1module Options.Applicative.Help.Core (
2  cmdDesc,
3  briefDesc,
4  missingDesc,
5  fullDesc,
6  globalDesc,
7  ParserHelp(..),
8  errorHelp,
9  headerHelp,
10  suggestionsHelp,
11  usageHelp,
12  bodyHelp,
13  footerHelp,
14  globalsHelp,
15  parserHelp,
16  parserUsage,
17  parserGlobals
18  ) where
19
20import Control.Applicative
21import Control.Monad (guard)
22import Data.Function (on)
23import Data.List (sort, intersperse, groupBy)
24import Data.Foldable (any, foldl')
25import Data.Maybe (maybeToList, catMaybes, fromMaybe)
26import Data.Monoid (mempty)
27import Data.Semigroup (Semigroup (..))
28import Prelude hiding (any)
29
30import Options.Applicative.Common
31import Options.Applicative.Types
32import Options.Applicative.Help.Pretty
33import Options.Applicative.Help.Chunk
34
35-- | Style for rendering an option.
36data OptDescStyle
37  = OptDescStyle
38      { descSep :: Doc,
39        descHidden :: Bool,
40        descGlobal :: Bool
41      }
42
43safelast :: [a] -> Maybe a
44safelast = foldl' (const Just) Nothing
45
46-- | Generate description for a single option.
47optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (Chunk Doc, Parenthetic)
48optDesc pprefs style _reachability opt =
49  let names =
50        sort . optionNames . optMain $ opt
51      meta =
52        stringChunk $ optMetaVar opt
53      descs =
54        map (string . showOption) names
55      descriptions =
56        listToChunk (intersperse (descSep style) descs)
57      desc
58        | prefHelpLongEquals pprefs && not (isEmpty meta) && any isLongName (safelast names) =
59          descriptions <> stringChunk "=" <> meta
60        | otherwise =
61          descriptions <<+>> meta
62      show_opt
63        | descGlobal style && not (propShowGlobal (optProps opt)) =
64          False
65        | optVisibility opt == Hidden =
66          descHidden style
67        | otherwise =
68          optVisibility opt == Visible
69      wrapping
70        | null names =
71          NeverRequired
72        | length names == 1 =
73          MaybeRequired
74        | otherwise =
75          AlwaysRequired
76      rendered
77        | not show_opt =
78          mempty
79        | otherwise =
80          desc
81      modified =
82        maybe id fmap (optDescMod opt) rendered
83   in (modified, wrapping)
84
85-- | Generate descriptions for commands.
86cmdDesc :: Parser a -> [(Maybe String, Chunk Doc)]
87cmdDesc = mapParser desc
88  where
89    desc _ opt =
90      case optMain opt of
91        CmdReader gn cmds p ->
92          (,) gn $
93            tabulate
94              [ (string cmd, align (extractChunk d))
95                | cmd <- reverse cmds,
96                  d <- maybeToList . fmap infoProgDesc $ p cmd
97              ]
98        _ -> mempty
99
100-- | Generate a brief help text for a parser.
101briefDesc :: ParserPrefs -> Parser a -> Chunk Doc
102briefDesc = briefDesc' True
103
104-- | Generate a brief help text for a parser, only including mandatory
105--   options and arguments.
106missingDesc :: ParserPrefs -> Parser a -> Chunk Doc
107missingDesc = briefDesc' False
108
109-- | Generate a brief help text for a parser, allowing the specification
110--   of if optional arguments are show.
111briefDesc' :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
112briefDesc' showOptional pprefs =
113  wrapOver NoDefault MaybeRequired
114    . foldTree pprefs style
115    . mfilterOptional
116    . treeMapParser (optDesc pprefs style)
117  where
118    mfilterOptional
119      | showOptional =
120        id
121      | otherwise =
122        filterOptional
123    style = OptDescStyle
124      { descSep = string "|",
125        descHidden = False,
126        descGlobal = False
127      }
128
129-- | Wrap a doc in parentheses or brackets if required.
130wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
131wrapOver altnode mustWrapBeyond (chunk, wrapping)
132  | altnode == MarkDefault =
133    fmap brackets chunk
134  | wrapping > mustWrapBeyond =
135    fmap parens chunk
136  | otherwise =
137    chunk
138
139-- Fold a tree of option docs into a single doc with fully marked
140-- optional areas and groups.
141foldTree :: ParserPrefs -> OptDescStyle -> OptTree (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
142foldTree _ _ (Leaf x) =
143  x
144foldTree prefs s (MultNode xs) =
145  let go =
146        (<</>>) . wrapOver NoDefault MaybeRequired . foldTree prefs s
147      x =
148        foldr go mempty xs
149      wrapLevel =
150        mult_wrap xs
151   in (x, wrapLevel)
152  where
153    mult_wrap [_] = NeverRequired
154    mult_wrap _ = MaybeRequired
155foldTree prefs s (AltNode b xs) =
156  (\x -> (x, NeverRequired))
157    . fmap groupOrNestLine
158    . wrapOver b MaybeRequired
159    . alt_node
160    . filter (not . isEmpty . fst)
161    . map (foldTree prefs s)
162    $ xs
163  where
164    alt_node :: [(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic)
165    alt_node [n] = n
166    alt_node ns =
167      (\y -> (y, AlwaysRequired))
168        . foldr (chunked altSep . wrapOver NoDefault MaybeRequired) mempty
169        $ ns
170foldTree prefs s (BindNode x) =
171  let rendered =
172        wrapOver NoDefault NeverRequired (foldTree prefs s x)
173
174      -- We always want to display the rendered option
175      -- if it exists, and only attach the suffix then.
176      withSuffix =
177        rendered >>= (\r -> pure r <> stringChunk (prefMultiSuffix prefs))
178   in (withSuffix, NeverRequired)
179
180-- | Generate a full help text for a parser
181fullDesc :: ParserPrefs -> Parser a -> Chunk Doc
182fullDesc = optionsDesc False
183
184-- | Generate a help text for the parser, showing
185--   only what is relevant in the "Global options: section"
186globalDesc :: ParserPrefs -> Parser a -> Chunk Doc
187globalDesc = optionsDesc True
188
189-- | Common generator for full descriptions and globals
190optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
191optionsDesc global pprefs = tabulate . catMaybes . mapParser doc
192  where
193    doc info opt = do
194      guard . not . isEmpty $ n
195      guard . not . isEmpty $ h
196      return (extractChunk n, align . extractChunk $ h <</>> hdef)
197      where
198        n = fst $ optDesc pprefs style info opt
199        h = optHelp opt
200        hdef = Chunk . fmap show_def . optShowDefault $ opt
201        show_def s = parens (string "default:" <+> string s)
202    style = OptDescStyle
203      { descSep = string ",",
204        descHidden = True,
205        descGlobal = global
206      }
207
208errorHelp :: Chunk Doc -> ParserHelp
209errorHelp chunk = mempty { helpError = chunk }
210
211headerHelp :: Chunk Doc -> ParserHelp
212headerHelp chunk = mempty { helpHeader = chunk }
213
214suggestionsHelp :: Chunk Doc -> ParserHelp
215suggestionsHelp chunk = mempty { helpSuggestions = chunk }
216
217globalsHelp :: Chunk Doc -> ParserHelp
218globalsHelp chunk = mempty { helpGlobals = chunk }
219
220usageHelp :: Chunk Doc -> ParserHelp
221usageHelp chunk = mempty { helpUsage = chunk }
222
223bodyHelp :: Chunk Doc -> ParserHelp
224bodyHelp chunk = mempty { helpBody = chunk }
225
226footerHelp :: Chunk Doc -> ParserHelp
227footerHelp chunk = mempty { helpFooter = chunk }
228
229-- | Generate the help text for a program.
230parserHelp :: ParserPrefs -> Parser a -> ParserHelp
231parserHelp pprefs p =
232  bodyHelp . vsepChunks $
233    with_title "Available options:" (fullDesc pprefs p)
234      : (group_title <$> cs)
235  where
236    def = "Available commands:"
237    cs = groupBy ((==) `on` fst) $ cmdDesc p
238
239    group_title a@((n, _) : _) =
240      with_title (fromMaybe def n) $
241        vcatChunks (snd <$> a)
242    group_title _ = mempty
243
244    with_title :: String -> Chunk Doc -> Chunk Doc
245    with_title title = fmap (string title .$.)
246
247
248parserGlobals :: ParserPrefs -> Parser a -> ParserHelp
249parserGlobals pprefs p =
250  globalsHelp $
251    (.$.) <$> stringChunk "Global options:"
252          <*> globalDesc pprefs p
253
254
255
256-- | Generate option summary.
257parserUsage :: ParserPrefs -> Parser a -> String -> Doc
258parserUsage pprefs p progn =
259  hsep
260    [ string "Usage:",
261      string progn,
262      align (extractChunk (briefDesc pprefs p))
263    ]
264
265-- | Peek at the structure of the rendered tree within.
266--
267--   For example, if a child is an option with multiple
268--   alternatives, such as -a or -b, we need to know this
269--   when wrapping it. For example, whether it's optional:
270--   we don't want to have [(-a|-b)], rather [-a|-b] or
271--   (-a|-b).
272data Parenthetic
273  = NeverRequired
274  -- ^ Parenthesis are not required.
275  | MaybeRequired
276  -- ^ Parenthesis should be used if this group can be repeated
277  | AlwaysRequired
278  -- ^ Parenthesis should always be used.
279  deriving (Eq, Ord, Show)
280