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(..), 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 [(Doc.brackets (docSchema xl), layoutInh_message inh <> xh)]
205 instance (LayoutDoc d, Doc.Justifiable d) => Sequenceable (Layout d) where
206 type Sequence (Layout d) = LayoutSeq d
207 runSequence (LayoutSeq s h m) = Layout (runSequence s) h m
208 toSequence (Layout s h m) = LayoutSeq (toSequence s) h m
210 runSequence (LayoutSeq s h ps) = Layout sch h $ \inh -> do
211 modify' $ \k -> \case
213 Just ts -> k $ Just [Tree.Node nod mempty]
214 -- where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})
216 nod = LayoutNode_Forest mempty {-(docSchema sch)-}
217 (layoutInh_message inh) (gs <> ts)
218 gs = (<$> ps inh{layoutInh_message=[]}) $ \(d,ds) ->
219 Tree.Node (LayoutNode_Single d ds) mempty
221 where sch = runSequence s
222 toSequence (Layout s h _m) = LayoutSeq (toSequence s) h $ \inh ->
223 [(docSchema s, layoutInh_message inh <> h)]
225 instance Pro (Layout d) where
226 dimap a2b b2a (Layout s h l) = Layout (dimap a2b b2a s) h l
227 instance (LayoutDoc d, Doc.From Name d) => CLI_Command (Layout d) where
228 command n (Layout xl xh xm) = Layout sch xh $ \inh -> do
229 modify' $ \k -> \case
234 (Doc.magentaer $ docSchema $ command n nothing)
235 (layoutInh_message inh)
238 xm inh{layoutInh_message=[]}
239 where sch = command n xl
240 instance (LayoutDoc d, Doc.Justifiable d) => CLI_Tag (Layout d) where
241 type TagConstraint (Layout d) a = TagConstraint (Schema d) a
242 tag n (Layout xs xh xm) = Layout (tag n xs) xh $ \inh -> do
243 modify' $ \k -> \case
247 ( LayoutNode_List [] [
248 ( docSchema (tag n nothing)
249 , layoutInh_message inh
254 xm inh{layoutInh_message=[]}
255 endOpts = Layout sch [] $ \_inh -> do
256 modify' $ \k -> \case
258 Just ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []) ts]
260 instance LayoutDoc d => CLI_Var (Layout d) where
261 type VarConstraint (Layout d) a = VarConstraint (Schema d) a
262 var' n = Layout sch [] $ \inh -> do
263 modify' $ \k -> \case
265 Just ts -> k $ Just [Tree.Node (LayoutNode_List [] h) ts]
266 where h | List.null (layoutInh_message inh) = []
267 | otherwise = [(docSchema sch, layoutInh_message inh)]
269 just a = Layout (just a) [] $ \_inh -> pure ()
270 nothing = Layout nothing [] $ \_inh -> pure ()
271 instance LayoutDoc d => CLI_Env (Layout d) where
272 type EnvConstraint (Layout d) a = EnvConstraint (Schema d) a
273 env' n = Layout (env' n) [] $ \_inh -> pure ()
274 instance LayoutDoc d => CLI_Help (Layout d) where
275 type HelpConstraint (Layout d) d' = HelpConstraint (Schema d) d'
276 help msg (Layout s _h m) = Layout
278 (\inh -> m inh{layoutInh_message=[msg]})
279 program n (Layout xl xh xm) = Layout sch xh $ \inh -> do
280 modify' $ \k -> \case
284 (LayoutNode_Single (Doc.magentaer $ docSchema $ program n nothing) [])
288 where sch = program n xl
290 instance LayoutDoc d => CLI_Response (Layout d) where
291 type ResponseConstraint (Layout d) a = ResponseConstraint (Schema d) a
292 type ResponseArgs (Layout d) a = ResponseArgs (Schema d) a
293 type Response (Layout d) = Response (Schema d)
294 response' = Layout response' [] $ \_inh -> do
295 modify' $ \k -> \case
296 Nothing -> k $ Just []
297 Just ts -> k $ Just ts
299 -- ** Type 'LayoutSeq'
300 data LayoutSeq d k a = LayoutSeq
301 { layoutSeq_schema :: SchemaSeq d k a
302 , layoutSeq_help :: [d]
303 , layoutSeq_monad :: LayoutInh d -> State (LayoutState d) ()
305 instance Functor (LayoutSeq d k) where
306 f`fmap`LayoutSeq s h m = LayoutSeq (f<$>s) h $ \inh -> m inh
307 instance Applicative (LayoutSeq d k) where
308 pure a = LayoutSeq (pure a) [] $ \_inh -> return ()
309 LayoutSeq fs fh f <*> LayoutSeq xs xh x =
310 LayoutSeq (fs<*>xs) (fh<>xh) $ \inh -> f inh >> x inh
311 instance LayoutDoc d => CLI_Help (LayoutSeq d) where
312 type HelpConstraint (LayoutSeq d) d' = HelpConstraint (SchemaSeq d) d'
313 help msg (LayoutSeq s _h m) = LayoutSeq (help msg s) [msg] $ \inh ->
314 m inh{layoutInh_message=[msg]}
315 program n (LayoutSeq s h m) = LayoutSeq (program n s) h m
316 rule n (LayoutSeq s h m) = LayoutSeq (rule n s) h m
318 -- ** Type 'LayoutPerm'
319 data LayoutPerm d k a = LayoutPerm
320 { layoutPerm_help :: [d]
321 , layoutPerm_elem :: LayoutInh d -> [(d, {-help-}[d])]
323 instance Functor (LayoutPerm d k) where
324 _f`fmap`LayoutPerm h ps = LayoutPerm h $ \inh -> ps inh
325 instance Applicative (LayoutPerm d k) where
326 pure _a = LayoutPerm [] $ \_inh -> []
327 LayoutPerm _fh f <*> LayoutPerm _xh x =
328 LayoutPerm [] $ \inh -> f inh <> x inh
329 instance LayoutDoc d => CLI_Help (LayoutPerm d) where
330 type HelpConstraint (LayoutPerm d) d' = HelpConstraint (SchemaPerm d) d'
331 help msg (LayoutPerm _h m) = LayoutPerm [msg] $ \inh ->
332 m inh{layoutInh_message=[msg]}
336 -- ** Type 'LayoutNode'
338 = LayoutNode_Single d {-help-}[d]
339 | LayoutNode_List [d] [(d, {-help-}[d])]
340 | LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))