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