{-# LANGUAGE RankNTypes #-}
module Options.Applicative.Extra (
  -- * Extra parser utilities
  --
  -- | This module contains high-level functions to run parsers.
  helper,
  helperWith,
  hsubparser,
  execParser,
  customExecParser,
  execParserPure,
  getParseResult,
  handleParseResult,
  parserFailure,
  renderFailure,
  ParserFailure(..),
  overFailure,
  ParserResult(..),
  ParserPrefs(..),
  CompletionResult(..),
  ) where

import Control.Applicative
import Control.Monad (void)
import Data.Monoid
import Data.Foldable (traverse_)
import Prelude
import System.Environment (getArgs, getProgName)
import System.Exit (exitSuccess, exitWith, ExitCode(..))
import System.IO (hPutStrLn, stderr)

import Options.Applicative.BashCompletion
import Options.Applicative.Builder
import Options.Applicative.Builder.Internal
import Options.Applicative.Common
import Options.Applicative.Help

import Options.Applicative.Internal
import Options.Applicative.Types

-- | A hidden \"helper\" option which always fails.
--
-- A common usage pattern is to apply this applicatively when
-- creating a 'ParserInfo'
--
-- > opts :: ParserInfo Sample
-- > opts = info (sample <**> helper) mempty

helper :: Parser (a -> a)
helper :: Parser (a -> a)
helper =
  Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. Mod OptionFields (a -> a) -> Parser (a -> a)
helperWith ([Mod OptionFields (a -> a)] -> Mod OptionFields (a -> a)
forall a. Monoid a => [a] -> a
mconcat [
    String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"help",
    Char -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'h',
    String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. String -> Mod f a
help String
"Show this help text"
  ])

-- | Like helper, but with a minimal set of modifiers that can be extended
-- as desired.
--
-- > opts :: ParserInfo Sample
-- > opts = info (sample <**> helperWith (mconcat [
-- >          long "help",
-- >          short 'h',
-- >          help "Show this help text",
-- >          hidden
-- >        ])) mempty
helperWith :: Mod OptionFields (a -> a) -> Parser (a -> a)
helperWith :: Mod OptionFields (a -> a) -> Parser (a -> a)
helperWith Mod OptionFields (a -> a)
modifiers =
  ReadM (a -> a) -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM (a -> a)
forall b. ReadM b
helpReader (Mod OptionFields (a -> a) -> Parser (a -> a))
-> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$
    [Mod OptionFields (a -> a)] -> Mod OptionFields (a -> a)
forall a. Monoid a => [a] -> a
mconcat
      [ (a -> a) -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value a -> a
forall a. a -> a
id,
        String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"",
        Mod OptionFields (a -> a)
forall (f :: * -> *) a. Mod f a
noGlobal,
        ParseError -> Mod OptionFields (a -> a)
forall a. ParseError -> Mod OptionFields a
noArgError (Maybe String -> ParseError
ShowHelpText Maybe String
forall a. Maybe a
Nothing),
        Mod OptionFields (a -> a)
forall (f :: * -> *) a. Mod f a
hidden,
        Mod OptionFields (a -> a)
modifiers
      ]
  where
    helpReader :: ReadM b
helpReader = do
      String
potentialCommand <- ReadM String
readerAsk
      ParseError -> ReadM b
forall a. ParseError -> ReadM a
readerAbort (ParseError -> ReadM b) -> ParseError -> ReadM b
forall a b. (a -> b) -> a -> b
$
        Maybe String -> ParseError
ShowHelpText (String -> Maybe String
forall a. a -> Maybe a
Just String
potentialCommand)

-- | Builder for a command parser with a \"helper\" option attached.
-- Used in the same way as `subparser`, but includes a \"--help|-h\" inside
-- the subcommand.
hsubparser :: Mod CommandFields a -> Parser a
hsubparser :: Mod CommandFields a -> Parser a
hsubparser Mod CommandFields a
m = DefaultProp a
-> (OptProperties -> OptProperties) -> OptReader a -> Parser a
forall a.
DefaultProp a
-> (OptProperties -> OptProperties) -> OptReader a -> Parser a
mkParser DefaultProp a
d OptProperties -> OptProperties
g OptReader a
rdr
  where
    Mod CommandFields a -> CommandFields a
_ DefaultProp a
d OptProperties -> OptProperties
g = String -> Mod CommandFields a
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"COMMAND" Mod CommandFields a -> Mod CommandFields a -> Mod CommandFields a
forall a. Monoid a => a -> a -> a
`mappend` Mod CommandFields a
m
    (Maybe String
groupName, [String]
cmds, String -> Maybe (ParserInfo a)
subs) = Mod CommandFields a
-> (Maybe String, [String], String -> Maybe (ParserInfo a))
forall a.
Mod CommandFields a
-> (Maybe String, [String], String -> Maybe (ParserInfo a))
mkCommand Mod CommandFields a
m
    rdr :: OptReader a
rdr = Maybe String
-> [String] -> (String -> Maybe (ParserInfo a)) -> OptReader a
forall a.
Maybe String
-> [String] -> (String -> Maybe (ParserInfo a)) -> OptReader a
CmdReader Maybe String
groupName [String]
cmds ((ParserInfo a -> ParserInfo a)
-> Maybe (ParserInfo a) -> Maybe (ParserInfo a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParserInfo a -> ParserInfo a
forall a. ParserInfo a -> ParserInfo a
add_helper (Maybe (ParserInfo a) -> Maybe (ParserInfo a))
-> (String -> Maybe (ParserInfo a))
-> String
-> Maybe (ParserInfo a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (ParserInfo a)
subs)
    add_helper :: ParserInfo a -> ParserInfo a
add_helper ParserInfo a
pinfo = ParserInfo a
pinfo
      { infoParser :: Parser a
infoParser = ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
pinfo Parser a -> Parser (a -> a) -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (a -> a)
forall a. Parser (a -> a)
helper }

-- | Run a program description.
--
-- Parse command line arguments. Display help text and exit if any parse error
-- occurs.
execParser :: ParserInfo a -> IO a
execParser :: ParserInfo a -> IO a
execParser = ParserPrefs -> ParserInfo a -> IO a
forall a. ParserPrefs -> ParserInfo a -> IO a
customExecParser ParserPrefs
defaultPrefs

-- | Run a program description with custom preferences.
customExecParser :: ParserPrefs -> ParserInfo a -> IO a
customExecParser :: ParserPrefs -> ParserInfo a -> IO a
customExecParser ParserPrefs
pprefs ParserInfo a
pinfo
  = ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure ParserPrefs
pprefs ParserInfo a
pinfo ([String] -> ParserResult a) -> IO [String] -> IO (ParserResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
getArgs
  IO (ParserResult a) -> (ParserResult a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParserResult a -> IO a
forall a. ParserResult a -> IO a
handleParseResult

-- | Handle `ParserResult`.
handleParseResult :: ParserResult a -> IO a
handleParseResult :: ParserResult a -> IO a
handleParseResult (Success a
a) = a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
handleParseResult (Failure ParserFailure ParserHelp
failure) = do
      String
progn <- IO String
getProgName
      let (String
msg, ExitCode
exit) = ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure ParserFailure ParserHelp
failure String
progn
      case ExitCode
exit of
        ExitCode
ExitSuccess -> String -> IO ()
putStrLn String
msg
        ExitCode
_           -> Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
      ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith ExitCode
exit
handleParseResult (CompletionInvoked CompletionResult
compl) = do
      String
progn <- IO String
getProgName
      String
msg <- CompletionResult -> String -> IO String
execCompletion CompletionResult
compl String
progn
      String -> IO ()
putStr String
msg
      IO a
forall a. IO a
exitSuccess

-- | Extract the actual result from a `ParserResult` value.
--
-- This function returns 'Nothing' in case of errors.  Possible error messages
-- or completion actions are simply discarded.
--
-- If you want to display error messages and invoke completion actions
-- appropriately, use 'handleParseResult' instead.
getParseResult :: ParserResult a -> Maybe a
getParseResult :: ParserResult a -> Maybe a
getParseResult (Success a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
getParseResult ParserResult a
_ = Maybe a
forall a. Maybe a
Nothing

-- | The most general way to run a program description in pure code.
execParserPure :: ParserPrefs       -- ^ Global preferences for this parser
               -> ParserInfo a      -- ^ Description of the program to run
               -> [String]          -- ^ Program arguments
               -> ParserResult a
execParserPure :: ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure ParserPrefs
pprefs ParserInfo a
pinfo [String]
args =
  case P (Either CompletionResult a)
-> ParserPrefs
-> (Either ParseError (Either CompletionResult a), [Context])
forall a. P a -> ParserPrefs -> (Either ParseError a, [Context])
runP P (Either CompletionResult a)
p ParserPrefs
pprefs of
    (Right (Right a
r), [Context]
_) -> a -> ParserResult a
forall a. a -> ParserResult a
Success a
r
    (Right (Left CompletionResult
c), [Context]
_) -> CompletionResult -> ParserResult a
forall a. CompletionResult -> ParserResult a
CompletionInvoked CompletionResult
c
    (Left ParseError
err, [Context]
ctx) -> ParserFailure ParserHelp -> ParserResult a
forall a. ParserFailure ParserHelp -> ParserResult a
Failure (ParserFailure ParserHelp -> ParserResult a)
-> ParserFailure ParserHelp -> ParserResult a
forall a b. (a -> b) -> a -> b
$ ParserPrefs
-> ParserInfo a
-> ParseError
-> [Context]
-> ParserFailure ParserHelp
forall a.
ParserPrefs
-> ParserInfo a
-> ParseError
-> [Context]
-> ParserFailure ParserHelp
parserFailure ParserPrefs
pprefs ParserInfo a
pinfo ParseError
err [Context]
ctx
  where
    pinfo' :: ParserInfo (Either CompletionResult a)
pinfo' = ParserInfo a
pinfo
      { infoParser :: Parser (Either CompletionResult a)
infoParser = (CompletionResult -> Either CompletionResult a
forall a b. a -> Either a b
Left (CompletionResult -> Either CompletionResult a)
-> Parser CompletionResult -> Parser (Either CompletionResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserInfo a -> ParserPrefs -> Parser CompletionResult
forall a. ParserInfo a -> ParserPrefs -> Parser CompletionResult
bashCompletionParser ParserInfo a
pinfo ParserPrefs
pprefs)
                 Parser (Either CompletionResult a)
-> Parser (Either CompletionResult a)
-> Parser (Either CompletionResult a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> Either CompletionResult a
forall a b. b -> Either a b
Right (a -> Either CompletionResult a)
-> Parser a -> Parser (Either CompletionResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
pinfo) }
    p :: P (Either CompletionResult a)
p = ParserInfo (Either CompletionResult a)
-> [String] -> P (Either CompletionResult a)
forall (m :: * -> *) a. MonadP m => ParserInfo a -> [String] -> m a
runParserInfo ParserInfo (Either CompletionResult a)
pinfo' [String]
args

-- | Generate a `ParserFailure` from a `ParseError` in a given `Context`.
--
-- This function can be used, for example, to show the help text for a parser:
--
-- @handleParseResult . Failure $ parserFailure pprefs pinfo ShowHelpText mempty@
parserFailure :: ParserPrefs -> ParserInfo a
              -> ParseError -> [Context]
              -> ParserFailure ParserHelp
parserFailure :: ParserPrefs
-> ParserInfo a
-> ParseError
-> [Context]
-> ParserFailure ParserHelp
parserFailure ParserPrefs
pprefs ParserInfo a
pinfo ParseError
msg [Context]
ctx0 = (String -> (ParserHelp, ExitCode, Int)) -> ParserFailure ParserHelp
forall h. (String -> (h, ExitCode, Int)) -> ParserFailure h
ParserFailure ((String -> (ParserHelp, ExitCode, Int))
 -> ParserFailure ParserHelp)
-> (String -> (ParserHelp, ExitCode, Int))
-> ParserFailure ParserHelp
forall a b. (a -> b) -> a -> b
$ \String
progn ->
  let h :: ParserHelp
h = [Context]
-> ParserInfo a
-> (forall b. [String] -> ParserInfo b -> ParserHelp)
-> ParserHelp
forall a c.
[Context]
-> ParserInfo a -> (forall b. [String] -> ParserInfo b -> c) -> c
with_context [Context]
ctx ParserInfo a
pinfo ((forall b. [String] -> ParserInfo b -> ParserHelp) -> ParserHelp)
-> (forall b. [String] -> ParserInfo b -> ParserHelp) -> ParserHelp
forall a b. (a -> b) -> a -> b
$ \[String]
names ParserInfo b
pinfo' -> [ParserHelp] -> ParserHelp
forall a. Monoid a => [a] -> a
mconcat
            [ ParserInfo b -> ParserHelp
forall a. ParserInfo a -> ParserHelp
base_help ParserInfo b
pinfo'
            , String -> [String] -> ParserInfo b -> ParserHelp
forall a. String -> [String] -> ParserInfo a -> ParserHelp
usage_help String
progn [String]
names ParserInfo b
pinfo'
            , ParserHelp
suggestion_help
            , [Context] -> ParserHelp
globals [Context]
ctx
            , ParserHelp
error_help ]
  in (ParserHelp
h, ExitCode
exit_code, ParserPrefs -> Int
prefColumns ParserPrefs
pprefs)
  where
    --
    -- Add another context layer if the argument to --help is
    -- a valid command.
    ctx :: [Context]
ctx = case ParseError
msg of
      ShowHelpText (Just String
potentialCommand) ->
        let ctx1 :: [Context]
ctx1 = [Context]
-> ParserInfo a
-> (forall b. [String] -> ParserInfo b -> [Context])
-> [Context]
forall a c.
[Context]
-> ParserInfo a -> (forall b. [String] -> ParserInfo b -> c) -> c
with_context [Context]
ctx0 ParserInfo a
pinfo ((forall b. [String] -> ParserInfo b -> [Context]) -> [Context])
-> (forall b. [String] -> ParserInfo b -> [Context]) -> [Context]
forall a b. (a -> b) -> a -> b
$ \[String]
_ ParserInfo b
pinfo' ->
              (Either ParseError (Maybe (Parser b), [String]), [Context])
-> [Context]
forall a b. (a, b) -> b
snd
                ((Either ParseError (Maybe (Parser b), [String]), [Context])
 -> [Context])
-> (Either ParseError (Maybe (Parser b), [String]), [Context])
-> [Context]
forall a b. (a -> b) -> a -> b
$ (P (Maybe (Parser b), [String])
 -> ParserPrefs
 -> (Either ParseError (Maybe (Parser b), [String]), [Context]))
-> ParserPrefs
-> P (Maybe (Parser b), [String])
-> (Either ParseError (Maybe (Parser b), [String]), [Context])
forall a b c. (a -> b -> c) -> b -> a -> c
flip P (Maybe (Parser b), [String])
-> ParserPrefs
-> (Either ParseError (Maybe (Parser b), [String]), [Context])
forall a. P a -> ParserPrefs -> (Either ParseError a, [Context])
runP ParserPrefs
defaultPrefs { prefBacktrack :: Backtracking
prefBacktrack = Backtracking
SubparserInline }
                (P (Maybe (Parser b), [String])
 -> (Either ParseError (Maybe (Parser b), [String]), [Context]))
-> P (Maybe (Parser b), [String])
-> (Either ParseError (Maybe (Parser b), [String]), [Context])
forall a b. (a -> b) -> a -> b
$ ArgPolicy
-> Parser b -> String -> [String] -> P (Maybe (Parser b), [String])
forall (m :: * -> *) a.
MonadP m =>
ArgPolicy
-> Parser a -> String -> [String] -> m (Maybe (Parser a), [String])
runParserStep (ParserInfo b -> ArgPolicy
forall a. ParserInfo a -> ArgPolicy
infoPolicy ParserInfo b
pinfo') (ParserInfo b -> Parser b
forall a. ParserInfo a -> Parser a
infoParser ParserInfo b
pinfo') String
potentialCommand []
        in [Context]
ctx1 [Context] -> [Context] -> [Context]
forall a. Monoid a => a -> a -> a
`mappend` [Context]
ctx0
      ParseError
_ ->
        [Context]
ctx0

    exit_code :: ExitCode
exit_code = case ParseError
msg of
      ErrorMsg {}        -> Int -> ExitCode
ExitFailure (ParserInfo a -> Int
forall a. ParserInfo a -> Int
infoFailureCode ParserInfo a
pinfo)
      ParseError
UnknownError       -> Int -> ExitCode
ExitFailure (ParserInfo a -> Int
forall a. ParserInfo a -> Int
infoFailureCode ParserInfo a
pinfo)
      MissingError {}    -> Int -> ExitCode
ExitFailure (ParserInfo a -> Int
forall a. ParserInfo a -> Int
infoFailureCode ParserInfo a
pinfo)
      ExpectsArgError {} -> Int -> ExitCode
ExitFailure (ParserInfo a -> Int
forall a. ParserInfo a -> Int
infoFailureCode ParserInfo a
pinfo)
      UnexpectedError {} -> Int -> ExitCode
ExitFailure (ParserInfo a -> Int
forall a. ParserInfo a -> Int
infoFailureCode ParserInfo a
pinfo)
      ShowHelpText {}    -> ExitCode
ExitSuccess
      InfoMsg {}         -> ExitCode
ExitSuccess

    with_context :: [Context]
                 -> ParserInfo a
                 -> (forall b . [String] -> ParserInfo b -> c)
                 -> c
    with_context :: [Context]
-> ParserInfo a -> (forall b. [String] -> ParserInfo b -> c) -> c
with_context [] ParserInfo a
i forall b. [String] -> ParserInfo b -> c
f = [String] -> ParserInfo a -> c
forall b. [String] -> ParserInfo b -> c
f [] ParserInfo a
i
    with_context c :: [Context]
c@(Context String
_ ParserInfo a
i:[Context]
_) ParserInfo a
_ forall b. [String] -> ParserInfo b -> c
f = [String] -> ParserInfo a -> c
forall b. [String] -> ParserInfo b -> c
f ([Context] -> [String]
contextNames [Context]
c) ParserInfo a
i

    globals :: [Context] -> ParserHelp
    globals :: [Context] -> ParserHelp
globals [Context]
cs =
      let
        voided :: [ParserInfo ()]
voided =
          (Context -> ParserInfo ()) -> [Context] -> [ParserInfo ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Context String
_ ParserInfo a
p) -> ParserInfo a -> ParserInfo ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParserInfo a
p) [Context]
cs [ParserInfo ()] -> [ParserInfo ()] -> [ParserInfo ()]
forall a. Monoid a => a -> a -> a
`mappend` ParserInfo () -> [ParserInfo ()]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParserInfo a -> ParserInfo ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParserInfo a
pinfo)

        globalParsers :: Parser ()
globalParsers =
          (ParserInfo () -> Parser ()) -> [ParserInfo ()] -> Parser ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ParserInfo () -> Parser ()
forall a. ParserInfo a -> Parser a
infoParser ([ParserInfo ()] -> Parser ()) -> [ParserInfo ()] -> Parser ()
forall a b. (a -> b) -> a -> b
$
            Int -> [ParserInfo ()] -> [ParserInfo ()]
forall a. Int -> [a] -> [a]
drop Int
1 [ParserInfo ()]
voided
      in
        if ParserPrefs -> Bool
prefHelpShowGlobal ParserPrefs
pprefs then
          ParserPrefs -> Parser () -> ParserHelp
forall a. ParserPrefs -> Parser a -> ParserHelp
parserGlobals ParserPrefs
pprefs Parser ()
globalParsers
        else
          ParserHelp
forall a. Monoid a => a
mempty

    usage_help :: String -> [String] -> ParserInfo a -> ParserHelp
usage_help String
progn [String]
names ParserInfo a
i = case ParseError
msg of
      InfoMsg String
_
        -> ParserHelp
forall a. Monoid a => a
mempty
      ParseError
_
        -> [ParserHelp] -> ParserHelp
forall a. Monoid a => [a] -> a
mconcat [
            Chunk Doc -> ParserHelp
usageHelp (Doc -> Chunk Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Chunk Doc) -> ([String] -> Doc) -> [String] -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserPrefs -> Parser a -> String -> Doc
forall a. ParserPrefs -> Parser a -> String -> Doc
parserUsage ParserPrefs
pprefs (ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
i) (String -> Doc) -> ([String] -> String) -> [String] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> Chunk Doc) -> [String] -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ String
progn String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
names)
          , Chunk Doc -> ParserHelp
descriptionHelp (ParserInfo a -> Chunk Doc
forall a. ParserInfo a -> Chunk Doc
infoProgDesc ParserInfo a
i)
          ]

    error_help :: ParserHelp
error_help = Chunk Doc -> ParserHelp
errorHelp (Chunk Doc -> ParserHelp) -> Chunk Doc -> ParserHelp
forall a b. (a -> b) -> a -> b
$ case ParseError
msg of
      ShowHelpText {}
        -> Chunk Doc
forall a. Monoid a => a
mempty

      ErrorMsg String
m
        -> String -> Chunk Doc
stringChunk String
m

      InfoMsg  String
m
        -> String -> Chunk Doc
stringChunk String
m

      MissingError IsCmdStart
CmdStart SomeParser
_
        | ParserPrefs -> Bool
prefShowHelpOnEmpty ParserPrefs
pprefs
        -> Chunk Doc
forall a. Monoid a => a
mempty

      MissingError IsCmdStart
_ (SomeParser Parser a
x)
        -> String -> Chunk Doc
stringChunk String
"Missing:" Chunk Doc -> Chunk Doc -> Chunk Doc
<<+>> ParserPrefs -> Parser a -> Chunk Doc
forall a. ParserPrefs -> Parser a -> Chunk Doc
missingDesc ParserPrefs
pprefs Parser a
x

      ExpectsArgError String
x
        -> String -> Chunk Doc
stringChunk (String -> Chunk Doc) -> String -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ String
"The option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` expects an argument."

      UnexpectedError String
arg SomeParser
_
        -> String -> Chunk Doc
stringChunk String
msg'
          where
            --
            -- This gives us the same error we have always
            -- reported
            msg' :: String
msg' = case String
arg of
              (Char
'-':String
_) -> String
"Invalid option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
              String
_       -> String
"Invalid argument `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"

      ParseError
UnknownError
        -> Chunk Doc
forall a. Monoid a => a
mempty


    suggestion_help :: ParserHelp
suggestion_help = Chunk Doc -> ParserHelp
suggestionsHelp (Chunk Doc -> ParserHelp) -> Chunk Doc -> ParserHelp
forall a b. (a -> b) -> a -> b
$ case ParseError
msg of
      UnexpectedError String
arg (SomeParser Parser a
x)
        --
        -- We have an unexpected argument and the parser which
        -- it's running over.
        --
        -- We can make a good help suggestion here if we do
        -- a levenstein distance between all possible suggestions
        -- and the supplied option or argument.
        -> Chunk Doc
suggestions
          where
            --
            -- Not using chunked here, as we don't want to
            -- show "Did you mean" if there's nothing there
            -- to show
            suggestions :: Chunk Doc
suggestions = Doc -> Doc -> Doc
(.$.) (Doc -> Doc -> Doc) -> Chunk Doc -> Chunk (Doc -> Doc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chunk Doc
prose
                                Chunk (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Doc -> Doc
indent Int
4 (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Chunk Doc] -> Chunk Doc
vcatChunks ([Chunk Doc] -> Chunk Doc)
-> ([String] -> [Chunk Doc]) -> [String] -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Chunk Doc) -> [String] -> [Chunk Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Chunk Doc
stringChunk ([String] -> Chunk Doc) -> [String] -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ [String]
good ))

            --
            -- We won't worry about the 0 case, it won't be
            -- shown anyway.
            prose :: Chunk Doc
prose       = if [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
good Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then
                            String -> Chunk Doc
stringChunk String
"Did you mean this?"
                          else
                            String -> Chunk Doc
stringChunk String
"Did you mean one of these?"
            --
            -- Suggestions we will show, they're close enough
            -- to what the user wrote
            good :: [String]
good        = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isClose [String]
possibles

            --
            -- Bit of an arbitrary decision here.
            -- Edit distances of 1 or 2 will give hints
            isClose :: String -> Bool
isClose String
a   = String -> String -> Int
forall a. Eq a => [a] -> [a] -> Int
editDistance String
a String
arg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3

            --
            -- Similar to how bash completion works.
            -- We map over the parser and get the names
            -- ( no IO here though, unlike for completers )
            possibles :: [String]
possibles   = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (forall x. ArgumentReachability -> Option x -> [String])
-> Parser a -> [[String]]
forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> [b]
mapParser forall x. ArgumentReachability -> Option x -> [String]
opt_completions Parser a
x

            --
            -- Look at the option and give back the possible
            -- things the user could type. If it's a command
            -- reader also ensure that it can be immediately
            -- reachable from where the error was given.
            opt_completions :: ArgumentReachability -> Option a -> [String]
opt_completions ArgumentReachability
reachability Option a
opt = case Option a -> OptReader a
forall a. Option a -> OptReader a
optMain Option a
opt of
              OptReader [OptName]
ns CReader a
_ String -> ParseError
_ -> (OptName -> String) -> [OptName] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OptName -> String
showOption [OptName]
ns
              FlagReader [OptName]
ns a
_  -> (OptName -> String) -> [OptName] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OptName -> String
showOption [OptName]
ns
              ArgReader CReader a
_      -> []
              CmdReader Maybe String
_ [String]
ns String -> Maybe (ParserInfo a)
_  | ArgumentReachability -> Bool
argumentIsUnreachable ArgumentReachability
reachability
                               -> []
                                | Bool
otherwise
                               -> [String]
ns
      ParseError
_
        -> Chunk Doc
forall a. Monoid a => a
mempty

    base_help :: ParserInfo a -> ParserHelp
    base_help :: ParserInfo a -> ParserHelp
base_help ParserInfo a
i
      | Bool
show_full_help
      = [ParserHelp] -> ParserHelp
forall a. Monoid a => [a] -> a
mconcat [ParserHelp
h, ParserHelp
f, ParserPrefs -> Parser a -> ParserHelp
forall a. ParserPrefs -> Parser a -> ParserHelp
parserHelp ParserPrefs
pprefs (ParserInfo a -> Parser a
forall a. ParserInfo a -> Parser a
infoParser ParserInfo a
i)]
      | Bool
otherwise
      = ParserHelp
forall a. Monoid a => a
mempty
      where
        h :: ParserHelp
h = Chunk Doc -> ParserHelp
headerHelp (ParserInfo a -> Chunk Doc
forall a. ParserInfo a -> Chunk Doc
infoHeader ParserInfo a
i)
        f :: ParserHelp
f = Chunk Doc -> ParserHelp
footerHelp (ParserInfo a -> Chunk Doc
forall a. ParserInfo a -> Chunk Doc
infoFooter ParserInfo a
i)

    show_full_help :: Bool
show_full_help = case ParseError
msg of
      ShowHelpText {}          -> Bool
True
      MissingError IsCmdStart
CmdStart  SomeParser
_  | ParserPrefs -> Bool
prefShowHelpOnEmpty ParserPrefs
pprefs
                               -> Bool
True
      InfoMsg String
_                -> Bool
False
      ParseError
_                        -> ParserPrefs -> Bool
prefShowHelpOnError ParserPrefs
pprefs

renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure ParserFailure ParserHelp
failure String
progn =
  let (ParserHelp
h, ExitCode
exit, Int
cols) = ParserFailure ParserHelp -> String -> (ParserHelp, ExitCode, Int)
forall h. ParserFailure h -> String -> (h, ExitCode, Int)
execFailure ParserFailure ParserHelp
failure String
progn
  in (Int -> ParserHelp -> String
renderHelp Int
cols ParserHelp
h, ExitCode
exit)