1{-# LANGUAGE RankNTypes #-} 2module Options.Applicative.Extra ( 3 -- * Extra parser utilities 4 -- 5 -- | This module contains high-level functions to run parsers. 6 helper, 7 hsubparser, 8 execParser, 9 customExecParser, 10 execParserPure, 11 getParseResult, 12 handleParseResult, 13 parserFailure, 14 renderFailure, 15 ParserFailure(..), 16 overFailure, 17 ParserResult(..), 18 ParserPrefs(..), 19 CompletionResult(..), 20 ) where 21 22import Control.Applicative 23import Control.Monad (void) 24import Data.Monoid 25import Data.Foldable (traverse_) 26import Prelude 27import System.Environment (getArgs, getProgName) 28import System.Exit (exitSuccess, exitWith, ExitCode(..)) 29import System.IO (hPutStrLn, stderr) 30 31import Options.Applicative.BashCompletion 32import Options.Applicative.Builder 33import Options.Applicative.Builder.Internal 34import Options.Applicative.Common 35import Options.Applicative.Help 36 37import Options.Applicative.Internal 38import Options.Applicative.Types 39 40-- | A hidden \"helper\" option which always fails. 41-- 42-- A common usage pattern is to apply this applicatively when 43-- creating a 'ParserInfo' 44-- 45-- > opts :: ParserInfo Sample 46-- > opts = info (sample <**> helper) mempty 47 48helper :: Parser (a -> a) 49helper = 50 option helpReader $ 51 mconcat 52 [ long "help", 53 short 'h', 54 help "Show this help text", 55 value id, 56 metavar "", 57 noGlobal, 58 noArgError (ShowHelpText Nothing), 59 hidden 60 ] 61 where 62 helpReader = do 63 potentialCommand <- readerAsk 64 readerAbort $ 65 ShowHelpText (Just potentialCommand) 66 67-- | Builder for a command parser with a \"helper\" option attached. 68-- Used in the same way as `subparser`, but includes a \"--help|-h\" inside 69-- the subcommand. 70hsubparser :: Mod CommandFields a -> Parser a 71hsubparser m = mkParser d g rdr 72 where 73 Mod _ d g = metavar "COMMAND" `mappend` m 74 (groupName, cmds, subs) = mkCommand m 75 rdr = CmdReader groupName cmds (fmap add_helper . subs) 76 add_helper pinfo = pinfo 77 { infoParser = infoParser pinfo <**> helper } 78 79-- | Run a program description. 80-- 81-- Parse command line arguments. Display help text and exit if any parse error 82-- occurs. 83execParser :: ParserInfo a -> IO a 84execParser = customExecParser defaultPrefs 85 86-- | Run a program description with custom preferences. 87customExecParser :: ParserPrefs -> ParserInfo a -> IO a 88customExecParser pprefs pinfo 89 = execParserPure pprefs pinfo <$> getArgs 90 >>= handleParseResult 91 92-- | Handle `ParserResult`. 93handleParseResult :: ParserResult a -> IO a 94handleParseResult (Success a) = return a 95handleParseResult (Failure failure) = do 96 progn <- getProgName 97 let (msg, exit) = renderFailure failure progn 98 case exit of 99 ExitSuccess -> putStrLn msg 100 _ -> hPutStrLn stderr msg 101 exitWith exit 102handleParseResult (CompletionInvoked compl) = do 103 progn <- getProgName 104 msg <- execCompletion compl progn 105 putStr msg 106 exitSuccess 107 108-- | Extract the actual result from a `ParserResult` value. 109-- 110-- This function returns 'Nothing' in case of errors. Possible error messages 111-- or completion actions are simply discarded. 112-- 113-- If you want to display error messages and invoke completion actions 114-- appropriately, use 'handleParseResult' instead. 115getParseResult :: ParserResult a -> Maybe a 116getParseResult (Success a) = Just a 117getParseResult _ = Nothing 118 119-- | The most general way to run a program description in pure code. 120execParserPure :: ParserPrefs -- ^ Global preferences for this parser 121 -> ParserInfo a -- ^ Description of the program to run 122 -> [String] -- ^ Program arguments 123 -> ParserResult a 124execParserPure pprefs pinfo args = 125 case runP p pprefs of 126 (Right (Right r), _) -> Success r 127 (Right (Left c), _) -> CompletionInvoked c 128 (Left err, ctx) -> Failure $ parserFailure pprefs pinfo err ctx 129 where 130 pinfo' = pinfo 131 { infoParser = (Left <$> bashCompletionParser pinfo pprefs) 132 <|> (Right <$> infoParser pinfo) } 133 p = runParserInfo pinfo' args 134 135-- | Generate a `ParserFailure` from a `ParseError` in a given `Context`. 136-- 137-- This function can be used, for example, to show the help text for a parser: 138-- 139-- @handleParseResult . Failure $ parserFailure pprefs pinfo ShowHelpText mempty@ 140parserFailure :: ParserPrefs -> ParserInfo a 141 -> ParseError -> [Context] 142 -> ParserFailure ParserHelp 143parserFailure pprefs pinfo msg ctx0 = ParserFailure $ \progn -> 144 let h = with_context ctx pinfo $ \names pinfo' -> mconcat 145 [ base_help pinfo' 146 , usage_help progn names pinfo' 147 , suggestion_help 148 , globals ctx 149 , error_help ] 150 in (h, exit_code, prefColumns pprefs) 151 where 152 -- 153 -- Add another context layer if the argument to --help is 154 -- a valid command. 155 ctx = case msg of 156 ShowHelpText (Just potentialCommand) -> 157 let ctx1 = with_context ctx0 pinfo $ \_ pinfo' -> 158 snd 159 $ flip runP defaultPrefs { prefBacktrack = SubparserInline } 160 $ runParserStep (infoPolicy pinfo') (infoParser pinfo') potentialCommand [] 161 in ctx1 `mappend` ctx0 162 _ -> 163 ctx0 164 165 exit_code = case msg of 166 ErrorMsg {} -> ExitFailure (infoFailureCode pinfo) 167 UnknownError -> ExitFailure (infoFailureCode pinfo) 168 MissingError {} -> ExitFailure (infoFailureCode pinfo) 169 ExpectsArgError {} -> ExitFailure (infoFailureCode pinfo) 170 UnexpectedError {} -> ExitFailure (infoFailureCode pinfo) 171 ShowHelpText {} -> ExitSuccess 172 InfoMsg {} -> ExitSuccess 173 174 with_context :: [Context] 175 -> ParserInfo a 176 -> (forall b . [String] -> ParserInfo b -> c) 177 -> c 178 with_context [] i f = f [] i 179 with_context c@(Context _ i:_) _ f = f (contextNames c) i 180 181 globals :: [Context] -> ParserHelp 182 globals cs = 183 let 184 voided = 185 fmap (\(Context _ p) -> void p) cs `mappend` pure (void pinfo) 186 187 globalParsers = 188 traverse_ infoParser $ 189 drop 1 voided 190 in 191 if prefHelpShowGlobal pprefs then 192 parserGlobals pprefs globalParsers 193 else 194 mempty 195 196 usage_help progn names i = case msg of 197 InfoMsg _ 198 -> mempty 199 _ 200 -> usageHelp $ vcatChunks 201 [ pure . parserUsage pprefs (infoParser i) . unwords $ progn : names 202 , fmap (indent 2) . infoProgDesc $ i ] 203 204 error_help = errorHelp $ case msg of 205 ShowHelpText {} 206 -> mempty 207 208 ErrorMsg m 209 -> stringChunk m 210 211 InfoMsg m 212 -> stringChunk m 213 214 MissingError CmdStart _ 215 | prefShowHelpOnEmpty pprefs 216 -> mempty 217 218 MissingError _ (SomeParser x) 219 -> stringChunk "Missing:" <<+>> missingDesc pprefs x 220 221 ExpectsArgError x 222 -> stringChunk $ "The option `" ++ x ++ "` expects an argument." 223 224 UnexpectedError arg _ 225 -> stringChunk msg' 226 where 227 -- 228 -- This gives us the same error we have always 229 -- reported 230 msg' = case arg of 231 ('-':_) -> "Invalid option `" ++ arg ++ "'" 232 _ -> "Invalid argument `" ++ arg ++ "'" 233 234 UnknownError 235 -> mempty 236 237 238 suggestion_help = suggestionsHelp $ case msg of 239 UnexpectedError arg (SomeParser x) 240 -- 241 -- We have an unexpected argument and the parser which 242 -- it's running over. 243 -- 244 -- We can make a good help suggestion here if we do 245 -- a levenstein distance between all possible suggestions 246 -- and the supplied option or argument. 247 -> suggestions 248 where 249 -- 250 -- Not using chunked here, as we don't want to 251 -- show "Did you mean" if there's nothing there 252 -- to show 253 suggestions = (.$.) <$> prose 254 <*> (indent 4 <$> (vcatChunks . fmap stringChunk $ good )) 255 256 -- 257 -- We won't worry about the 0 case, it won't be 258 -- shown anyway. 259 prose = if length good < 2 then 260 stringChunk "Did you mean this?" 261 else 262 stringChunk "Did you mean one of these?" 263 -- 264 -- Suggestions we will show, they're close enough 265 -- to what the user wrote 266 good = filter isClose possibles 267 268 -- 269 -- Bit of an arbitrary decision here. 270 -- Edit distances of 1 or 2 will give hints 271 isClose a = editDistance a arg < 3 272 273 -- 274 -- Similar to how bash completion works. 275 -- We map over the parser and get the names 276 -- ( no IO here though, unlike for completers ) 277 possibles = concat $ mapParser opt_completions x 278 279 -- 280 -- Look at the option and give back the possible 281 -- things the user could type. If it's a command 282 -- reader also ensure that it can be immediately 283 -- reachable from where the error was given. 284 opt_completions reachability opt = case optMain opt of 285 OptReader ns _ _ -> fmap showOption ns 286 FlagReader ns _ -> fmap showOption ns 287 ArgReader _ -> [] 288 CmdReader _ ns _ | argumentIsUnreachable reachability 289 -> [] 290 | otherwise 291 -> ns 292 _ 293 -> mempty 294 295 base_help :: ParserInfo a -> ParserHelp 296 base_help i 297 | show_full_help 298 = mconcat [h, f, parserHelp pprefs (infoParser i)] 299 | otherwise 300 = mempty 301 where 302 h = headerHelp (infoHeader i) 303 f = footerHelp (infoFooter i) 304 305 show_full_help = case msg of 306 ShowHelpText {} -> True 307 MissingError CmdStart _ | prefShowHelpOnEmpty pprefs 308 -> True 309 InfoMsg _ -> False 310 _ -> prefShowHelpOnError pprefs 311 312renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode) 313renderFailure failure progn = 314 let (h, exit, cols) = execFailure failure progn 315 in (renderHelp cols h, exit) 316