1 {-# LANGUAGE OverloadedStrings #-}
2 module Language.Symantic.CLI.Write.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(..))
10 import Data.Monoid (Monoid(..))
11 import Data.Semigroup (Semigroup(..))
12 import qualified Language.Symantic.Document.Term as Doc
14 import Language.Symantic.CLI.Sym
15 import qualified Language.Symantic.CLI.Write.Plain as Plain
20 { reader_help :: Maybe d -- ^ Current help.
21 -- , reader_define :: Bool -- ^ Whether to print a definition, or not.
23 , reader_command_indent :: Doc.Indent
24 , reader_option_indent :: Doc.Indent
25 , reader_plain :: Plain.Reader d
26 , reader_option_empty :: Bool
29 defReader :: Doc.Textable d => Reader d
31 { reader_help = Nothing
32 -- , reader_define = True
33 -- , reader_or = Doc.stringH " | "
34 , reader_command_indent = 2
35 , reader_option_indent = 20
36 , reader_plain = Plain.defReader
37 , reader_option_empty = False
43 defResult :: Monoid d => Result d
49 { help_result :: Reader d -> Result d
50 , help_plain :: Plain.Plain d e t a
53 runHelp :: Monoid d => Doc.Textable d => Help d e t a -> d
54 runHelp h = Doc.catV $ help_result h defReader
56 textHelp :: Plain.Doc d => Reader d -> Help d e t a -> d
57 textHelp def (Help h _p) =
61 coerceHelp :: Help d e s a -> Help d e t b
62 coerceHelp Help{help_plain, ..} = Help
63 { help_plain = Plain.coercePlain help_plain
67 instance Doc.Textable d => Semigroup (Help d e s a) where
68 Help hx px <> Help hy py = Help (hx<>hy) (px<>py)
69 instance (Doc.Textable d, Monoid d) => Monoid (Help d e s a) where
70 mempty = Help mempty mempty
73 instance (Semigroup d, IsString d) => IsString (Help d e s a) where
74 fromString "" = Help $ \_ro -> Nothing
75 fromString s = Help $ \_ro -> Just $ fromString s
76 instance Show (Help Doc.Term e s a) where
77 show = TL.unpack . Doc.textTerm . textHelp
79 instance Plain.Doc d => Sym_Fun (Help d) where
80 f <$$> Help h p = Help h (f<$$>p)
81 instance Plain.Doc d => Sym_App (Help d) where
82 value a = Help mempty (value a)
84 Help hf pf <**> Help hx px = Help (hf<>hx) (pf<**>px)
85 instance Plain.Doc d => Sym_Alt (Help d) where
86 Help hl pl <||> Help hr pr = Help (hl<>hr) (pl<||>pr)
87 try (Help h p) = Help h (try p)
88 choice hs = Help (mconcat $ help_result <$> hs) (choice (help_plain <$> hs))
89 option a (Help h p) = Help h (option a p)
90 instance Plain.Doc d => Sym_AltApp (Help d) where
91 many (Help h p) = Help h (many p)
92 some (Help h p) = Help h (many p)
95 = PermHelp (Reader d -> Result d)
97 type instance Perm (Help d e t) = PermHelp d e t
98 instance Plain.Doc d => Sym_Interleaved (Help d) where
99 interleaved (PermHelp h ps) = Help h $ interleaved $ Compose ps
100 f <<$>> Help h p = PermHelp h $ getCompose $ f<<$>>p
101 f <<$?>> (a, Help h p) = PermHelp h $ getCompose $ f<<$?>>(a,p)
102 f <<$*>> Help h p = PermHelp h $ getCompose $ f<<$*>>p
103 PermHelp hl pl <<|>> Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|>>pr
104 PermHelp hl pl <<|?>> (a, Help hr pr) = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|?>>(a,pr)
105 PermHelp hl pl <<|*>> Help hr pr = PermHelp (hl<>hr) $ getCompose $ Compose pl<<|*>>pr
106 instance Plain.Doc d => Sym_Rule (Help d) where
110 Doc.breakableFill 4 (ref<>" ::= "<> Plain.runPlain p' (reader_plain ro)) <>
111 Doc.align (Doc.catV (h ro{reader_help=Nothing}))
115 ref = Doc.bold $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.textH n)
116 instance Plain.Doc d => Sym_Option (Help d) where
117 var n (Help _h p) = Help mempty (var n p)
118 string = Help mempty string
119 tag n = Help mempty (tag n)
122 case reader_help ro of
124 if reader_option_empty ro
125 then pure $ Doc.bold (Plain.runPlain p' (reader_plain ro))
129 Doc.breakableFill (reader_option_indent ro)
130 (Doc.bold $ Plain.runPlain p' (reader_plain ro) <>
135 instance Plain.Doc d => Sym_Help d (Help d) where
136 help msg (Help h p) = Help
137 (\ro -> h ro{reader_help=Just msg})
138 (Language.Symantic.CLI.Sym.help msg p)
139 instance Plain.Doc d => Sym_Command (Help d) where
142 [ Plain.runPlain p' (reader_plain ro) <>
143 (case reader_help ro of
146 Doc.incrIndent (reader_command_indent ro) $
148 , Doc.catV $ h ro{reader_help=Nothing}
152 command n (Help h p) =
155 let d = ref<>" ::= "<>Plain.runPlain p' (reader_plain ro) in
156 case h ro{reader_help=Nothing} of
159 Doc.breakableFill 4 d <>
160 Doc.align (Doc.catV hs)
164 ref = Doc.bold $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.stringH n)
165 instance Plain.Doc d => Sym_Exit (Help d) where
166 exit e = Help mempty $ exit e