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(..), 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                 [(Doc.brackets (docSchema xl), layoutInh_message inh <> xh)]
 205 instance (LayoutDoc d, Doc.Justifiable d) => Sequenceable (Layout d) where
 206         type Sequence (Layout d) = LayoutSeq d
 207         runSequence (LayoutSeq s h m) = Layout (runSequence s) h m
 208         toSequence (Layout s h m) = LayoutSeq (toSequence s) h m
 209         {-
 210         runSequence (LayoutSeq s h ps) = Layout sch h $ \inh -> do
 211                 modify' $ \k -> \case
 212                  Nothing -> k Nothing
 213                  Just ts -> k $ Just [Tree.Node nod mempty]
 214                         -- where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})
 215                         where
 216                         nod = LayoutNode_Forest mempty {-(docSchema sch)-}
 217                          (layoutInh_message inh) (gs <> ts)
 218                         gs = (<$> ps inh{layoutInh_message=[]}) $ \(d,ds) ->
 219                                 Tree.Node (LayoutNode_Single d ds) mempty
 220
 221                 where sch = runSequence s
 222         toSequence (Layout s h _m) = LayoutSeq (toSequence s) h $ \inh ->
 223                 [(docSchema s, layoutInh_message inh <> h)]
 224         -}
 225 instance Pro (Layout d) where
 226         dimap a2b b2a (Layout s h l) = Layout (dimap a2b b2a s) h l
 227 instance (LayoutDoc d, Doc.From Name d) => CLI_Command (Layout d) where
 228         command n (Layout xl xh xm) = Layout sch xh $ \inh -> do
 229                 modify' $ \k -> \case
 230                  Nothing -> k Nothing
 231                  Just ts -> k $ Just
 232                         [ Tree.Node
 233                                  ( LayoutNode_Single
 234                                          (Doc.magentaer $ docSchema $ command n nothing)
 235                                          (layoutInh_message inh)
 236                                  ) ts
 237                         ]
 238                 xm inh{layoutInh_message=[]}
 239                 where sch = command n xl
 240 instance (LayoutDoc d, Doc.Justifiable d) => CLI_Tag (Layout d) where
 241         type TagConstraint (Layout d) a = TagConstraint (Schema d) a
 242         tag n (Layout xs xh xm) = Layout (tag n xs) xh $ \inh -> do
 243                 modify' $ \k -> \case
 244                  Nothing -> k Nothing
 245                  Just ts -> k $ Just
 246                         [ Tree.Node
 247                          ( LayoutNode_List [] [
 248                                  ( docSchema (tag n nothing)
 249                                  , layoutInh_message inh
 250                                  )
 251                                 ]
 252                          ) ts
 253                         ]
 254                 xm inh{layoutInh_message=[]}
 255         endOpts = Layout sch [] $ \_inh -> do
 256                 modify' $ \k -> \case
 257                  Nothing -> k Nothing
 258                  Just ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []) ts]
 259                 where sch = endOpts
 260 instance LayoutDoc d => CLI_Var (Layout d) where
 261         type VarConstraint (Layout d) a = VarConstraint (Schema d) a
 262         var' n = Layout sch [] $ \inh -> do
 263                 modify' $ \k -> \case
 264                  Nothing -> k Nothing
 265                  Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
 266                         where h | List.null (layoutInh_message inh) = []
 267                                 | otherwise = [(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 | List.null (layoutInh_message inh) = []
 275                                 | otherwise = [(docSchema sch, layoutInh_message inh)]
 276                 where sch = constant c a
 277         just a  = Layout (just a) [] $ \_inh -> pure ()
 278         nothing = Layout nothing  [] $ \_inh -> pure ()
 279 instance LayoutDoc d => CLI_Env (Layout d) where
 280         type EnvConstraint (Layout d) a = EnvConstraint (Schema d) a
 281         env' n = Layout (env' n) [] $ \_inh -> pure ()
 282 instance LayoutDoc d => CLI_Help (Layout d) where
 283         type HelpConstraint (Layout d) d' = HelpConstraint (Schema d) d'
 284         help msg (Layout s _h m) = Layout
 285          (help msg s) [msg]
 286          (\inh -> m inh{layoutInh_message=[msg]})
 287         program n (Layout xl xh xm) = Layout sch xh $ \inh -> do
 288                 modify' $ \k -> \case
 289                  Nothing -> k Nothing
 290                  Just ts -> k $ Just
 291                          [ Tree.Node
 292                                  (LayoutNode_Single (Doc.magentaer $ docSchema $ program n nothing) [])
 293                                  ts
 294                          ]
 295                 xm inh
 296                 where sch = program n xl
 297         rule _n = id
 298 instance LayoutDoc d => CLI_Response (Layout d) where
 299         type ResponseConstraint (Layout d) a = ResponseConstraint (Schema d) a
 300         type ResponseArgs (Layout d) a = ResponseArgs (Schema d) a
 301         type Response (Layout d) = Response (Schema d)
 302         response' = Layout response' [] $ \_inh -> do
 303                 modify' $ \k -> \case
 304                  Nothing -> k $ Just []
 305                  Just ts -> k $ Just ts
 306
 307 -- ** Type 'LayoutSeq'
 308 data LayoutSeq d k a = LayoutSeq
 309  {   layoutSeq_schema :: SchemaSeq d k a
 310  ,   layoutSeq_help  :: [d]
 311  ,   layoutSeq_monad :: LayoutInh d -> State (LayoutState d) ()
 312  }
 313 instance Functor (LayoutSeq d k) where
 314         f`fmap`LayoutSeq s h m = LayoutSeq (f<$>s) h $ \inh -> m inh
 315 instance Applicative (LayoutSeq d k) where
 316         pure a = LayoutSeq (pure a) [] $ \_inh -> return ()
 317         LayoutSeq fs fh f <*> LayoutSeq xs xh x =
 318                 LayoutSeq (fs<*>xs) (fh<>xh) $ \inh -> f inh >> x inh
 319 instance LayoutDoc d => CLI_Help (LayoutSeq d) where
 320         type HelpConstraint (LayoutSeq d) d' = HelpConstraint (SchemaSeq d) d'
 321         help msg (LayoutSeq s _h m) = LayoutSeq (help msg s) [msg] $ \inh ->
 322                 m inh{layoutInh_message=[msg]}
 323         program n (LayoutSeq s h m) = LayoutSeq (program n s) h m
 324         rule    n (LayoutSeq s h m) = LayoutSeq (rule n s) h m
 325
 326 -- ** Type 'LayoutPerm'
 327 data LayoutPerm d k a = LayoutPerm
 328  {   layoutPerm_help :: [d]
 329  ,   layoutPerm_elem :: LayoutInh d -> [(d, {-help-}[d])]
 330  }
 331 instance Functor (LayoutPerm d k) where
 332         _f`fmap`LayoutPerm h ps = LayoutPerm h $ \inh -> ps inh
 333 instance Applicative (LayoutPerm d k) where
 334         pure _a = LayoutPerm [] $ \_inh -> []
 335         LayoutPerm _fh f <*> LayoutPerm _xh x =
 336                 LayoutPerm [] $ \inh -> f inh <> x inh
 337 instance LayoutDoc d => CLI_Help (LayoutPerm d) where
 338         type HelpConstraint (LayoutPerm d) d' = HelpConstraint (SchemaPerm d) d'
 339         help msg (LayoutPerm _h m) = LayoutPerm [msg] $ \inh ->
 340                 m inh{layoutInh_message=[msg]}
 341         program _n = id
 342         rule    _n = id
 343
 344 -- ** Type 'LayoutNode'
 345 data LayoutNode d
 346  =   LayoutNode_Single d {-help-}[d]
 347  |   LayoutNode_List [d] [(d, {-help-}[d])]
 348  |   LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))
 349  deriving (Show)