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 :: Docable d => HelpInh d -> Help d f k -> d
31 runHelp def (Help h _p) = runHelpNodes def (h def) <> Doc.newline
33 docHelp :: Docable d => Doc.Indentable d => Docable 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 :: Docable 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'
91 Tree (HelpNode, d) -> d
92 runHelpNode (Tree.Node (n,d) _ts) = d -- "[" <> Doc.stringH (show n) <> "]" <> d
94 -- | Introduce 'Doc.newline' according to the 'HelpNode's
95 -- put next to each others.
100 Tree.Forest (HelpNode, d) -> d
101 runHelpNodes inh [] = mempty
102 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Command, _) t0s)
103 : t1@(Tree.Node (HelpNode_Command, _) _) : ts ) =
106 (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
107 runHelpNodes inh (t1:ts)
108 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Tag, _) _)
109 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
112 runHelpNodes inh (t1:ts)
113 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Rule, _) t0s)
114 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
117 (if null t0s || not (helpInh_full inh) then mempty else Doc.newline) <>
118 runHelpNodes inh (t1:ts)
119 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Env, _) _)
120 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
123 runHelpNodes inh (t1:ts)
124 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
128 runHelpNodes inh (t1:ts)
129 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
133 runHelpNodes inh (t1:ts)
134 runHelpNodes inh ( t0@(Tree.Node (HelpNode_Message, _) _)
139 runHelpNodes inh (t1:ts)
140 runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts
142 instance Semigroup d => Semigroup (Help d f k) where
143 Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
144 instance Monoid d => Monoid (Help d f k) where
145 mempty = Help mempty mempty
148 instance (Semigroup d, IsString d) => IsString (Help d e s a) where
149 fromString "" = Help $ \_ro -> Nothing
150 fromString s = Help $ \_ro -> Just $ fromString s
151 instance Show (Help Doc.Term e s a) where
152 show = TL.unpack . Doc.textTerm . runHelp
153 instance Docable d => Functor (Help d f) where
154 f <$$> Help h s = Help h (f<$$>s)
156 instance Docable d => App (Help d) where
157 Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
158 instance Docable d => Alt (Help d) where
159 Help hl pl <!> Help hr pr = Help (hl<>hr) (pl<!>pr)
160 opt (Help h s) = Help h (opt s)
162 try (Help h s) = Help h (try s)
163 choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs))
164 option a (Help h s) = Help h (option a s)
166 instance Docable d => Permutable (Help d) where
167 type Permutation (Help d) = HelpPerm d
168 runPermutation (HelpPerm h s) = Help h $ runPermutation s
169 toPermutation (Help h s) = HelpPerm h $ toPermutation s
170 toPermDefault a (Help h s) = HelpPerm h $ toPermDefault a s
171 instance Pro (Help d) where
172 dimap a2b b2a (Help h s) = Help h $ dimap a2b b2a s
173 instance Docable d => AltApp (Help d) where
174 many0 (Help h s) = Help h (many0 s)
175 many1 (Help h s) = Help h (many1 s)
176 instance Docable d => CLI_Var (Help d) where
177 type VarConstraint (Help d) a = ()
178 var' n = Help mempty (var' n)
179 just a = Help mempty (just a)
180 nothing = Help mempty nothing
181 instance Docable d => CLI_Env (Help d) where
182 type EnvConstraint (Help d) a = ()
185 let ts = maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) in
187 Doc.breakfill (helpInh_tag_indent inh)
188 (Doc.bold (Doc.green (Doc.from (Doc.Word n)))
190 <> (if null ts then mempty else Doc.space)
191 <> Doc.align (runHelpNodes inh ts)
193 [ Tree.Node (HelpNode_Env, d) ts ]
195 where schema = env' n
196 instance Docable d => CLI_Command (Help d) where
197 -- type CommandConstraint (Help d) a = ()
198 command n (Help h s) =
202 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
205 { helpInh_message = Nothing
206 , helpInh_command_rule = True
209 (if not (null n) && helpInh_command_rule inh 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 (helpInh_command_indent inh)
213 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
215 [ Tree.Node (HelpNode_Command, d) ts ]
223 Doc.from (Doc.Word n)
224 instance Docable d => CLI_Tag (Help d) where
225 type TagConstraint (Help d) a = ()
226 tagged n (Help h s) =
228 if (isJust (helpInh_message inh)
229 || helpInh_helpless_options inh)
233 maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
234 h inh{helpInh_message=Nothing} in
236 Doc.breakfill (helpInh_tag_indent inh)
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)
243 [ Tree.Node (HelpNode_Tag, d) ts ]
246 where schema = tagged n s
247 endOpts = Help mempty endOpts
248 instance Docable 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) =
257 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
260 { helpInh_message = Nothing
261 , helpInh_command_rule = True
264 Schema.runSchema schema (helpInh_schema inh)
265 <> (if null ts {-|| not (helpInh_full inh)-} then mempty else Doc.newline)
267 (helpInh_command_indent inh)
268 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
270 [ Tree.Node (HelpNode_Rule, d) ts ]
278 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
281 { helpInh_message = Nothing
282 , helpInh_command_rule = True
285 ref<>Doc.space<>"::= "
286 <> Schema.runSchema schema (helpInh_schema inh)
287 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
289 (helpInh_command_indent inh)
290 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
292 [ Tree.Node (HelpNode_Rule, d) ts ]
300 Doc.from (Doc.Word n)
301 type HelpResponseArgs = SchemaResponseArgs
302 instance Docable 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 Docable 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 Docable 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)))