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
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 _ 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 (_, _) _) : 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_Message, _) _)
124 runHelpNodes inh (t1:ts)
125 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Tag, _) _) : ts ) =
129 runHelpNodes inh (t1:ts)
130 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Env, _) _) : ts ) =
134 runHelpNodes inh (t1:ts)
135 runHelpNodes inh ( t0 : t1@(Tree.Node (HelpNode_Rule, _) _) : ts ) =
138 runHelpNodes inh (t1:ts)
139 runHelpNodes inh (t:ts) = runHelpNode t <> runHelpNodes inh ts
141 instance Semigroup d => Semigroup (Help d f k) where
142 Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
143 instance Monoid d => Monoid (Help d f k) where
144 mempty = Help mempty mempty
147 instance (Semigroup d, IsString d) => IsString (Help d e s a) where
148 fromString "" = Help $ \_ro -> Nothing
149 fromString s = Help $ \_ro -> Just $ fromString s
150 instance Show (Help Doc.Term e s a) where
151 show = TL.unpack . Doc.textTerm . runHelp
152 instance Docable d => Functor (Help d f) where
153 f <$$> Help h s = Help h (f<$$>s)
155 instance Docable d => App (Help d) where
156 Help hf pf <.> Help hx px = Help (hf<>hx) (pf<.>px)
157 instance Docable d => Alt (Help d) where
158 Help hl pl <!> Help hr pr = Help (hl<>hr) (pl<!>pr)
159 opt (Help h s) = Help h (opt s)
161 try (Help h s) = Help h (try s)
162 choice hs = Help (mconcat $ help_result <$> hs) (choice (help_schema <$> hs))
163 option a (Help h s) = Help h (option a s)
165 instance Docable d => Permutable (Help d) where
166 type Permutation (Help d) = HelpPerm d
167 runPermutation (HelpPerm h s) = Help h $ runPermutation s
168 toPermutation (Help h s) = HelpPerm h $ toPermutation s
169 toPermDefault a (Help h s) = HelpPerm h $ toPermDefault a s
170 instance Pro (Help d) where
171 dimap a2b b2a (Help h s) = Help h $ dimap a2b b2a s
172 instance Docable d => AltApp (Help d) where
173 many0 (Help h s) = Help h (many0 s)
174 many1 (Help h s) = Help h (many1 s)
175 instance Docable d => CLI_Var (Help d) where
176 type VarConstraint (Help d) a = ()
177 var' n = Help mempty (var' n)
178 just a = Help mempty (just a)
179 nothing = Help mempty nothing
180 instance Docable d => CLI_Env (Help d) where
181 type EnvConstraint (Help d) a = ()
186 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
189 Doc.breakfill (helpInh_tag_indent inh)
190 (Doc.bold (Doc.green (Doc.from (Doc.Word n)))
192 <> (if null ts then mempty else Doc.space)
193 <> Doc.align (runHelpNodes inh ts)
195 [ Tree.Node (HelpNode_Env, d) ts ]
197 where schema = env' n
198 instance Docable d => CLI_Command (Help d) where
199 -- type CommandConstraint (Help d) a = ()
200 command n (Help h s) =
204 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
207 { helpInh_message = Nothing
208 , helpInh_command_rule = True
211 (if not (null n) && helpInh_command_rule inh
212 then ref<>Doc.space<>"::= " else mempty)
213 <> Schema.runSchema schema (helpInh_schema inh)
214 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
215 <> Doc.incrIndent (helpInh_command_indent inh)
216 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
218 [ Tree.Node (HelpNode_Command, d) ts ]
226 Doc.from (Doc.Word n)
227 instance Docable d => CLI_Tag (Help d) where
228 type TagConstraint (Help d) a = ()
229 tagged n (Help h s) =
231 if (isJust (helpInh_message inh)
232 || helpInh_helpless_options inh)
236 maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh) <>
237 h inh{helpInh_message=Nothing} in
239 Doc.breakfill (helpInh_tag_indent inh)
241 Schema.runSchema schema (helpInh_schema inh)
242 <> Doc.space) -- FIXME: space is not always needed
243 <> (if null ts then mempty else Doc.space)
244 <> Doc.align (runHelpNodes inh ts)
246 [ Tree.Node (HelpNode_Tag, d) ts ]
249 where schema = tagged n s
250 endOpts = Help mempty endOpts
251 instance Docable d => CLI_Help (Help d) where
252 type HelpConstraint (Help d) d' = d ~ d'
253 help msg (Help h s) = Help
254 (\inh -> h inh{helpInh_message=Just msg})
256 program n (Help h s) =
260 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
263 { helpInh_message = Nothing
264 , helpInh_command_rule = True
267 Schema.runSchema schema (helpInh_schema inh)
268 <> (if null ts {-|| not (helpInh_full inh)-} then mempty else Doc.newline)
270 (helpInh_command_indent inh)
271 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
273 [ Tree.Node (HelpNode_Rule, d) ts ]
281 then maybe [] (pure . pure . (HelpNode_Message,)) (helpInh_message inh)
284 { helpInh_message = Nothing
285 , helpInh_command_rule = True
288 ref<>Doc.space<>"::= "
289 <> Schema.runSchema schema (helpInh_schema inh)
290 <> (if null ts || not (helpInh_full inh) then mempty else Doc.newline)
292 (helpInh_command_indent inh)
293 ((if null ts then mempty else Doc.newline) <> runHelpNodes inh ts)
295 [ Tree.Node (HelpNode_Rule, d) ts ]
303 Doc.from (Doc.Word n)
304 type HelpResponseArgs = SchemaResponseArgs
305 instance Docable d => CLI_Response (Help d) where
306 type ResponseConstraint (Help d) a = () -- ResponseConstraint (Schema d)
307 type ResponseArgs (Help d) a = SchemaResponseArgs a -- ResponseArgs (Schema d) a
308 type Response (Help d) = () -- Response (Schema d)
312 ResponseConstraint repr a =>
313 repr (ResponseArgs repr a)
315 response' = Help mempty $ response' @(Schema d) @a
318 instance Docable d => Sym_AltApp (Help d) where
319 many (Help h s) = Help h (many s)
320 some (Help h s) = Help h (many s)
325 = HelpPerm (HelpInh d -> HelpResult d)
327 instance Functor (HelpPerm d k) where
328 f`fmap`HelpPerm h ps = HelpPerm h (f<$>ps)
329 instance Applicative (HelpPerm d k) where
330 pure a = HelpPerm mempty (pure a)
331 HelpPerm fh f <*> HelpPerm xh x =
332 HelpPerm (fh<>xh) (f<*>x)
333 instance Docable d => CLI_Help (HelpPerm d) where
334 type HelpConstraint (HelpPerm d) d' = d ~ d'
335 help msg (HelpPerm h s) = HelpPerm
336 (\inh -> h inh{helpInh_message=Just msg})
338 program n (HelpPerm h s) = HelpPerm
339 (help_result $ program n (Help h (runPermutation s)))
341 rule n (HelpPerm h s) = HelpPerm
342 (help_result $ rule n (Help h (runPermutation s)))