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