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(..), Alternative(..))
   9 import Control.Arrow (first)
  10 import Control.Monad (Monad(..), (>>))
  11 import Control.Monad.Trans.Class (MonadTrans(..))
  12 import Control.Monad.Trans.Reader
  13 import Control.Monad.Trans.State.Strict
  14 import Data.Bool
  15 import Data.Char (Char)
  16 import Data.Eq (Eq(..))
  17 import Data.Function (($), (.), id)
  18 import Data.Functor (Functor(..), (<$>))
  19 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
  20 import Data.Monoid (Monoid(..))
  21 import Data.Ord (Ord(..))
  22 import Data.Semigroup (Semigroup(..))
  23 import Data.String (String, IsString(..))
  24 import Data.Text (Text)
  25 import Data.Tree (Tree(..), Forest, drawForest)
  26 import Data.Tuple (snd)
  27 import System.IO (IO)
  28 import Text.Show (Show(..))
  29 import Text.Show (Show(..))
  30 import qualified Data.List as List
  31 import qualified Data.Text.Lazy as TL
  32 import qualified Data.Text.Lazy.Builder as TLB
  33 import qualified Data.Tree as Tree
  34 import qualified Symantic.Document as Doc
  35 import qualified System.IO as IO
  36
  37 import Symantic.CLI.API
  38 import Symantic.CLI.Fixity
  39 import Symantic.CLI.Schema
  40 import Symantic.CLI.Parser (output)
  41
  42 import Debug.Trace
  43
  44 -- * Type 'Layout'
  45 data Layout d f k = Layout
  46  { layoutSchema :: Schema d f k
  47  , layoutHelp   :: [d]
  48  , unLayout     :: LayoutInh d -> State (LayoutState d) ()
  49  }
  50
  51 runLayout :: LayoutDoc d => Bool -> Layout d f k -> d
  52 runLayout full (Layout _s _h l) =
  53         runLayoutForest full $
  54         fromMaybe [] $
  55         ($ (Just [])) $
  56         (`execState`id) $
  57         l defLayoutInh
  58
  59 -- ** Type 'LayoutInh'
  60 data LayoutInh d
  61  =   LayoutInh
  62  {   layoutInh_message :: ![d]
  63  }
  64
  65 defLayoutInh :: LayoutInh d
  66 defLayoutInh = LayoutInh
  67  { layoutInh_message = []
  68  }
  69
  70 -- ** Type 'LayoutState'
  71 type LayoutState d = Diff (Tree.Forest (LayoutNode d))
  72
  73 -- ** Type 'Diff'
  74 -- | A continuation-passing-style constructor,
  75 -- (each constructor prepending something),
  76 -- augmented with 'Maybe' to change the prepending
  77 -- according to what the following parts are.
  78 -- Used in '<!>' and 'alt' to know if branches
  79 -- lead to at least one route (ie. contain at least one 'response').
  80 type Diff a = Maybe a -> Maybe a
  81
  82 -- ** Type 'LayoutDoc'
  83 type LayoutDoc d =
  84  ( SchemaDoc d
  85  , Doc.Justifiable d
  86  )
  87
  88 runLayoutForest :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d
  89 runLayoutForest full = (<> Doc.newline) . Doc.catV . (runLayoutTree full <$>)
  90
  91 runLayoutTree :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> d
  92 runLayoutTree full =
  93         Doc.setIndent mempty 0 .
  94         Doc.catV . runLayoutNode full
  95
  96 runLayoutNode :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> [d]
  97 runLayoutNode full (Tree.Node n ts0) =
  98         (case n of
  99          LayoutNode_Tags ds -> (<$> ds) $ \(mh,sch) ->
 100                 case mh of
 101                  [] -> Doc.whiter sch
 102                  _ | not full -> Doc.whiter sch
 103                  h -> Doc.fillOrBreak 15 (Doc.whiter sch) <>
 104                         Doc.space <> Doc.align (Doc.justify (Doc.catV h))
 105          LayoutNode_Help mh sch ->
 106                 [ Doc.align $
 107                         case mh of
 108                          [] -> Doc.whiter sch
 109                          _ | not full -> Doc.whiter sch
 110                          h -> Doc.whiter sch <> Doc.newline <> Doc.justify (Doc.catV h)
 111                 ]
 112         ) <> docSubTrees ts0
 113         where
 114         docSubTrees [] = []
 115         docSubTrees [t] =
 116                 -- "|" :
 117                 shift (Doc.blacker "└──"<>Doc.space)
 118                       (Doc.spaces 4)
 119                       (Doc.incrIndent (Doc.spaces 4) 4 <$> runLayoutNode full t)
 120         docSubTrees (t:ts) =
 121                 -- "|" :
 122                 shift (Doc.blacker "├──"<>Doc.space)
 123                       (Doc.blacker "│"<>Doc.spaces 3)
 124                       (Doc.incrIndent (Doc.blacker "│"<>Doc.spaces 3) 4 <$> runLayoutNode full t)
 125                 <> docSubTrees ts
 126
 127         shift d ds =
 128                 List.zipWith (<>)
 129                  (d : List.repeat ds)
 130
 131 instance LayoutDoc d => App (Layout d) where
 132         Layout xs xh xm <.> Layout ys yh ym =
 133                 Layout (xs<.>ys) (xh<>yh) $ \inh ->
 134                         xm inh >> ym inh
 135 instance LayoutDoc d => Alt (Layout d) where
 136         Layout ls lh lm <!> Layout rs rh rm = Layout sch [] $ \inh -> do
 137                 k <- get
 138
 139                 put id
 140                 lm inh
 141                 lk <- get
 142
 143                 put id
 144                 rm inh
 145                 rk <- get
 146
 147                 put $
 148                         case (lk Nothing, rk Nothing) of
 149                          (Nothing, Nothing) -> \case
 150                                  Nothing -> k Nothing
 151                                  Just ts -> k $ Just [Tree.Node (LayoutNode_Help (lh<>rh) $ docSchema sch) ts]
 152                          (Just lt, Just rt) -> \case
 153                                  Nothing -> k $ Just (lt<>rt)
 154                                  Just ts -> k $ Just (lt<>rt<>ts)
 155                          (Just lt, Nothing) -> \case
 156                                  Nothing -> k $ Just lt
 157                                  Just ts -> k $ Just (lt<>ts)
 158                          (Nothing, Just rt) -> \case
 159                                  Nothing -> k $ Just rt
 160                                  Just ts -> k $ Just (rt<>ts)
 161                 where sch = ls<!>rs
 162         Layout ls lh lm `alt` Layout rs rh rm =
 163                 (Layout ls lh lm <!> Layout rs rh rm)
 164                  {layoutSchema=sch}
 165                 where sch = ls`alt`rs
 166         opt (Layout xs xh xm) = Layout sch xh $ \inh -> do
 167                 modify' $ \k -> \case
 168                  Nothing -> k Nothing
 169                  Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] mempty{-FIXME-}) ts]
 170                 xm inh
 171                 where sch = opt xs
 172 instance Pro (Layout d) where
 173         dimap a2b b2a (Layout s h l) = Layout (dimap a2b b2a s) h l
 174 instance (LayoutDoc d, Doc.From Name d) => CLI_Command (Layout d) where
 175         command n (Layout xl xh xm) = Layout sch xh $ \inh -> do
 176                 modify' $ \k -> \case
 177                  Nothing -> k Nothing
 178                  Just ts -> k $ Just
 179                         [ Tree.Node
 180                                  ( LayoutNode_Help (layoutInh_message inh)
 181                                  $ Doc.magentaer $ docSchema $ command n nothing
 182                                  ) ts
 183                         ]
 184                 xm inh
 185                 where sch = command n xl
 186 instance (LayoutDoc d, Doc.Justifiable d) => CLI_Tag (Layout d) where
 187         type TagConstraint (Layout d) a = TagConstraint (Schema d) a
 188         tagged n (Layout xs xh xm) = Layout (tagged n xs) xh $ \inh -> do
 189                 modify' $ \k -> \case
 190                  Nothing -> k Nothing
 191                  Just ts -> k $ Just
 192                         [ Tree.Node
 193                          ( LayoutNode_Tags [
 194                                  ( layoutInh_message inh
 195                                  , docSchema (tagged n nothing)
 196                                  )
 197                                 ]
 198                          ) ts
 199                         ]
 200                 xm inh
 201         endOpts = Layout sch [] $ \inh -> do
 202                 modify' $ \k -> \case
 203                  Nothing -> k Nothing
 204                  Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] $ docSchema sch) ts]
 205                 where sch = endOpts
 206 instance LayoutDoc d => CLI_Var (Layout d) where
 207         type VarConstraint (Layout d) a = VarConstraint (Schema d) a
 208         var' n = Layout sch [] $ \inh -> do
 209                 modify' $ \k -> \case
 210                  Nothing -> k Nothing
 211                  Just ts -> k $ Just [Tree.Node (LayoutNode_Help [] $ docSchema sch) ts]
 212                 where sch = var' n
 213         just a  = Layout (just a) [] $ \_inh -> pure ()
 214         nothing = Layout nothing  [] $ \_inh -> pure ()
 215 instance LayoutDoc d => CLI_Env (Layout d) where
 216         type EnvConstraint (Layout d) a = EnvConstraint (Schema d) a
 217         env' n = Layout (env' n) [] $ \_inh -> pure ()
 218 instance LayoutDoc d => CLI_Help (Layout d) where
 219         type HelpConstraint (Layout d) d' = HelpConstraint (Schema d) d'
 220         help msg (Layout s _h m) = Layout
 221          (help msg s) [msg]
 222          (\inh -> m inh{layoutInh_message=[msg]})
 223         program n (Layout xl xh xm) = Layout sch xh $ \inh -> do
 224                 modify' $ \k -> \case
 225                  Nothing -> k Nothing
 226                  Just ts -> k $ Just
 227                          [ Tree.Node
 228                                  (LayoutNode_Help [] $ Doc.magentaer $ docSchema $ program n nothing)
 229                                  ts
 230                          ]
 231                 xm inh
 232                 where sch = program n xl
 233         rule _n = id
 234 instance LayoutDoc d => CLI_Response (Layout d) where
 235         type ResponseConstraint (Layout d) a = ResponseConstraint (Schema d) a
 236         type ResponseArgs (Layout d) a = ResponseArgs (Schema d) a
 237         type Response (Layout d) = Response (Schema d)
 238         response' = Layout response' [] $ \inh -> do
 239                 modify' $ \k -> \case
 240                  Nothing -> k $ Just []
 241                  Just ts -> k $ Just ts
 242
 243 -- ** Type 'LayoutPerm'
 244 data LayoutPerm d k a = LayoutPerm
 245  { layoutPerm_help :: [d]
 246  , layoutPerm_elem :: LayoutInh d -> [([d], d)]
 247  }
 248 instance Functor (LayoutPerm d k) where
 249         _f`fmap`LayoutPerm h ps = LayoutPerm h $ \inh -> ps inh
 250 instance Applicative (LayoutPerm d k) where
 251         pure _a = LayoutPerm [] $ \_inh -> []
 252         LayoutPerm fh f <*> LayoutPerm xh x =
 253                 LayoutPerm [] $ \inh -> f inh <> x inh
 254 instance (LayoutDoc d, Doc.Justifiable d) => Permutable (Layout d) where
 255         type Permutation (Layout d) = LayoutPerm d
 256         runPermutation (LayoutPerm h ps) = Layout sch h $ \inh -> do
 257                 modify' $ \k -> \case
 258                  Nothing -> k Nothing
 259                  Just ts -> k $ Just [Tree.Node (LayoutNode_Tags (ps inh)) ts]
 260                 where
 261                 sch = runPermutation $ SchemaPerm id []
 262         toPermutation (Layout xl xh xm) = LayoutPerm [] $ \inh ->
 263                 [(layoutInh_message inh <> xh, docSchema xl)]
 264         toPermDefault a (Layout xl xh xm) = LayoutPerm [] $ \inh ->
 265                 [(layoutInh_message inh <> xh, Doc.brackets (docSchema xl))]
 266 instance LayoutDoc d => CLI_Help (LayoutPerm d) where
 267         type HelpConstraint (LayoutPerm d) d' = HelpConstraint (SchemaPerm d) d'
 268         help msg (LayoutPerm h m) = LayoutPerm [msg] $ \inh ->
 269                 m inh{layoutInh_message=[msg]}
 270         program n = id
 271         rule    n = id
 272
 273 -- ** Type 'LayoutNode'
 274 data LayoutNode d
 275  =   LayoutNode_Help [d] d
 276  |   LayoutNode_Tags [([d], d)]
 277  deriving (Show)