1 {-# LANGUAGE InstanceSigs #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE UndecidableInstances #-} -- for From (Word *) d
4 module Symantic.CLI.Help where
6 import Control.Applicative (Applicative(..))
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
18 import Symantic.CLI.API
19 import Symantic.CLI.Schema as Schema
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.
30 runHelp :: SchemaDoc d => HelpInh d -> Help d f k -> d
31 runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline
33 docHelp :: SchemaDoc d => Doc.Indentable d => SchemaDoc d => Help d f k -> d
34 docHelp = runHelp defHelpInh
36 coerceHelp :: Help d f k -> Help d f' k'
37 coerceHelp Help{help_schema, ..} = Help
38 { help_schema = Schema.coerceSchema help_schema
43 -- | Configuration inherited top-down.
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.
62 defHelpInh :: SchemaDoc d => HelpInh d
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
73 -- ** Type 'HelpResult'
74 type HelpResult d = Tree.Forest (HelpNode, d)
76 defHelpResult :: Monoid d => HelpResult d
77 defHelpResult = mempty
79 -- *** Type 'HelpNode'
88 runHelpNode :: SchemaDoc d => Tree (HelpNode, d) -> d
89 runHelpNode (Tree.Node (_n,d) _ts) = d
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 ) =
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 ) =
105 runHelpNodes inh (t1:ts)
106 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)
107 : t1@(Tree.Node (_, _) _) : ts ) =
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, _) _)
117 runHelpNodes inh (t1:ts)
118 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
122 runHelpNodes inh (t1:ts)
123 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
127 runHelpNodes inh (t1:ts)
128 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Rule, _) _) : ts ) =
131 runHelpNodes inh (t1:ts)
132 runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts
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
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)
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)
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)
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 = ()
183 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
186 Doc.fillOrBreak (helpInh_tag_indent inh)
187 (Doc.bold (Doc.green (Doc.from (Doc.Word n)))
189 <> (if null ts then mempty else Doc.space)
190 <> Doc.align (runHelpNodes inh ts)
191 in [ Tree.Node (HelpNode_Env, d) ts ]
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) =
201 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
204 { helpInh_message = Nothing
205 , helpInh_command_rule = True
208 let ind = helpInh_command_indent inh in
209 (if not (null n) && helpInh_command_rule inh
210 then ref<>Doc.space<>"::= " else mempty)
211 <> Schema.runSchema schema (helpInh_schema inh)
212 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
213 <> Doc.incrIndent (Doc.spaces ind) ind
214 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
215 in [ Tree.Node (HelpNode_Command, d) ts ]
223 Doc.from (Doc.Word n)
224 instance SchemaDoc d => CLI_Tag (Help d) where
225 type TagConstraint (Help d) a = ()
228 if (isJust (helpInh_message inh)
229 || helpInh_helpless_options inh)
234 maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
235 h inh{helpInh_message=Nothing}
237 Doc.fillOrBreak (helpInh_tag_indent inh)
239 Schema.runSchema schema (helpInh_schema inh)
240 <> Doc.space) -- FIXME: space is not always needed
241 <> (if null ts then mempty else Doc.space)
242 <> Doc.align (runHelpNodes inh ts)
243 in [ Tree.Node (HelpNode_Tag, d) ts ]
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})
253 program n (Help h s) =
258 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
261 { helpInh_message = Nothing
262 , helpInh_command_rule = True
265 let ind = helpInh_command_indent inh in
266 Schema.runSchema schema (helpInh_schema inh)
267 <> (if null ts {- \|| not (helpInh_full inh)-} then mempty else Doc.newline)
268 <> Doc.incrIndent (Doc.spaces ind) ind
269 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
270 in [ Tree.Node (HelpNode_Rule, d) ts ]
279 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
282 { helpInh_message = Nothing
283 , helpInh_command_rule = True
286 let ind = helpInh_command_indent inh in
287 ref<>Doc.space<>"::= "
288 <> Schema.runSchema schema (helpInh_schema inh)
289 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
290 <> Doc.incrIndent (Doc.spaces ind) ind
291 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
292 in [ Tree.Node (HelpNode_Rule, d) ts ]
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)
309 ResponseConstraint repr a =>
310 repr (ResponseArgs repr a)
312 response' = Help mempty $ response' @(Schema d) @a
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)
322 = HelpPerm (HelpInh d -> HelpResult d)
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})
335 program n (HelpPerm h s) = HelpPerm
336 (help_result $ program n (Help h (runPermutation s)))
338 rule n (HelpPerm h s) = HelpPerm
339 (help_result $ rule n (Help h (runPermutation s)))