module Options.Applicative.Help (
cmdDesc,
briefDesc,
fullDesc,
parserHelpText,
) where
import Data.List (intercalate, sort)
import Data.Maybe (maybeToList, catMaybes)
import Options.Applicative.Common
import Options.Applicative.Types
import Options.Applicative.Utils
showOption :: OptName -> String
showOption (OptLong n) = "--" ++ n
showOption (OptShort n) = '-' : [n]
data OptDescStyle = OptDescStyle
{ descSep :: String
, descHidden :: Bool
, descSurround :: Bool }
optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> String
optDesc pprefs style info opt =
let ns = optionNames $ optMain opt
mv = optMetaVar opt
descs = map showOption (sort ns)
desc' = intercalate (descSep style) descs <+> mv
show_opt
| optVisibility opt == Hidden
= descHidden style
| otherwise
= optVisibility opt == Visible
suffix
| hinfoMulti info
= prefMultiSuffix pprefs
| otherwise
= ""
render text
| not show_opt
= ""
| null text || not (descSurround style)
= text ++ suffix
| hinfoDefault info
= "[" ++ text ++ "]" ++ suffix
| null (drop 1 descs)
= text ++ suffix
| otherwise
= "(" ++ text ++ ")" ++ suffix
in render desc'
cmdDesc :: Parser a -> [String]
cmdDesc = concat . mapParser desc
where
desc _ opt =
case optMain opt of
CmdReader cmds p ->
tabulate [(cmd, d)
| cmd <- reverse cmds
, d <- maybeToList . fmap infoProgDesc $ p cmd ]
_ -> []
briefDesc :: ParserPrefs -> Parser a -> String
briefDesc pprefs = fold_tree . treeMapParser (optDesc pprefs style)
where
style = OptDescStyle
{ descSep = "|"
, descHidden = False
, descSurround = True }
fold_tree (Leaf x) = x
fold_tree (MultNode xs) = unwords (fold_trees xs)
fold_tree (AltNode xs) = alt_node (fold_trees xs)
alt_node [n] = n
alt_node ns = "(" ++ intercalate " | " ns ++ ")"
fold_trees = filter (not . null) . map fold_tree
fullDesc :: ParserPrefs -> Parser a -> [String]
fullDesc pprefs = tabulate . catMaybes . mapParser doc
where
doc info opt
| null n = Nothing
| null h = Nothing
| otherwise = Just (n, h ++ hdef)
where n = optDesc pprefs style info opt
h = optHelp opt
hdef = maybe "" show_def (optShowDefault opt)
show_def s = " (default: " ++ s ++ ")"
style = OptDescStyle
{ descSep = ","
, descHidden = True
, descSurround = False }
parserHelpText :: ParserPrefs -> ParserInfo a -> String
parserHelpText pprefs pinfo = unlines
$ nn [infoHeader pinfo]
++ [ " " ++ line | line <- nn [infoProgDesc pinfo] ]
++ [ line | let opts = fullDesc pprefs p
, not (null opts)
, line <- ["", "Available options:"] ++ opts
, infoFullDesc pinfo ]
++ [ line | let cmds = cmdDesc p
, not (null cmds)
, line <- ["", "Available commands:"] ++ cmds
, infoFullDesc pinfo ]
++ [ line | footer <- nn [infoFooter pinfo]
, line <- ["", footer] ]
where
nn = filter (not . null)
p = infoParser pinfo