]> Git — Sourcephile - haskell/symantic-cli.git/blob - Symantic/CLI/Layout.hs
api: improve CLI_Tag
[haskell/symantic-cli.git] / 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(..))
9 import Control.Monad (Monad(..), (>>))
10 import Control.Monad.Trans.State.Strict
11 import Data.Bool
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
22
23 import Symantic.CLI.API
24 import Symantic.CLI.Schema
25
26 -- * Type 'Layout'
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'.
32 , layoutHelp :: [d]
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) ()
37 }
38
39 runLayout :: LayoutDoc d => Bool -> Layout d f k -> d
40 runLayout full (Layout _s _h l) =
41 runLayoutForest full $
42 fromMaybe [] $
43 ($ (Just [])) $
44 (`execState`id) $
45 l defLayoutInh
46
47 coerceLayout :: Layout d f k -> Layout d f' k'
48 coerceLayout (Layout s h l) = Layout (coerceSchema s) h l
49
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 ->
53 xm inh >> ym inh
54
55 -- ** Type 'LayoutInh'
56 newtype LayoutInh d = LayoutInh
57 { layoutInh_message :: {-!-}[d]
58 }
59
60 defLayoutInh :: LayoutInh d
61 defLayoutInh = LayoutInh
62 { layoutInh_message = []
63 }
64
65 -- ** Type 'LayoutState'
66 type LayoutState d = Diff (Tree.Forest (LayoutNode d))
67
68 -- ** Type 'Diff'
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
76
77 -- ** Type 'LayoutDoc'
78 type LayoutDoc d =
79 ( SchemaDoc d
80 , Doc.Justifiable d
81 )
82
83 runLayoutForest :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d
84 runLayoutForest full = (<> Doc.newline) . Doc.catV . (runLayoutTree full <$>)
85
86 runLayoutForest' :: LayoutDoc d => Bool -> Forest (LayoutNode d) -> d
87 runLayoutForest' full = Doc.catV . (runLayoutTree full <$>)
88
89 runLayoutTree :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> d
90 runLayoutTree full =
91 -- Doc.setIndent mempty 0 .
92 Doc.catV . runLayoutNode full
93
94 runLayoutNode :: LayoutDoc d => Bool -> Tree (LayoutNode d) -> [d]
95 runLayoutNode full (Tree.Node n ts0) =
96 (case n of
97 LayoutNode_Single sch mh ->
98 [ Doc.align $
99 case mh of
100 [] -> Doc.whiter sch
101 _ | not full -> Doc.whiter sch
102 h -> Doc.whiter sch <> Doc.newline <> Doc.justify (Doc.catV h)
103 ]
104 LayoutNode_List ns ds ->
105 ((if full then ns else []) <>) $
106 (<$> ds) $ \(sch, mh) ->
107 case mh of
108 [] ->
109 Doc.whiter sch
110 _ | not full -> Doc.whiter sch
111 h ->
112 Doc.fillOrBreak 15 (Doc.whiter sch) <>
113 Doc.space <> Doc.align (Doc.justify (Doc.catV h))
114 LayoutNode_Forest sch ds ts ->
115 [Doc.whiter sch] <>
116 (if List.null ds || not full then [] else [Doc.catV ds]) <>
117 (if List.null ts then [] else [runLayoutForest' full ts])
118 ) <> docSubTrees ts0
119 where
120 docSubTrees [] = []
121 docSubTrees [t] =
122 -- "|" :
123 shift (Doc.blacker "└──"<>Doc.space)
124 (Doc.spaces 4)
125 (Doc.incrIndent (Doc.spaces 4) 4 <$> runLayoutNode full t)
126 docSubTrees (t:ts) =
127 -- "|" :
128 shift (Doc.blacker "├──"<>Doc.space)
129 (Doc.blacker "│"<>Doc.spaces 3)
130 (Doc.incrIndent (Doc.blacker "│"<>Doc.spaces 3) 4 <$> runLayoutNode full t)
131 <> docSubTrees ts
132
133 shift d ds =
134 List.zipWith (<>)
135 (d : List.repeat ds)
136
137 instance LayoutDoc d => App (Layout d) where
138 Layout xs xh xm <.> Layout ys yh ym =
139 Layout (xs<.>ys) (xh<>yh) $ \inh ->
140 xm inh >> ym inh
141 instance LayoutDoc d => Alt (Layout d) where
142 Layout ls lh lm <!> Layout rs rh rm = Layout sch [] $ \inh -> do
143 k <- get
144
145 put id
146 lm inh
147 lk <- get
148
149 put id
150 rm inh
151 rk <- get
152
153 put $
154 case (lk Nothing, rk Nothing) of
155 (Nothing, Nothing) -> \case
156 Nothing -> k Nothing
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)
167 where sch = ls<!>rs
168 Layout ls lh lm `alt` Layout rs rh rm =
169 (Layout ls lh lm <!> Layout rs rh rm)
170 {layoutSchema=sch}
171 where sch = ls`alt`rs
172 opt (Layout xs xh xm) = Layout sch xh $ \inh -> do
173 modify' $ \k -> \case
174 Nothing -> k Nothing
175 Just _ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []{-FIXME-}) mempty]
176 xm inh
177 where sch = opt xs
178 instance LayoutDoc d => AltApp (Layout d) where
179 many0 (Layout xs xh xm) = Layout sch xh $ \inh -> do
180 modify' $ \k -> \case
181 Nothing -> k Nothing
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=[]}
185 where sch = many0 xs
186 many1 (Layout xs xh xm) = Layout sch xh $ \inh -> do
187 modify' $ \k -> \case
188 Nothing -> k Nothing
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=[]}
192 where sch = many1 xs
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
197 Nothing -> k Nothing
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
209 {-
210 runSequence (LayoutSeq s h ps) = Layout sch h $ \inh -> do
211 modify' $ \k -> \case
212 Nothing -> k Nothing
213 Just ts -> k $ Just [Tree.Node nod mempty]
214 -- where nod = LayoutNode_List (layoutInh_message inh) (ps inh{layoutInh_message=[]})
215 where
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
220
221 where sch = runSequence s
222 toSequence (Layout s h _m) = LayoutSeq (toSequence s) h $ \inh ->
223 [(docSchema s, layoutInh_message inh <> h)]
224 -}
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
230 Nothing -> k Nothing
231 Just ts -> k $ Just
232 [ Tree.Node
233 ( LayoutNode_Single
234 (Doc.magentaer $ docSchema $ command n nothing)
235 (layoutInh_message inh)
236 ) ts
237 ]
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
244 Nothing -> k Nothing
245 Just ts -> k $ Just
246 [ Tree.Node
247 ( LayoutNode_List [] [
248 ( docSchema (tag n nothing)
249 , layoutInh_message inh
250 )
251 ]
252 ) ts
253 ]
254 xm inh{layoutInh_message=[]}
255 endOpts = Layout sch [] $ \_inh -> do
256 modify' $ \k -> \case
257 Nothing -> k Nothing
258 Just ts -> k $ Just [Tree.Node (LayoutNode_Single (docSchema sch) []) ts]
259 where sch = endOpts
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
264 Nothing -> k Nothing
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)]
268 where sch = var' n
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
277 (help msg s) [msg]
278 (\inh -> m inh{layoutInh_message=[msg]})
279 program n (Layout xl xh xm) = Layout sch xh $ \inh -> do
280 modify' $ \k -> \case
281 Nothing -> k Nothing
282 Just ts -> k $ Just
283 [ Tree.Node
284 (LayoutNode_Single (Doc.magentaer $ docSchema $ program n nothing) [])
285 ts
286 ]
287 xm inh
288 where sch = program n xl
289 rule _n = id
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
298
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) ()
304 }
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
317
318 -- ** Type 'LayoutPerm'
319 data LayoutPerm d k a = LayoutPerm
320 { layoutPerm_help :: [d]
321 , layoutPerm_elem :: LayoutInh d -> [(d, {-help-}[d])]
322 }
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]}
333 program _n = id
334 rule _n = id
335
336 -- ** Type 'LayoutNode'
337 data LayoutNode d
338 = LayoutNode_Single d {-help-}[d]
339 | LayoutNode_List [d] [(d, {-help-}[d])]
340 | LayoutNode_Forest d [d] (Tree.Forest (LayoutNode d))
341 deriving (Show)