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 Perm (Help d e t) = PermHelp d e t
132 instance Plain.Doc d => Sym_Interleaved (Help d) where
133 interleaved (PermHelp h ps) = Help h $ interleaved $ Compose ps
134 f <<$>> Help h p = PermHelp h $ getCompose $ f<<$>>p
135 f <<$?>> (a, Help h p) = PermHelp h $ getCompose $ f<<$?>>(a,p)
136 f <<$*>> Help h p = PermHelp h $ getCompose $ f<<$*>>p
137 PermHelp hl pl <<|>> Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|>>pr
138 PermHelp hl pl <<|?>> (a, Help hr pr) = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|?>>(a,pr)
139 PermHelp hl pl <<|*>> Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|*>>pr
140 instance Plain.Doc d => Sym_Rule (Help d) where
145 (reader_command_indent ro)
146 (Doc.newline <> Doc.newline) $
147 ref<>" ::= "<>Plain.runPlain p' (reader_plain ro)) $
148 maybeToList (pure . Leaf Doc.empty <$> reader_help ro) <>
149 h ro{reader_help=Nothing}
155 Doc.between (Doc.charH '<') (Doc.charH '>') $
158 instance Plain.Doc d => Sym_Option (Help d) where
159 var n f = Help mempty (var n f)
160 tag n = Help mempty (tag n)
163 case reader_help ro of
165 if reader_option_empty ro
167 pure $ pure $ Leaf Doc.newline $ Doc.bold $
168 Plain.runPlain p' (reader_plain ro)
174 (reader_option_indent ro)
176 (Doc.bold $ Plain.runPlain p' (reader_plain ro) <> Doc.space)) $
177 pure $ pure $ Leaf Doc.empty msg
180 instance Plain.Doc d => Sym_Help d (Help d) where
181 help msg (Help h p) = Help
182 (\ro -> h ro{reader_help=Just msg})
183 (Language.Symantic.CLI.Sym.help msg p)
184 instance Plain.Doc d => Sym_Command (Help d) where
188 Tree.Node (Indented 0
189 (Doc.newline <> Doc.newline) $
190 Plain.runPlain p' (reader_plain ro) <>
192 (\d -> Doc.newline <> Doc.newline <> d <> Doc.newline)
195 h ro{reader_help=Nothing}
198 command n (Help h p) =
203 (reader_command_indent ro)
204 (Doc.newline <> Doc.newline) $
206 Plain.runPlain p' (reader_plain ro) <>
209 . Doc.incrIndent (reader_command_indent ro)
213 h ro{reader_help=Nothing}
219 Doc.between (Doc.charH '<') (Doc.charH '>') $
222 instance Plain.Doc d => Sym_Exit (Help d) where
223 exit e = Help mempty $ exit e