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 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 | List.null (layoutInh_message inh) = []
275 | otherwise = [(docSchema sch, layoutInh_message inh)]
276 where sch = constant c a
277 just a = Layout (just a) [] $ \_inh -> pure ()
278 nothing = Layout nothing [] $ \_inh -> pure ()
279 instance LayoutDoc d => CLI_Env (Layout d) where
280 type EnvConstraint (Layout d) a = EnvConstraint (Schema d) a
281 env' n = Layout (env' n) [] $ \_inh -> pure ()
282 instance LayoutDoc d => CLI_Help (Layout d) where
283 type HelpConstraint (Layout d) d' = HelpConstraint (Schema d) d'
284 help msg (Layout s _h m) = Layout
286 (\inh -> m inh{layoutInh_message=[msg]})
287 program n (Layout xl xh xm) = Layout sch xh $ \inh -> do
288 modify' $ \k -> \case
292 (LayoutNode_Single (Doc.magentaer $ docSchema $ program n nothing) [])
296 where sch = program n xl
298 instance LayoutDoc d => CLI_Response (Layout d) where
299 type ResponseConstraint (Layout d) a = ResponseConstraint (Schema d) a
300 type ResponseArgs (Layout d) a = ResponseArgs (Schema d) a
301 type Response (Layout d) = Response (Schema d)
302 response' = Layout response' [] $ \_inh -> do
303 modify' $ \k -> \case
304 Nothing -> k $ Just []
305 Just ts -> k $ Just ts
307 -- ** Type 'LayoutSeq'
308 data LayoutSeq d k a = LayoutSeq
309 { layoutSeq_schema :: SchemaSeq d k a
310 , layoutSeq_help :: [d]
311 , layoutSeq_monad :: LayoutInh d -> State (LayoutState d) ()
313 instance Functor (LayoutSeq d k) where
314 f`fmap`LayoutSeq s h m = LayoutSeq (f<$>s) h $ \inh -> m inh
315 instance Applicative (LayoutSeq d k) where
316 pure a = LayoutSeq (pure a) [] $ \_inh -> return ()
317 LayoutSeq fs fh f <*> LayoutSeq xs xh x =
318 LayoutSeq (fs<*>xs) (fh<>xh) $ \inh -> f inh >> x inh
319 instance LayoutDoc d => CLI_Help (LayoutSeq d) where
320 type HelpConstraint (LayoutSeq d) d' = HelpConstraint (SchemaSeq d) d'
321 help msg (LayoutSeq s _h m) = LayoutSeq (help msg s) [msg] $ \inh ->
322 m inh{layoutInh_message=[msg]}
323 program n (LayoutSeq s h m) = LayoutSeq (program n s) h m
324 rule n (LayoutSeq s h m) = LayoutSeq (rule n s) h m
326 -- ** Type 'LayoutPerm'
327 data LayoutPerm d k a = LayoutPerm
328 { layoutPerm_help :: [d]
329 , layoutPerm_elem :: LayoutInh d -> [(d, {-help-}[d])]
331 instance Functor (LayoutPerm d k) where
332 _f`fmap`LayoutPerm h ps = LayoutPerm h $ \inh -> ps inh
333 instance Applicative (LayoutPerm d k) where
334 pure _a = LayoutPerm [] $ \_inh -> []
335 LayoutPerm _fh f <*> LayoutPerm _xh x =
336 LayoutPerm [] $ \inh -> f inh <> x inh
337 instance LayoutDoc d => CLI_Help (LayoutPerm d) where
338 type HelpConstraint (LayoutPerm d) d' = HelpConstraint (SchemaPerm d) d'
339 help msg (LayoutPerm _h m) = LayoutPerm [msg] $ \inh ->
340 m inh{layoutInh_message=[msg]}
344 -- ** Type 'LayoutNode'
346 = LayoutNode_Single d {-help-}[d]
347 | LayoutNode_List [d] [(d, {-help-}[d])]
348 | LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))