1module Options.Applicative.Help.Core ( 2 cmdDesc, 3 briefDesc, 4 missingDesc, 5 fullDesc, 6 ParserHelp(..), 7 errorHelp, 8 headerHelp, 9 suggestionsHelp, 10 usageHelp, 11 bodyHelp, 12 footerHelp, 13 parserHelp, 14 parserUsage, 15 ) where 16 17import Control.Applicative 18import Control.Monad (guard) 19import Data.Function (on) 20import Data.List (sort, intersperse, groupBy) 21import Data.Foldable (any) 22import Data.Maybe (maybeToList, catMaybes, fromMaybe) 23import Data.Monoid (mempty) 24import Data.Semigroup (Semigroup (..)) 25import Prelude hiding (any) 26 27import Options.Applicative.Common 28import Options.Applicative.Types 29import Options.Applicative.Help.Pretty 30import Options.Applicative.Help.Chunk 31 32-- | Style for rendering an option. 33data OptDescStyle = OptDescStyle 34 { descSep :: Doc 35 , descHidden :: Bool } 36 37safelast :: [a] -> Maybe a 38safelast = foldl (const Just) Nothing 39 40-- | Generate description for a single option. 41optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> (Chunk Doc, Wrapping) 42optDesc pprefs style info opt = 43 let names 44 = sort . optionNames . optMain $ opt 45 meta 46 = stringChunk $ optMetaVar opt 47 descs 48 = map (string . showOption) names 49 descriptions 50 = listToChunk (intersperse (descSep style) descs) 51 desc 52 | prefHelpLongEquals pprefs && not (isEmpty meta) && any isLongName (safelast names) 53 = descriptions <> stringChunk "=" <> meta 54 | otherwise 55 = descriptions <<+>> meta 56 show_opt 57 | optVisibility opt == Hidden 58 = descHidden style 59 | otherwise 60 = optVisibility opt == Visible 61 suffix 62 | hinfoMulti info 63 = stringChunk . prefMultiSuffix $ pprefs 64 | otherwise 65 = mempty 66 wrapping 67 = wrapIf (length names > 1) 68 rendered 69 | not show_opt 70 = mempty 71 | otherwise 72 = desc <> suffix 73 modified 74 = maybe id fmap (optDescMod opt) rendered 75 in (modified, wrapping) 76 77-- | Generate descriptions for commands. 78cmdDesc :: Parser a -> [(Maybe String, Chunk Doc)] 79cmdDesc = mapParser desc 80 where 81 desc _ opt = 82 case optMain opt of 83 CmdReader gn cmds p -> (,) gn $ 84 tabulate [(string cmd, align (extractChunk d)) 85 | cmd <- reverse cmds 86 , d <- maybeToList . fmap infoProgDesc $ p cmd ] 87 _ -> mempty 88 89-- | Generate a brief help text for a parser. 90briefDesc :: ParserPrefs -> Parser a -> Chunk Doc 91briefDesc = briefDesc' True 92 93-- | Generate a brief help text for a parser, only including mandatory 94-- options and arguments. 95missingDesc :: ParserPrefs -> Parser a -> Chunk Doc 96missingDesc = briefDesc' False 97 98-- | Generate a brief help text for a parser, allowing the specification 99-- of if optional arguments are show. 100briefDesc' :: Bool -> ParserPrefs -> Parser a -> Chunk Doc 101briefDesc' showOptional pprefs 102 = wrap NoDefault . foldTree . mfilterOptional . treeMapParser (optDesc pprefs style) 103 where 104 mfilterOptional 105 | showOptional 106 = id 107 | otherwise 108 = filterOptional 109 110 style = OptDescStyle 111 { descSep = string "|" 112 , descHidden = False } 113 114-- | Wrap a doc in parentheses or brackets if required. 115wrap :: AltNodeType -> (Chunk Doc, Wrapping) -> Chunk Doc 116wrap altnode (chunk, wrapping) 117 | altnode == MarkDefault 118 = fmap brackets chunk 119 | needsWrapping wrapping 120 = fmap parens chunk 121 | otherwise 122 = chunk 123 124-- Fold a tree of option docs into a single doc with fully marked 125-- optional areas and groups. 126foldTree :: OptTree (Chunk Doc, Wrapping) -> (Chunk Doc, Wrapping) 127foldTree (Leaf x) 128 = x 129foldTree (MultNode xs) 130 = (foldr ((<</>>) . wrap NoDefault . foldTree) mempty xs, Bare) 131foldTree (AltNode b xs) 132 = (\x -> (x, Bare)) 133 . fmap groupOrNestLine 134 . wrap b 135 . alt_node 136 . filter (not . isEmpty . fst) 137 . map foldTree $ xs 138 where 139 140 alt_node :: [(Chunk Doc, Wrapping)] -> (Chunk Doc, Wrapping) 141 alt_node [n] = n 142 alt_node ns = (\y -> (y, Wrapped)) 143 . foldr (chunked altSep . wrap NoDefault) mempty 144 $ ns 145 146-- | Generate a full help text for a parser. 147fullDesc :: ParserPrefs -> Parser a -> Chunk Doc 148fullDesc pprefs = tabulate . catMaybes . mapParser doc 149 where 150 doc info opt = do 151 guard . not . isEmpty $ n 152 guard . not . isEmpty $ h 153 return (extractChunk n, align . extractChunk $ h <<+>> hdef) 154 where 155 n = fst $ optDesc pprefs style info opt 156 h = optHelp opt 157 hdef = Chunk . fmap show_def . optShowDefault $ opt 158 show_def s = parens (string "default:" <+> string s) 159 style = OptDescStyle 160 { descSep = string "," 161 , descHidden = True } 162 163errorHelp :: Chunk Doc -> ParserHelp 164errorHelp chunk = mempty { helpError = chunk } 165 166headerHelp :: Chunk Doc -> ParserHelp 167headerHelp chunk = mempty { helpHeader = chunk } 168 169suggestionsHelp :: Chunk Doc -> ParserHelp 170suggestionsHelp chunk = mempty { helpSuggestions = chunk } 171 172usageHelp :: Chunk Doc -> ParserHelp 173usageHelp chunk = mempty { helpUsage = chunk } 174 175bodyHelp :: Chunk Doc -> ParserHelp 176bodyHelp chunk = mempty { helpBody = chunk } 177 178footerHelp :: Chunk Doc -> ParserHelp 179footerHelp chunk = mempty { helpFooter = chunk } 180 181-- | Generate the help text for a program. 182parserHelp :: ParserPrefs -> Parser a -> ParserHelp 183parserHelp pprefs p = bodyHelp . vsepChunks 184 $ with_title "Available options:" (fullDesc pprefs p) 185 : (group_title <$> cs) 186 where 187 def = "Available commands:" 188 189 cs = groupBy ((==) `on` fst) $ cmdDesc p 190 191 group_title a@((n,_):_) = with_title (fromMaybe def n) $ 192 vcatChunks (snd <$> a) 193 group_title _ = mempty 194 195 196 with_title :: String -> Chunk Doc -> Chunk Doc 197 with_title title = fmap (string title .$.) 198 199-- | Generate option summary. 200parserUsage :: ParserPrefs -> Parser a -> String -> Doc 201parserUsage pprefs p progn = hsep 202 [ string "Usage:" 203 , string progn 204 , align (extractChunk (briefDesc pprefs p)) ] 205 206data Wrapping 207 = Bare 208 | Wrapped 209 deriving (Eq, Show) 210 211wrapIf :: Bool -> Wrapping 212wrapIf b = if b then Wrapped else Bare 213 214needsWrapping :: Wrapping -> Bool 215needsWrapping = (==) Wrapped 216