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  , unLayout     :: 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 runLayoutTree :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> d
  79 runLayoutTree full =
  80         Doc.setIndent mempty 0 .
  81         Doc.catV . runLayoutNode full
  82
  83 runLayoutNode :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> [d]
  84 runLayoutNode full (Tree.Node n ts0) =
  85         (case n of
  86          LayoutNode_Tags ds -> (<$> ds) $ \(mh,sch) ->
  87                 case mh of
  88                  [] -> Doc.whiter sch
  89                  _ | not full -> Doc.whiter sch
  90                  h -> Doc.fillOrBreak 15 (Doc.whiter sch) <>
  91                         Doc.space <> Doc.align (Doc.justify (Doc.catV h))
  92          LayoutNode_Help mh sch ->
  93                 [ Doc.align $
  94                         case mh of
  95                          [] -> Doc.whiter sch
  96                          _ | not full -> Doc.whiter sch
  97                          h -> Doc.whiter sch <> Doc.newline <> Doc.justify (Doc.catV h)
  98                 ]
  99         ) <> docSubTrees ts0
 100         where
 101         docSubTrees [] = []
 102         docSubTrees [t] =
 103                 -- "|" :
 104                 shift (Doc.blacker "└──"<>Doc.space)
 105                       (Doc.spaces 4)
 106                       (Doc.incrIndent (Doc.spaces 4) 4 <$> runLayoutNode full t)
 107         docSubTrees (t:ts) =
 108                 -- "|" :
 109                 shift (Doc.blacker "├──"<>Doc.space)
 110                       (Doc.blacker "│"<>Doc.spaces 3)
 111                       (Doc.incrIndent (Doc.blacker "│"<>Doc.spaces 3) 4 <$> runLayoutNode full t)
 112                 <> docSubTrees ts
 113
 114         shift d ds =
 115                 List.zipWith (<>)
 116                  (d : List.repeat ds)
 117
 118 instance LayoutDoc d => App (Layout d) where
 119         Layout xs xh xm <.> Layout ys yh ym =
 120                 Layout (xs<.>ys) (xh<>yh) $ \inh ->
 121                         xm inh >> ym inh
 122 instance LayoutDoc d => Alt (Layout d) where
 123         Layout ls lh lm <!> Layout rs rh rm = Layout sch [] $ \inh -> do
 124                 k <- get
 125
 126                 put id
 127                 lm inh
 128                 lk <- get
 129
 130                 put id
 131                 rm inh
 132                 rk <- get
 133
 134                 put $
 135                         case (lk Nothing, rk Nothing) of
 136                          (Nothing, Nothing) -> \case
 137                                  Nothing -> k Nothing
 138                                  Just ts -> k $ Just [Tree.Node (LayoutNode_Help (lh<>rh) $ docSchema sch) ts]
 139                          (Just lt, Just rt) -> \case
 140                                  Nothing -> k $ Just (lt<>rt)
 141                                  Just ts -> k $ Just (lt<>rt<>ts)
 142                          (Just lt, Nothing) -> \case
 143                                  Nothing -> k $ Just lt
 144                                  Just ts -> k $ Just (lt<>ts)
 145                          (Nothing, Just rt) -> \case
 146                                  Nothing -> k $ Just rt
 147                                  Just ts -> k $ Just (rt<>ts)
 148                 where sch = ls<!>rs
 149         Layout ls lh lm `alt` Layout rs rh rm =
 150                 (Layout ls lh lm <!> Layout rs rh rm)
 151                  {layoutSchema=sch}
 152                 where sch = ls`alt`rs
 153         opt (Layout xs xh xm) = Layout sch xh $ \inh -> do
 154                 modify' $ \k -> \case
 155                  Nothing -> k Nothing
 156                  Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] mempty{-FIXME-}) ts]
 157                 xm inh
 158                 where sch = opt xs
 159 instance Pro (Layout d) where
 160         dimap a2b b2a (Layout s h l) = Layout (dimap a2b b2a s) h l
 161 instance (LayoutDoc d, Doc.From Name d) => CLI_Command (Layout d) where
 162         command n (Layout xl xh xm) = Layout sch xh $ \inh -> do
 163                 modify' $ \k -> \case
 164                  Nothing -> k Nothing
 165                  Just ts -> k $ Just
 166                         [ Tree.Node
 167                                  ( LayoutNode_Help (layoutInh_message inh)
 168                                  $ Doc.magentaer $ docSchema $ command n nothing
 169                                  ) ts
 170                         ]
 171                 xm inh
 172                 where sch = command n xl
 173 instance (LayoutDoc d, Doc.Justifiable d) => CLI_Tag (Layout d) where
 174         type TagConstraint (Layout d) a = TagConstraint (Schema d) a
 175         tagged n (Layout xs xh xm) = Layout (tagged n xs) xh $ \inh -> do
 176                 modify' $ \k -> \case
 177                  Nothing -> k Nothing
 178                  Just ts -> k $ Just
 179                         [ Tree.Node
 180                          ( LayoutNode_Tags [
 181                                  ( layoutInh_message inh
 182                                  , docSchema (tagged n nothing)
 183                                  )
 184                                 ]
 185                          ) ts
 186                         ]
 187                 xm inh
 188         endOpts = Layout sch [] $ \_inh -> do
 189                 modify' $ \k -> \case
 190                  Nothing -> k Nothing
 191                  Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] $ docSchema sch) ts]
 192                 where sch = endOpts
 193 instance LayoutDoc d => CLI_Var (Layout d) where
 194         type VarConstraint (Layout d) a = VarConstraint (Schema d) a
 195         var' n = Layout sch [] $ \_inh -> do
 196                 modify' $ \k -> \case
 197                  Nothing -> k Nothing
 198                  Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] $ docSchema sch) ts]
 199                 where sch = var' n
 200         just a  = Layout (just a) [] $ \_inh -> pure ()
 201         nothing = Layout nothing  [] $ \_inh -> pure ()
 202 instance LayoutDoc d => CLI_Env (Layout d) where
 203         type EnvConstraint (Layout d) a = EnvConstraint (Schema d) a
 204         env' n = Layout (env' n) [] $ \_inh -> pure ()
 205 instance LayoutDoc d => CLI_Help (Layout d) where
 206         type HelpConstraint (Layout d) d' = HelpConstraint (Schema d) d'
 207         help msg (Layout s _h m) = Layout
 208          (help msg s) [msg]
 209          (\inh -> m inh{layoutInh_message=[msg]})
 210         program n (Layout xl xh xm) = Layout sch xh $ \inh -> do
 211                 modify' $ \k -> \case
 212                  Nothing -> k Nothing
 213                  Just ts -> k $ Just
 214                          [ Tree.Node
 215                                  (LayoutNode_Help [] $ Doc.magentaer $ docSchema $ program n nothing)
 216                                  ts
 217                          ]
 218                 xm inh
 219                 where sch = program n xl
 220         rule _n = id
 221 instance LayoutDoc d => CLI_Response (Layout d) where
 222         type ResponseConstraint (Layout d) a = ResponseConstraint (Schema d) a
 223         type ResponseArgs (Layout d) a = ResponseArgs (Schema d) a
 224         type Response (Layout d) = Response (Schema d)
 225         response' = Layout response' [] $ \_inh -> do
 226                 modify' $ \k -> \case
 227                  Nothing -> k $ Just []
 228                  Just ts -> k $ Just ts
 229
 230 -- ** Type 'LayoutPerm'
 231 data LayoutPerm d k a = LayoutPerm
 232  { layoutPerm_help :: [d]
 233  , layoutPerm_elem :: LayoutInh d -> [([d], d)]
 234  }
 235 instance Functor (LayoutPerm d k) where
 236         _f`fmap`LayoutPerm h ps = LayoutPerm h $ \inh -> ps inh
 237 instance Applicative (LayoutPerm d k) where
 238         pure _a = LayoutPerm [] $ \_inh -> []
 239         LayoutPerm _fh f <*> LayoutPerm _xh x =
 240                 LayoutPerm [] $ \inh -> f inh <> x inh
 241 instance (LayoutDoc d, Doc.Justifiable d) => Permutable (Layout d) where
 242         type Permutation (Layout d) = LayoutPerm d
 243         runPermutation (LayoutPerm h ps) = Layout sch h $ \inh -> do
 244                 modify' $ \k -> \case
 245                  Nothing -> k Nothing
 246                  Just ts -> k $ Just [Tree.Node (LayoutNode_Tags (ps inh)) ts]
 247                 where
 248                 sch = runPermutation $ SchemaPerm id []
 249         toPermutation (Layout xl xh _xm) = LayoutPerm [] $ \inh ->
 250                 [(layoutInh_message inh <> xh, docSchema xl)]
 251         toPermDefault _a (Layout xl xh _xm) = LayoutPerm [] $ \inh ->
 252                 [(layoutInh_message inh <> xh, Doc.brackets (docSchema xl))]
 253 instance LayoutDoc d => CLI_Help (LayoutPerm d) where
 254         type HelpConstraint (LayoutPerm d) d' = HelpConstraint (SchemaPerm d) d'
 255         help msg (LayoutPerm _h m) = LayoutPerm [msg] $ \inh ->
 256                 m inh{layoutInh_message=[msg]}
 257         program _n = id
 258         rule    _n = id
 259
 260 -- ** Type 'LayoutNode'
 261 data LayoutNode d
 262  =   LayoutNode_Help [d] d
 263  |   LayoutNode_Tags [([d], d)]
 264  deriving (Show)