-
Notifications
You must be signed in to change notification settings - Fork 116
/
Core.hs
153 lines (135 loc) · 4.65 KB
/
Core.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
module Options.Applicative.Help.Core (
cmdDesc,
briefDesc,
fullDesc,
ParserHelp(..),
helpText,
headerHelp,
usageHelp,
bodyHelp,
footerHelp,
parserHelp,
parserUsage,
) where
import Control.Monad (guard)
import Data.List (intersperse, sort)
import Data.Maybe (maybeToList, catMaybes)
import Data.Monoid (Monoid, mempty, mappend, mconcat)
import Options.Applicative.Common
import Options.Applicative.Types
import Options.Applicative.Help.Pretty
import Options.Applicative.Help.Chunk
-- | Style for rendering an option.
data OptDescStyle = OptDescStyle
{ descSep :: Doc
, descHidden :: Bool
, descSurround :: Bool }
-- | Generate description for a single option.
optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> Chunk Doc
optDesc pprefs style info opt =
let ns = optionNames $ optMain opt
mv = stringChunk $ optMetaVar opt
descs = map (string . showOption) (sort ns)
desc' = listToChunk (intersperse (descSep style) descs) <<+>> mv
show_opt
| optVisibility opt == Hidden
= descHidden style
| otherwise
= optVisibility opt == Visible
suffix
| hinfoMulti info
= stringChunk . prefMultiSuffix $ pprefs
| otherwise
= mempty
render chunk
| not show_opt
= mempty
| isEmpty chunk || not (descSurround style)
= mappend chunk suffix
| hinfoDefault info
= mappend (fmap brackets chunk) suffix
| null (drop 1 descs)
= mappend chunk suffix
| otherwise
= mappend (fmap parens chunk) suffix
in render desc'
-- | Generate descriptions for commands.
cmdDesc :: Parser a -> Chunk Doc
cmdDesc = mconcat . mapParser desc
where
desc _ opt =
case optMain opt of
CmdReader cmds p ->
tabulate [(string cmd, align (extractChunk d))
| cmd <- reverse cmds
, d <- maybeToList . fmap infoProgDesc $ p cmd ]
_ -> mempty
-- | Generate a brief help text for a parser.
briefDesc :: ParserPrefs -> Parser a -> Chunk Doc
briefDesc pprefs = fold_tree . treeMapParser (optDesc pprefs style)
where
style = OptDescStyle
{ descSep = string "|"
, descHidden = False
, descSurround = True }
fold_tree (Leaf x) = x
fold_tree (MultNode xs) = foldr (<</>>) mempty . map fold_tree $ xs
fold_tree (AltNode xs) = alt_node
. filter (not . isEmpty)
. map fold_tree $ xs
alt_node :: [Chunk Doc] -> Chunk Doc
alt_node [n] = n
alt_node ns = fmap parens
. foldr (chunked (\x y -> x </> char '|' </> y)) mempty
$ ns
-- | Generate a full help text for a parser.
fullDesc :: ParserPrefs -> Parser a -> Chunk Doc
fullDesc pprefs = tabulate . catMaybes . mapParser doc
where
doc info opt = do
guard . not . isEmpty $ n
guard . not . isEmpty $ h
return (extractChunk n, align . extractChunk $ h <<+>> hdef)
where
n = optDesc pprefs style info opt
h = optHelp $ opt
hdef = Chunk . fmap show_def . optShowDefault $ opt
show_def s = parens (string "default:" <+> string s)
style = OptDescStyle
{ descSep = string ","
, descHidden = True
, descSurround = False }
data ParserHelp = ParserHelp
{ helpHeader :: Chunk Doc
, helpUsage :: Chunk Doc
, helpBody :: Chunk Doc
, helpFooter :: Chunk Doc }
instance Monoid ParserHelp where
mempty = ParserHelp mempty mempty mempty mempty
mappend (ParserHelp h1 u1 b1 f1) (ParserHelp h2 u2 b2 f2)
= ParserHelp (mappend h1 h2) (mappend u1 u2)
(mappend b1 b2) (mappend f1 f2)
headerHelp :: Chunk Doc -> ParserHelp
headerHelp chunk = ParserHelp chunk mempty mempty mempty
usageHelp :: Chunk Doc -> ParserHelp
usageHelp chunk = ParserHelp mempty chunk mempty mempty
bodyHelp :: Chunk Doc -> ParserHelp
bodyHelp chunk = ParserHelp mempty mempty chunk mempty
footerHelp :: Chunk Doc -> ParserHelp
footerHelp chunk = ParserHelp mempty mempty mempty chunk
helpText :: ParserHelp -> Doc
helpText (ParserHelp h u b f) = extractChunk . vsepChunks $ [h, u, b, f]
-- | Generate the help text for a program.
parserHelp :: ParserPrefs -> Parser a -> ParserHelp
parserHelp pprefs p = bodyHelp . vsepChunks $
[ with_title "Available options:" (fullDesc pprefs p)
, with_title "Available commands:" (cmdDesc p) ]
where
with_title :: String -> Chunk Doc -> Chunk Doc
with_title title = fmap (string title .$.)
-- | Generate option summary.
parserUsage :: ParserPrefs -> Parser a -> String -> Doc
parserUsage pprefs p progn = hsep $
[ string "Usage:"
, string progn
, align (extractChunk (briefDesc pprefs p)) ]