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