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
8 import Control.Applicative (Applicative(..))
9 import Control.Monad (Monad(..), (>>))
10 import Control.Monad.Trans.State.Strict
12 import Data.Function (($), (.), id)
13 import Data.Functor (Functor(..), (<$>))
14 import Data.Maybe (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
23 import Symantic.CLI.API
24 import Symantic.CLI.Schema
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'.
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) ()
39 runLayout :: LayoutDoc d => Bool -> Layout d f k -> d
40 runLayout full (Layout _s _h l) =
41 runLayoutForest full $
47 coerceLayout :: Layout d f k -> Layout d f' k'
48 coerceLayout (Layout s h l) = Layout (coerceSchema s) h l
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 ->
55 -- ** Type 'LayoutInh'
56 newtype LayoutInh d = LayoutInh
57 { layoutInh_message :: {-!-}[d]
60 defLayoutInh :: LayoutInh d
61 defLayoutInh = LayoutInh
62 { layoutInh_message = []
65 -- ** Type 'LayoutState'
66 type LayoutState d = Diff (Tree.Forest (LayoutNode d))
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
77 -- ** Type 'LayoutDoc'
83 runLayoutForest :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d
84 runLayoutForest full = (<> Doc.newline) . Doc.catV . (runLayoutTree full <$>)
86 runLayoutForest' :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d
87 runLayoutForest' full = Doc.catV . (runLayoutTree full <$>)
89 runLayoutTree :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> d
91 -- Doc.setIndent mempty 0 .
92 Doc.catV . runLayoutNode full
94 runLayoutNode :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> [d]
95 runLayoutNode full (Tree.Node n ts0) =
97 LayoutNode_Single sch mh ->
101 _ | not full -> Doc.whiter sch
102 h -> Doc.whiter sch <> Doc.newline <> Doc.justify (Doc.catV h)
104 LayoutNode_List ns ds ->
105 ((if full then ns else []) <>) $
106 (<$> ds) $ \(sch, mh) ->
110 _ | not full -> Doc.whiter sch
112 Doc.fillOrBreak 15 (Doc.whiter sch) <>
113 Doc.space <> Doc.align (Doc.justify (Doc.catV h))
114 LayoutNode_Forest sch ds ts ->
116 (if List.null ds || not full then [] else [Doc.catV ds]) <>
117 (if List.null ts then [] else [runLayoutForest' full ts])
123 shift (Doc.blacker "└──"<>Doc.space)
125 (Doc.incrIndent (Doc.spaces 4) 4 <$> runLayoutNode full t)
128 shift (Doc.blacker "├──"<>Doc.space)
129 (Doc.blacker "│"<>Doc.spaces 3)
130 (Doc.incrIndent (Doc.blacker "│"<>Doc.spaces 3) 4 <$> runLayoutNode full t)
137 instance LayoutDoc d => App (Layout d) where
138 Layout xs xh xm <.> Layout ys yh ym =
139 Layout (xs<.>ys) (xh<>yh) $ \inh ->
141 instance LayoutDoc d => Alt (Layout d) where
142 Layout ls lh lm <!> Layout rs rh rm = Layout sch [] $ \inh -> do
154 case (lk Nothing, rk Nothing) of
155 (Nothing, Nothing) -> \case
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)
168 Layout ls lh lm `alt` Layout rs rh rm =
169 (Layout ls lh lm <!> Layout rs rh rm)
171 where sch = ls`alt`rs
172 opt (Layout xs xh xm) = Layout sch xh $ \inh -> do
173 modify' $ \k -> \case
175 Just _ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []{-FIXME-}) mempty]
178 instance LayoutDoc d => AltApp (Layout d) where
179 many0 (Layout xs xh xm) = Layout sch xh $ \inh -> do
180 modify' $ \k -> \case
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=[]}
186 many1 (Layout xs xh xm) = Layout sch xh $ \inh -> do
187 modify' $ \k -> \case
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=[]}
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
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 maybe [] (\sch -> [(Doc.brackets sch, layoutInh_message inh <> xh)]) $
205 unSchema xl defSchemaInh
206 instance (LayoutDoc d, Doc.Justifiable d) => Sequenceable (Layout d) where
207 type Sequence (Layout d) = LayoutSeq d
208 runSequence (LayoutSeq s h m) = Layout (runSequence s) h m
209 toSequence (Layout s h m) = LayoutSeq (toSequence s) h m
211 runSequence (LayoutSeq s h ps) = Layout sch h $ \inh -> do
212 modify' $ \k -> \case
214 Just ts -> k $ Just [Tree.Node nod mempty]
215 -- where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})
217 nod = LayoutNode_Forest mempty {-(docSchema sch)-}
218 (layoutInh_message inh) (gs <> ts)
219 gs = (<$> ps inh{layoutInh_message=[]}) $ \(d,ds) ->
220 Tree.Node (LayoutNode_Single d ds) mempty
222 where sch = runSequence s
223 toSequence (Layout s h _m) = LayoutSeq (toSequence s) h $ \inh ->
224 [(docSchema s, layoutInh_message inh <> h)]
226 instance Pro (Layout d) where
227 dimap a2b b2a (Layout s h l) = Layout (dimap a2b b2a s) h l
228 instance (LayoutDoc d, Doc.From Name d) => CLI_Command (Layout d) where
229 command n (Layout xl xh xm) = Layout sch xh $ \inh -> do
230 modify' $ \k -> \case
235 (Doc.magentaer $ docSchema $ command n nothing)
236 (layoutInh_message inh)
239 xm inh{layoutInh_message=[]}
240 where sch = command n xl
241 instance (LayoutDoc d, Doc.Justifiable d) => CLI_Tag (Layout d) where
242 type TagConstraint (Layout d) a = TagConstraint (Schema d) a
243 tag n (Layout xs xh xm) = Layout (tag n xs) xh $ \inh -> do
244 modify' $ \k -> \case
248 ( LayoutNode_List [] [
249 ( docSchema (tag n nothing)
250 , layoutInh_message inh
255 xm inh{layoutInh_message=[]}
256 endOpts = Layout sch [] $ \_inh -> do
257 modify' $ \k -> \case
259 Just ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []) ts]
261 instance LayoutDoc d => CLI_Var (Layout d) where
262 type VarConstraint (Layout d) a = VarConstraint (Schema d) a
263 var' n = Layout sch [] $ \inh -> do
264 modify' $ \k -> \case
266 Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
267 where h = [(docSchema sch, layoutInh_message inh)]
269 instance LayoutDoc d => CLI_Constant (Layout d) where
270 constant c a = Layout sch [] $ \inh -> do
271 modify' $ \k -> \case
273 Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
274 where h = [(docSchema sch, layoutInh_message inh)]
275 where sch = constant c a
276 just a = Layout (just a) [] $ \_inh -> pure ()
277 nothing = Layout nothing [] $ \_inh -> pure ()
278 instance LayoutDoc d => CLI_Env (Layout d) where
279 type EnvConstraint (Layout d) a = EnvConstraint (Schema d) a
280 env' n = Layout (env' n) [] $ \_inh -> pure ()
281 instance LayoutDoc d => CLI_Help (Layout d) where
282 type HelpConstraint (Layout d) d' = HelpConstraint (Schema d) d'
283 help msg (Layout s _h m) = Layout
285 (\inh -> m inh{layoutInh_message=[msg]})
286 program n (Layout xl xh xm) = Layout sch xh $ \inh -> do
287 modify' $ \k -> \case
291 (LayoutNode_Single (Doc.magentaer $ docSchema $ program n nothing) [])
295 where sch = program n xl
297 instance LayoutDoc d => CLI_Response (Layout d) where
298 type ResponseConstraint (Layout d) a = ResponseConstraint (Schema d) a
299 type ResponseArgs (Layout d) a = ResponseArgs (Schema d) a
300 type Response (Layout d) = Response (Schema d)
301 response' = Layout response' [] $ \_inh -> do
302 modify' $ \k -> \case
303 Nothing -> k $ Just []
304 Just ts -> k $ Just ts
306 -- ** Type 'LayoutSeq'
307 data LayoutSeq d k a = LayoutSeq
308 { layoutSeq_schema :: SchemaSeq d k a
309 , layoutSeq_help :: [d]
310 , layoutSeq_monad :: LayoutInh d -> State (LayoutState d) ()
312 instance Functor (LayoutSeq d k) where
313 f`fmap`LayoutSeq s h m = LayoutSeq (f<$>s) h $ \inh -> m inh
314 instance Applicative (LayoutSeq d k) where
315 pure a = LayoutSeq (pure a) [] $ \_inh -> return ()
316 LayoutSeq fs fh f <*> LayoutSeq xs xh x =
317 LayoutSeq (fs<*>xs) (fh<>xh) $ \inh -> f inh >> x inh
318 instance LayoutDoc d => CLI_Help (LayoutSeq d) where
319 type HelpConstraint (LayoutSeq d) d' = HelpConstraint (SchemaSeq d) d'
320 help msg (LayoutSeq s _h m) = LayoutSeq (help msg s) [msg] $ \inh ->
321 m inh{layoutInh_message=[msg]}
322 program n (LayoutSeq s h m) = LayoutSeq (program n s) h m
323 rule n (LayoutSeq s h m) = LayoutSeq (rule n s) h m
325 -- ** Type 'LayoutPerm'
326 data LayoutPerm d k a = LayoutPerm
327 { layoutPerm_help :: [d]
328 , layoutPerm_elem :: LayoutInh d -> [(d, {-help-}[d])]
330 instance Functor (LayoutPerm d k) where
331 _f`fmap`LayoutPerm h ps = LayoutPerm h $ \inh -> ps inh
332 instance Applicative (LayoutPerm d k) where
333 pure _a = LayoutPerm [] $ \_inh -> []
334 LayoutPerm _fh f <*> LayoutPerm _xh x =
335 LayoutPerm [] $ \inh -> f inh <> x inh
336 instance LayoutDoc d => CLI_Help (LayoutPerm d) where
337 type HelpConstraint (LayoutPerm d) d' = HelpConstraint (SchemaPerm d) d'
338 help msg (LayoutPerm _h m) = LayoutPerm [msg] $ \inh ->
339 m inh{layoutInh_message=[msg]}
343 -- ** Type 'LayoutNode'
345 = LayoutNode_Single d {-help-}[d]
346 | LayoutNode_List [d] [(d, {-help-}[d])]
347 | LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))