]> Git — Sourcephile - haskell/symantic-cli.git/blob - Symantic/CLI/Help.hs
f1868555cc23644d8566917f2c0d05339e7cfeca
[haskell/symantic-cli.git] / Symantic / CLI / Help.hs
1 {-# LANGUAGE InstanceSigs #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
4 module Symantic.CLI.Help where
5
6 import Control.Applicative (Applicative(..))
7 import Data.Bool
8 import Data.Foldable (null)
9 import Data.Function (($), (.))
10 import Data.Functor (Functor(..), (<$>))
11 import Data.Maybe (Maybe(..), maybe, isJust)
12 import Data.Monoid (Monoid(..))
13 import Data.Semigroup (Semigroup(..))
14 import Text.Show (Show(..))
15 import Data.Tree as Tree
16 import qualified Symantic.Document as Doc
17
18 import Symantic.CLI.API
19 import Symantic.CLI.Schema as Schema
20
21 -- * Type 'Help'
22 data Help d f k
23 = Help
24 { help_result :: HelpInh d -> HelpResult d
25 -- ^ The 'HelpResult' of the current symantic.
26 , help_schema :: Schema d f k
27 -- ^ The 'Schema' of the current symantic.
28 }
29
30 runHelp :: SchemaDoc d => HelpInh d -> Help d f k -> d
31 runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline
32
33 docHelp :: SchemaDoc d => Doc.Indentable d => SchemaDoc d => Help d f k -> d
34 docHelp = runHelp defHelpInh
35
36 coerceHelp :: Help d f k -> Help d f' k'
37 coerceHelp Help{help_schema, ..} = Help
38 { help_schema = Schema.coerceSchema help_schema
39 , ..
40 }
41
42 -- ** Type 'HelpInh'
43 -- | Configuration inherited top-down.
44 data HelpInh d
45 = HelpInh
46 { helpInh_message :: !(Maybe d)
47 -- ^ The message inherited from 'help's.
48 , helpInh_command_indent :: !Doc.Indent
49 -- ^ 'Doc.Indent'ation for 'command's.
50 , helpInh_tag_indent :: !Doc.Indent
51 -- ^ 'Doc.Indent'ation for 'Tag's.
52 , helpInh_schema :: !(SchemaInh d)
53 -- ^ The inherited 'SchemaInh' for 'runSchema'.
54 , helpInh_helpless_options :: !Bool
55 -- ^ Whether to include options without help in the listing.
56 , helpInh_command_rule :: !Bool
57 -- ^ Whether to print the name of the rule.
58 , helpInh_full :: !Bool
59 -- ^ Whether to print full help.
60 }
61
62 defHelpInh :: SchemaDoc d => HelpInh d
63 defHelpInh = HelpInh
64 { helpInh_message = Nothing
65 , helpInh_command_indent = 2
66 , helpInh_tag_indent = 16
67 , helpInh_schema = defSchemaInh
68 , helpInh_helpless_options = False
69 , helpInh_command_rule = False
70 , helpInh_full = True
71 }
72
73 -- ** Type 'HelpResult'
74 type HelpResult d = Tree.Forest (HelpNode, d)
75
76 defHelpResult :: Monoid d => HelpResult d
77 defHelpResult = mempty
78
79 -- *** Type 'HelpNode'
80 data HelpNode
81 = HelpNode_Message
82 | HelpNode_Rule
83 | HelpNode_Command
84 | HelpNode_Tag
85 | HelpNode_Env
86 deriving Show
87
88 runHelpNode :: SchemaDoc d => Tree (HelpNode, d) -> d
89 runHelpNode (Tree.Node (_n,d) _ts) = d
90
91 -- | Introduce 'Doc.newline' according to the 'HelpNode's
92 -- put next to each others.
93 runHelpNodes :: SchemaDoc d => HelpInh d -> Tree.Forest (HelpNode, d) -> d
94 runHelpNodes _inh [] = mempty
95 runHelpNodes inh ( t0@(Tree.Node _ t0s)
96 : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) =
97 runHelpNode t0 <>
98 Doc.newline <>
99 (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
100 runHelpNodes inh (t1:ts)
101 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Tag, _) _)
102 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
103 runHelpNode t0 <>
104 Doc.newline <>
105 runHelpNodes inh (t1:ts)
106 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)
107 : t1@(Tree.Node (_, _) _) : ts ) =
108 runHelpNode t0 <>
109 Doc.newline <>
110 (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
111 runHelpNodes inh (t1:ts)
112 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Message, _) _)
113 : t1 : ts ) =
114 runHelpNode t0 <>
115 Doc.newline <>
116 Doc.newline <>
117 runHelpNodes inh (t1:ts)
118 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
119 runHelpNode t0 <>
120 Doc.newline <>
121 Doc.newline <>
122 runHelpNodes inh (t1:ts)
123 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
124 runHelpNode t0 <>
125 Doc.newline <>
126 Doc.newline <>
127 runHelpNodes inh (t1:ts)
128 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Rule, _) _) : ts ) =
129 runHelpNode t0 <>
130 Doc.newline <>
131 runHelpNodes inh (t1:ts)
132 runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts
133
134 instance Semigroup d => Semigroup (Help d f k) where
135 Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
136 instance Monoid d => Monoid (Help d f k) where
137 mempty = Help mempty mempty
138 mappend = (<>)
139 {-
140 instance (Semigroup d, IsString d) => IsString (Help d e s a) where
141 fromString "" = Help $ \_ro -> Nothing
142 fromString s = Help $ \_ro -> Just $ fromString s
143 instance Show (Help Doc.Term e s a) where
144 show = TL.unpack . Doc.textTerm . runHelp
145 instance SchemaDoc d => Functor (Help d f) where
146 f <$$> Help h s = Help h (f<$$>s)
147 -}
148 instance SchemaDoc d => App (Help d) where
149 Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
150 instance SchemaDoc d => Alt (Help d) where
151 Help hl pl <!> Help hr pr = Help (hl<>hr) (pl<!>pr)
152 Help hl pl `alt` Help hr pr = Help (hl<>hr) (pl`alt`pr)
153 opt (Help h s) = Help h (opt s)
154 {-
155 try (Help h s) = Help h (try s)
156 choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs))
157 option a (Help h s) = Help h (option a s)
158 -}
159 instance SchemaDoc d => Permutable (Help d) where
160 type Permutation (Help d) = HelpPerm d
161 runPermutation (HelpPerm h s) = Help h $ runPermutation s
162 toPermutation (Help h s) = HelpPerm h $ toPermutation s
163 toPermDefault a (Help h s) = HelpPerm h $ toPermDefault a s
164 instance Pro (Help d) where
165 dimap a2b b2a (Help h s) = Help h $ dimap a2b b2a s
166 instance SchemaDoc d => AltApp (Help d) where
167 many0 (Help h s) = Help h (many0 s)
168 many1 (Help h s) = Help h (many1 s)
169 instance SchemaDoc d => CLI_Var (Help d) where
170 type VarConstraint (Help d) a = ()
171 var' n = Help mempty (var' n)
172 instance SchemaDoc d => CLI_Constant (Help d) where
173 constant n a = Help mempty (constant n a)
174 just a = Help mempty (just a)
175 nothing = Help mempty nothing
176 instance SchemaDoc d => CLI_Env (Help d) where
177 type EnvConstraint (Help d) a = ()
178 env' n =
179 Help (\inh ->
180 let ts =
181 if helpInh_full inh
182 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
183 else [] in
184 let d =
185 Doc.fillOrBreak (helpInh_tag_indent inh)
186 (Doc.bold (Doc.green (Doc.from (Doc.Word n)))
187 <> Doc.space)
188 <> (if null ts then mempty else Doc.space)
189 <> Doc.align (runHelpNodes inh ts)
190 in
191 [ Tree.Node (HelpNode_Env, d) ts ]
192 ) schema
193 where schema = env' n
194 instance SchemaDoc d => CLI_Command (Help d) where
195 -- type CommandConstraint (Help d) a = ()
196 command n (Help h s) =
197 Help (\inh ->
198 let ts =
199 (if helpInh_full inh
200 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
201 else []) <>
202 h inh
203 { helpInh_message = Nothing
204 , helpInh_command_rule = True
205 } in
206 let d =
207 let ind = helpInh_command_indent inh in
208 (if not (null n) && helpInh_command_rule inh
209 then ref<>Doc.space<>"::= " else mempty)
210 <> Schema.runSchema schema (helpInh_schema inh)
211 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
212 <> Doc.incrIndent (Doc.spaces ind) ind
213 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
214 in
215 [ Tree.Node (HelpNode_Command, d) ts ]
216 ) schema
217 where
218 schema = command n s
219 ref =
220 Doc.bold $
221 Doc.angles $
222 Doc.magentaer $
223 Doc.from (Doc.Word n)
224 instance SchemaDoc d => CLI_Tag (Help d) where
225 type TagConstraint (Help d) a = ()
226 tag n (Help h s) =
227 Help (\inh ->
228 if (isJust (helpInh_message inh)
229 || helpInh_helpless_options inh)
230 && helpInh_full inh
231 then
232 let ts =
233 maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
234 h inh{helpInh_message=Nothing} in
235 let d =
236 Doc.fillOrBreak (helpInh_tag_indent inh)
237 (Doc.bold $
238 Schema.runSchema schema (helpInh_schema inh)
239 <> Doc.space) -- FIXME: space is not always needed
240 <> (if null ts then mempty else Doc.space)
241 <> Doc.align (runHelpNodes inh ts)
242 in
243 [ Tree.Node (HelpNode_Tag, d) ts ]
244 else []
245 ) schema
246 where schema = tag n s
247 endOpts = Help mempty endOpts
248 instance SchemaDoc d => CLI_Help (Help d) where
249 type HelpConstraint (Help d) d' = d ~ d'
250 help msg (Help h s) = Help
251 (\inh -> h inh{helpInh_message=Just msg})
252 (help msg s)
253 program n (Help h s) =
254 Help (\inh ->
255 let ts =
256 (if helpInh_full inh
257 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
258 else []) <>
259 h inh
260 { helpInh_message = Nothing
261 , helpInh_command_rule = True
262 } in
263 let d =
264 let ind = helpInh_command_indent inh in
265 Schema.runSchema schema (helpInh_schema inh)
266 <> (if null ts {- \|| not (helpInh_full inh)-} then mempty else Doc.newline)
267 <> Doc.incrIndent (Doc.spaces ind) ind
268 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
269 in
270 [ Tree.Node (HelpNode_Rule, d) ts ]
271 ) schema
272 where
273 schema = program n s
274 rule n (Help h s) =
275 Help (\inh ->
276 let ts =
277 (if helpInh_full inh
278 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
279 else []) <>
280 h inh
281 { helpInh_message = Nothing
282 , helpInh_command_rule = True
283 } in
284 let d =
285 let ind = helpInh_command_indent inh in
286 ref<>Doc.space<>"::= "
287 <> Schema.runSchema schema (helpInh_schema inh)
288 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
289 <> Doc.incrIndent (Doc.spaces ind) ind
290 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
291 in
292 [ Tree.Node (HelpNode_Rule, d) ts ]
293 ) schema
294 where
295 schema = rule n s
296 ref =
297 Doc.bold $
298 Doc.angles $
299 Doc.magentaer $
300 Doc.from (Doc.Word n)
301 type HelpResponseArgs = SchemaResponseArgs
302 instance SchemaDoc d => CLI_Response (Help d) where
303 type ResponseConstraint (Help d) a = () -- ResponseConstraint (Schema d)
304 type ResponseArgs (Help d) a = SchemaResponseArgs a -- ResponseArgs (Schema d) a
305 type Response (Help d) = () -- Response (Schema d)
306 response' ::
307 forall a repr.
308 repr ~ Help d =>
309 ResponseConstraint repr a =>
310 repr (ResponseArgs repr a)
311 (Response repr)
312 response' = Help mempty $ response' @(Schema d) @a
313
314 {-
315 instance SchemaDoc d => Sym_AltApp (Help d) where
316 many (Help h s) = Help h (many s)
317 some (Help h s) = Help h (many s)
318 -}
319
320 -- * Type 'HelpPerm'
321 data HelpPerm d k a
322 = HelpPerm (HelpInh d -> HelpResult d)
323 (SchemaPerm d k a)
324 instance Functor (HelpPerm d k) where
325 f`fmap`HelpPerm h ps = HelpPerm h (f<$>ps)
326 instance Applicative (HelpPerm d k) where
327 pure a = HelpPerm mempty (pure a)
328 HelpPerm fh f <*> HelpPerm xh x =
329 HelpPerm (fh<>xh) (f<*>x)
330 instance SchemaDoc d => CLI_Help (HelpPerm d) where
331 type HelpConstraint (HelpPerm d) d' = d ~ d'
332 help msg (HelpPerm h s) = HelpPerm
333 (\inh -> h inh{helpInh_message=Just msg})
334 (help msg s)
335 program n (HelpPerm h s) = HelpPerm
336 (help_result $ program n (Help h (runPermutation s)))
337 (rule n s)
338 rule n (HelpPerm h s) = HelpPerm
339 (help_result $ rule n (Help h (runPermutation s)))
340 (rule n s)