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