1 {-# LANGUAGE OverloadedStrings #-}
2 module Language.Symantic.CLI.Help where
4 import Control.Applicative (Applicative(..))
6 import Data.Function (($), (.))
7 import Data.Functor ((<$>))
8 import Data.Functor.Compose (Compose(..))
9 import Data.Maybe (Maybe(..), maybeToList, maybe)
10 import Data.Monoid (Monoid(..))
11 import Data.Semigroup (Semigroup(..))
12 import qualified Language.Symantic.Document.Term as Doc
13 import Data.Tree as Tree
15 import Language.Symantic.CLI.Sym
16 import qualified Language.Symantic.CLI.Plain as Plain
21 { reader_help :: Maybe d
22 , reader_command_indent :: Doc.Indent
23 , reader_option_indent :: Doc.Indent
24 , reader_plain :: Plain.Reader d
25 , reader_option_empty :: Bool
28 defReader :: Doc.Textable d => Reader d
30 { reader_help = Nothing
31 , reader_command_indent = 2
32 , reader_option_indent = 15
33 , reader_plain = Plain.defReader
34 , reader_option_empty = False
38 type Result d = Tree.Forest (DocNode d)
40 defResult :: Monoid d => Result d
50 { docNodeIndent :: Doc.Indent
55 { docNodeIndent :: Doc.Indent
65 docTree (Tree.Node n []) = docNode n
66 docTree (Tree.Node n ts) =
69 Indented ind _sep d -> d <> Doc.incrIndent ind (Doc.newline <> docTrees ts)
70 BreakableFill ind _sep d -> Doc.breakableFill ind d <> (Doc.align $ docTrees ts)
76 Tree.Forest (DocNode d) -> d
77 docTrees [] = Doc.empty
78 docTrees [t] = docTree t
80 docTree t0 <> mconcat ((\t@(Tree.Node n _ns) -> docNodeSep n <> docTree t) <$> ts)
85 { help_result :: Reader d -> Result d
86 , help_plain :: Plain.Plain d e t a
89 runHelp :: Monoid d => Doc.Indentable d => Doc.Textable d => Help d e t a -> d
90 runHelp h = docTrees $ help_result h defReader
92 textHelp :: Plain.Doc d => Reader d -> Help d e t a -> d
93 textHelp def (Help h _p) = docTrees $ h def
95 coerceHelp :: Help d e s a -> Help d e t b
96 coerceHelp Help{help_plain, ..} = Help
97 { help_plain = Plain.coercePlain help_plain
101 instance Doc.Textable d => Semigroup (Help d e s a) where
102 Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
103 instance (Doc.Textable d, Monoid d) => Monoid (Help d e s a) where
104 mempty = Help mempty mempty
107 instance (Semigroup d, IsString d) => IsString (Help d e s a) where
108 fromString "" = Help $ \_ro -> Nothing
109 fromString s = Help $ \_ro -> Just $ fromString s
110 instance Show (Help Doc.Term e s a) where
111 show = TL.unpack . Doc.textTerm . textHelp
113 instance Plain.Doc d => Sym_Fun (Help d) where
114 f <$$> Help h p = Help h (f<$$>p)
115 instance Plain.Doc d => Sym_App (Help d) where
116 value a = Help mempty (value a)
117 end = Help mempty end
118 Help hf pf <**> Help hx px = Help (hf<>hx) (pf<**>px)
119 instance Plain.Doc d => Sym_Alt (Help d) where
120 Help hl pl <||> Help hr pr = Help (hl<>hr) (pl<||>pr)
121 try (Help h p) = Help h (try p)
122 choice hs = Help (mconcat $ help_result <$> hs) (choice (help_plain <$> hs))
123 option a (Help h p) = Help h (option a p)
124 instance Plain.Doc d => Sym_AltApp (Help d) where
125 many (Help h p) = Help h (many p)
126 some (Help h p) = Help h (many p)
128 data PermHelp d e t a
129 = PermHelp (Reader d -> Result d)
130 [Plain.Plain d e t a]
131 type instance Permutation (Help d e t) = PermHelp d e t
132 instance Plain.Doc d => Sym_Permutation (Help d) where
133 runPermutation (PermHelp h ps) = Help h $ runPermutation $ Compose ps
134 toPermutation (Help h p) = PermHelp h $ getCompose $ toPermutation p
135 toPermutationWithDefault d (Help h p) = PermHelp h $ getCompose $ toPermutationWithDefault d p
136 f <<$>> Help h p = PermHelp h $ getCompose $ f<<$>>p
137 f <<$ Help h p = PermHelp h $ getCompose $ f<<$p
138 f <<$?>> (a, Help h p) = PermHelp h $ getCompose $ f<<$?>>(a,p)
139 f <<$? (a, Help h p) = PermHelp h $ getCompose $ f<<$? (a,p)
140 f <<$*>> Help h p = PermHelp h $ getCompose $ f<<$*>>p
141 f <<$:>> Help h p = PermHelp h $ getCompose $ f<<$:>>p
142 PermHelp hl pl <<|>> Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|>>pr
143 PermHelp hl pl <<| Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|pr
144 PermHelp hl pl <<|?>> (a, Help hr pr) = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|?>>(a,pr)
145 PermHelp hl pl <<|? (a, Help hr pr) = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|?(a,pr)
146 PermHelp hl pl <<|*>> Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|*>>pr
147 PermHelp hl pl <<|:>> Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|:>>pr
148 instance Plain.Doc d => Sym_Rule (Help d) where
153 (reader_command_indent ro)
154 (Doc.newline <> Doc.newline) $
155 ref<>" ::= "<>Plain.runPlain p' (reader_plain ro)) $
156 maybeToList (pure . Leaf Doc.empty <$> reader_help ro) <>
157 h ro{reader_help=Nothing}
163 Doc.between (Doc.charH '<') (Doc.charH '>') $
166 instance Plain.Doc d => Sym_Option (Help d) where
167 var n f = Help mempty (var n f)
168 tag n = Help mempty (tag n)
171 case reader_help ro of
173 if reader_option_empty ro
175 pure $ pure $ Leaf Doc.newline $ Doc.bold $
176 Plain.runPlain p' (reader_plain ro)
182 (reader_option_indent ro)
184 (Doc.bold $ Plain.runPlain p' (reader_plain ro) <> Doc.space)) $
185 pure $ pure $ Leaf Doc.empty msg
188 instance Plain.Doc d => Sym_Help d (Help d) where
189 help msg (Help h p) = Help
190 (\ro -> h ro{reader_help=Just msg})
191 (Language.Symantic.CLI.Sym.help msg p)
192 instance Plain.Doc d => Sym_Command (Help d) where
196 Tree.Node (Indented 0
197 (Doc.newline <> Doc.newline) $
198 Plain.runPlain p' (reader_plain ro) <>
200 (\d -> Doc.newline <> Doc.newline <> d <> Doc.newline)
203 h ro{reader_help=Nothing}
206 command n (Help h p) =
211 (reader_command_indent ro)
212 (Doc.newline <> Doc.newline) $
214 Plain.runPlain p' (reader_plain ro) <>
217 . Doc.incrIndent (reader_command_indent ro)
221 h ro{reader_help=Nothing}
227 Doc.between (Doc.charH '<') (Doc.charH '>') $
230 instance Plain.Doc d => Sym_Exit (Help d) where
231 exit e = Help mempty $ exit e