Symantic/CLI/Layout.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# LANGUAGE Rank2Types #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
   6 module Symantic.CLI.Layout where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Control.Monad (Monad(..), (>>))
  10 import Control.Monad.Trans.State.Strict
  11 import Data.Bool
  12 import Data.Function (($), (.), id)
  13 import Data.Functor (Functor(..), (<$>))
  14 import Data.Maybe (Maybe(..), maybe, fromMaybe)
  15 import Data.Monoid (Monoid(..))
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.Tree (Tree(..), Forest)
  18 import Text.Show (Show(..))
  19 import qualified Data.List as List
  20 import qualified Data.Tree as Tree
  21 import qualified Symantic.Document as Doc
  22
  23 import Symantic.CLI.API
  24 import Symantic.CLI.Schema
  25
  26 -- * Type 'Layout'
  27 data Layout d f k = Layout
  28  { layoutSchema :: Schema d f k
  29    -- ^ Synthetized (bottom-up) 'Schema'.
  30    -- Useful for complex grammar rules or 'alt'ernatives associated
  31    -- to the left of a 'response'.
  32  , layoutHelp   :: [d]
  33    -- ^ Synthetized (bottom-up) 'help'.
  34    -- Useful in 'LayoutPerm' to merge nested 'help'
  35    -- and nesting 'help' of the permutation.
  36  , layoutMonad  :: LayoutInh d -> State (LayoutState d) ()
  37  }
  38
  39 runLayout :: LayoutDoc d => Bool -> Layout d f k -> d
  40 runLayout full (Layout _s _h l) =
  41         runLayoutForest full $
  42         fromMaybe [] $
  43         ($ (Just [])) $
  44         (`execState`id) $
  45         l defLayoutInh
  46
  47 coerceLayout :: Layout d f k -> Layout d f' k'
  48 coerceLayout (Layout s h l) = Layout (coerceSchema s) h l
  49
  50 instance Semigroup d => Semigroup (Layout d f k) where
  51         Layout xs xh xm <> Layout ys yh ym =
  52                 Layout (xs<>ys) (xh<>yh) $ \inh ->
  53                         xm inh >> ym inh
  54
  55 -- ** Type 'LayoutInh'
  56 newtype LayoutInh d = LayoutInh
  57  { layoutInh_message :: {-!-}[d]
  58  }
  59
  60 defLayoutInh :: LayoutInh d
  61 defLayoutInh = LayoutInh
  62  { layoutInh_message = []
  63  }
  64
  65 -- ** Type 'LayoutState'
  66 type LayoutState d = Diff (Tree.Forest (LayoutNode d))
  67
  68 -- ** Type 'Diff'
  69 -- | A continuation-passing-style constructor,
  70 -- (each constructor prepending something),
  71 -- augmented with 'Maybe' to change the prepending
  72 -- according to what the following parts are.
  73 -- Used in '<!>' and 'alt' to know if branches
  74 -- lead to at least one route (ie. contain at least one 'response').
  75 type Diff a = Maybe a -> Maybe a
  76
  77 -- ** Type 'LayoutDoc'
  78 type LayoutDoc d =
  79  ( SchemaDoc d
  80  , Doc.Justifiable d
  81  )
  82
  83 runLayoutForest :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d
  84 runLayoutForest full = (<> Doc.newline) . Doc.catV . (runLayoutTree full <$>)
  85
  86 runLayoutForest' :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d
  87 runLayoutForest' full = Doc.catV . (runLayoutTree full <$>)
  88
  89 runLayoutTree :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> d
  90 runLayoutTree full =
  91         -- Doc.setIndent mempty 0 .
  92         Doc.catV . runLayoutNode full
  93
  94 runLayoutNode :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> [d]
  95 runLayoutNode full (Tree.Node n ts0) =
  96         (case n of
  97          LayoutNode_Single sch mh ->
  98                 [ Doc.align $
  99                         case mh of
 100                          [] -> Doc.whiter sch
 101                          _ | not full -> Doc.whiter sch
 102                          h -> Doc.whiter sch <> Doc.newline <> Doc.justify (Doc.catV h)
 103                 ]
 104          LayoutNode_List ns ds ->
 105                 ((if full then ns else []) <>) $
 106                 (<$> ds) $ \(sch, mh) ->
 107                         case mh of
 108                          [] ->
 109                                 Doc.whiter sch
 110                          _ | not full -> Doc.whiter sch
 111                          h ->
 112                                 Doc.fillOrBreak 15 (Doc.whiter sch) <>
 113                                         Doc.space <> Doc.align (Doc.justify (Doc.catV h))
 114          LayoutNode_Forest sch ds ts ->
 115                 [Doc.whiter sch] <>
 116                 (if List.null ds || not full then [] else [Doc.catV ds]) <>
 117                 (if List.null ts then [] else [runLayoutForest' full ts])
 118         ) <> docSubTrees ts0
 119         where
 120         docSubTrees [] = []
 121         docSubTrees [t] =
 122                 -- "|" :
 123                 shift (Doc.blacker "└──"<>Doc.space)
 124                       (Doc.spaces 4)
 125                       (Doc.incrIndent (Doc.spaces 4) 4 <$> runLayoutNode full t)
 126         docSubTrees (t:ts) =
 127                 -- "|" :
 128                 shift (Doc.blacker "├──"<>Doc.space)
 129                       (Doc.blacker "│"<>Doc.spaces 3)
 130                       (Doc.incrIndent (Doc.blacker "│"<>Doc.spaces 3) 4 <$> runLayoutNode full t)
 131                 <> docSubTrees ts
 132
 133         shift d ds =
 134                 List.zipWith (<>)
 135                  (d : List.repeat ds)
 136
 137 instance LayoutDoc d => App (Layout d) where
 138         Layout xs xh xm <.> Layout ys yh ym =
 139                 Layout (xs<.>ys) (xh<>yh) $ \inh ->
 140                         xm inh >> ym inh
 141 instance LayoutDoc d => Alt (Layout d) where
 142         Layout ls lh lm <!> Layout rs rh rm = Layout sch [] $ \inh -> do
 143                 k <- get
 144
 145                 put id
 146                 lm inh
 147                 lk <- get
 148
 149                 put id
 150                 rm inh
 151                 rk <- get
 152
 153                 put $
 154                         case (lk Nothing, rk Nothing) of
 155                          (Nothing, Nothing) -> \case
 156                                  Nothing -> k Nothing
 157                                  Just ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) (lh<>rh)) ts]
 158                          (Just lt, Just rt) -> \case
 159                                  Nothing -> k $ Just (lt<>rt)
 160                                  Just ts -> k $ Just (lt<>rt<>ts)
 161                          (Just lt, Nothing) -> \case
 162                                  Nothing -> k $ Just lt
 163                                  Just ts -> k $ Just (lt<>ts)
 164                          (Nothing, Just rt) -> \case
 165                                  Nothing -> k $ Just rt
 166                                  Just ts -> k $ Just (rt<>ts)
 167                 where sch = ls<!>rs
 168         Layout ls lh lm `alt` Layout rs rh rm =
 169                 (Layout ls lh lm <!> Layout rs rh rm)
 170                  {layoutSchema=sch}
 171                 where sch = ls`alt`rs
 172         opt (Layout xs xh xm) = Layout sch xh $ \inh -> do
 173                 modify' $ \k -> \case
 174                  Nothing -> k Nothing
 175                  Just _ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []{-FIXME-}) mempty]
 176                 xm inh
 177                 where sch = opt xs
 178 instance LayoutDoc d => AltApp (Layout d) where
 179         many0 (Layout xs xh xm) = Layout sch xh $ \inh -> do
 180                 modify' $ \k -> \case
 181                  Nothing -> k Nothing
 182                  Just ts -> k $ Just [Tree.Node nod mempty]
 183                         where nod = LayoutNode_Forest (docSchema sch) (layoutInh_message inh) ts
 184                 xm inh{layoutInh_message=[]}
 185                 where sch = many0 xs
 186         many1 (Layout xs xh xm) = Layout sch xh $ \inh -> do
 187                 modify' $ \k -> \case
 188                  Nothing -> k Nothing
 189                  Just ts -> k $ Just [Tree.Node nod mempty]
 190                         where nod = LayoutNode_Forest (docSchema sch) (layoutInh_message inh) ts
 191                 xm inh{layoutInh_message=[]}
 192                 where sch = many1 xs
 193 instance (LayoutDoc d, Doc.Justifiable d) => Permutable (Layout d) where
 194         type Permutation (Layout d) = LayoutPerm d
 195         runPermutation (LayoutPerm h ps) = Layout sch h $ \inh -> do
 196                 modify' $ \k -> \case
 197                  Nothing -> k Nothing
 198                  Just ts -> k $ Just [Tree.Node nod ts]
 199                         where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})
 200                 where sch = runPermutation $ SchemaPerm id []
 201         toPermutation (Layout xl xh _xm) = LayoutPerm [] $ \inh ->
 202                 [(docSchema xl, layoutInh_message inh <> xh)]
 203         toPermDefault _a (Layout xl xh _xm) = LayoutPerm [] $ \inh ->
 204                 maybe [] (\sch -> [(Doc.brackets sch, layoutInh_message inh <> xh)]) $
 205                 unSchema xl defSchemaInh
 206 instance (LayoutDoc d, Doc.Justifiable d) => Sequenceable (Layout d) where
 207         type Sequence (Layout d) = LayoutSeq d
 208         runSequence (LayoutSeq s h m) = Layout (runSequence s) h m
 209         toSequence (Layout s h m) = LayoutSeq (toSequence s) h m
 210         {-
 211         runSequence (LayoutSeq s h ps) = Layout sch h $ \inh -> do
 212                 modify' $ \k -> \case
 213                  Nothing -> k Nothing
 214                  Just ts -> k $ Just [Tree.Node nod mempty]
 215                         -- where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})
 216                         where
 217                         nod = LayoutNode_Forest mempty {-(docSchema sch)-}
 218                          (layoutInh_message inh) (gs <> ts)
 219                         gs = (<$> ps inh{layoutInh_message=[]}) $ \(d,ds) ->
 220                                 Tree.Node (LayoutNode_Single d ds) mempty
 221
 222                 where sch = runSequence s
 223         toSequence (Layout s h _m) = LayoutSeq (toSequence s) h $ \inh ->
 224                 [(docSchema s, layoutInh_message inh <> h)]
 225         -}
 226 instance Pro (Layout d) where
 227         dimap a2b b2a (Layout s h l) = Layout (dimap a2b b2a s) h l
 228 instance (LayoutDoc d, Doc.From Name d) => CLI_Command (Layout d) where
 229         command n (Layout xl xh xm) = Layout sch xh $ \inh -> do
 230                 modify' $ \k -> \case
 231                  Nothing -> k Nothing
 232                  Just ts -> k $ Just
 233                         [ Tree.Node
 234                                  ( LayoutNode_Single
 235                                          (Doc.magentaer $ docSchema $ command n nothing)
 236                                          (layoutInh_message inh)
 237                                  ) ts
 238                         ]
 239                 xm inh{layoutInh_message=[]}
 240                 where sch = command n xl
 241 instance (LayoutDoc d, Doc.Justifiable d) => CLI_Tag (Layout d) where
 242         type TagConstraint (Layout d) a = TagConstraint (Schema d) a
 243         tag n (Layout xs xh xm) = Layout (tag n xs) xh $ \inh -> do
 244                 modify' $ \k -> \case
 245                  Nothing -> k Nothing
 246                  Just ts -> k $ Just
 247                         [ Tree.Node
 248                          ( LayoutNode_List [] [
 249                                  ( docSchema (tag n nothing)
 250                                  , layoutInh_message inh
 251                                  )
 252                                 ]
 253                          ) ts
 254                         ]
 255                 xm inh{layoutInh_message=[]}
 256         endOpts = Layout sch [] $ \_inh -> do
 257                 modify' $ \k -> \case
 258                  Nothing -> k Nothing
 259                  Just ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []) ts]
 260                 where sch = endOpts
 261 instance LayoutDoc d => CLI_Var (Layout d) where
 262         type VarConstraint (Layout d) a = VarConstraint (Schema d) a
 263         var' n = Layout sch [] $ \inh -> do
 264                 modify' $ \k -> \case
 265                  Nothing -> k Nothing
 266                  Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
 267                         where h = [(docSchema sch, layoutInh_message inh)]
 268                 where sch = var' n
 269 instance LayoutDoc d => CLI_Constant (Layout d) where
 270         constant c a = Layout sch [] $ \inh -> do
 271                 modify' $ \k -> \case
 272                  Nothing -> k Nothing
 273                  Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
 274                         where h = [(docSchema sch, layoutInh_message inh)]
 275                 where sch = constant c a
 276         just a  = Layout (just a) [] $ \_inh -> pure ()
 277         nothing = Layout nothing  [] $ \_inh -> pure ()
 278 instance LayoutDoc d => CLI_Env (Layout d) where
 279         type EnvConstraint (Layout d) a = EnvConstraint (Schema d) a
 280         env' n = Layout (env' n) [] $ \_inh -> pure ()
 281 instance LayoutDoc d => CLI_Help (Layout d) where
 282         type HelpConstraint (Layout d) d' = HelpConstraint (Schema d) d'
 283         help msg (Layout s _h m) = Layout
 284          (help msg s) [msg]
 285          (\inh -> m inh{layoutInh_message=[msg]})
 286         program n (Layout xl xh xm) = Layout sch xh $ \inh -> do
 287                 modify' $ \k -> \case
 288                  Nothing -> k Nothing
 289                  Just ts -> k $ Just
 290                          [ Tree.Node
 291                                  (LayoutNode_Single (Doc.magentaer $ docSchema $ program n nothing) [])
 292                                  ts
 293                          ]
 294                 xm inh
 295                 where sch = program n xl
 296         rule _n = id
 297 instance LayoutDoc d => CLI_Response (Layout d) where
 298         type ResponseConstraint (Layout d) a = ResponseConstraint (Schema d) a
 299         type ResponseArgs (Layout d) a = ResponseArgs (Schema d) a
 300         type Response (Layout d) = Response (Schema d)
 301         response' = Layout response' [] $ \_inh -> do
 302                 modify' $ \k -> \case
 303                  Nothing -> k $ Just []
 304                  Just ts -> k $ Just ts
 305
 306 -- ** Type 'LayoutSeq'
 307 data LayoutSeq d k a = LayoutSeq
 308  {   layoutSeq_schema :: SchemaSeq d k a
 309  ,   layoutSeq_help  :: [d]
 310  ,   layoutSeq_monad :: LayoutInh d -> State (LayoutState d) ()
 311  }
 312 instance Functor (LayoutSeq d k) where
 313         f`fmap`LayoutSeq s h m = LayoutSeq (f<$>s) h $ \inh -> m inh
 314 instance Applicative (LayoutSeq d k) where
 315         pure a = LayoutSeq (pure a) [] $ \_inh -> return ()
 316         LayoutSeq fs fh f <*> LayoutSeq xs xh x =
 317                 LayoutSeq (fs<*>xs) (fh<>xh) $ \inh -> f inh >> x inh
 318 instance LayoutDoc d => CLI_Help (LayoutSeq d) where
 319         type HelpConstraint (LayoutSeq d) d' = HelpConstraint (SchemaSeq d) d'
 320         help msg (LayoutSeq s _h m) = LayoutSeq (help msg s) [msg] $ \inh ->
 321                 m inh{layoutInh_message=[msg]}
 322         program n (LayoutSeq s h m) = LayoutSeq (program n s) h m
 323         rule    n (LayoutSeq s h m) = LayoutSeq (rule n s) h m
 324
 325 -- ** Type 'LayoutPerm'
 326 data LayoutPerm d k a = LayoutPerm
 327  {   layoutPerm_help :: [d]
 328  ,   layoutPerm_alts :: LayoutInh d -> [(d, {-help-}[d])]
 329  }
 330 instance Functor (LayoutPerm d k) where
 331         _f`fmap`LayoutPerm h ps = LayoutPerm h $ \inh -> ps inh
 332 instance Applicative (LayoutPerm d k) where
 333         pure _a = LayoutPerm [] $ \_inh -> []
 334         LayoutPerm _fh f <*> LayoutPerm _xh x =
 335                 LayoutPerm [] $ \inh -> f inh <> x inh
 336 instance LayoutDoc d => CLI_Help (LayoutPerm d) where
 337         type HelpConstraint (LayoutPerm d) d' = HelpConstraint (SchemaPerm d) d'
 338         help msg (LayoutPerm _h m) = LayoutPerm [msg] $ \inh ->
 339                 m inh{layoutInh_message=[msg]}
 340         program _n = id
 341         rule    _n = id
 342
 343 -- ** Type 'LayoutNode'
 344 data LayoutNode d
 345  =   LayoutNode_Single d {-help-}[d]
 346  |   LayoutNode_List [d] [(d, {-help-}[d])]
 347  |   LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))
 348  deriving (Show)