Merge branch 'error-handling'

Options/Applicative/BashCompletion.hs

@@ -41,10 +41,10 @@ bashCompletionQuery parser pprefs ws i _ = case runCompletion compl pprefs of
       . mapParser (\_ -> opt_completions)
 
     opt_completions opt = case optMain opt of
-      OptReader ns _  -> show_names ns
-      FlagReader ns _ -> show_names ns
-      ArgReader rdr   -> run_completer (crCompleter rdr)
-      CmdReader ns _  -> filter_names ns
+      OptReader ns _ _ -> show_names ns
+      FlagReader ns _  -> show_names ns
+      ArgReader rdr    -> run_completer (crCompleter rdr)
+      CmdReader ns _   -> filter_names ns
 
     show_name (OptShort c) = '-':[c]
     show_name (OptLong name) = "--" ++ name

Options/Applicative/Builder.hs

@@ -38,6 +38,8 @@ module Options.Applicative.Builder (
   showDefault,
   metavar,
   reader,
+  noArgError,
+  ParseError(..),
   hidden,
   internal,
   command,
@@ -83,18 +85,18 @@ import Options.Applicative.Types
 -- readers --
 
 -- | 'Option' reader based on the 'Read' type class.
-auto :: Read a => String -> Maybe a
+auto :: Monad m => Read a => String -> m a
 auto arg = case reads arg of
-  [(r, "")] -> Just r
-  _         -> Nothing
+  [(r, "")] -> return r
+  _         -> fail "Cannot parse value"
 
 -- | String 'Option' reader.
-str :: String -> Maybe String
-str = Just
+str :: Monad m => String -> m String
+str = return
 
 -- | Null 'Option' reader. All arguments will fail validation.
-disabled :: String -> Maybe a
-disabled = const Nothing
+disabled :: Monad m => String -> m a
+disabled = const . fail $ "Disabled option"
 
 -- modifiers --
 
@@ -123,9 +125,13 @@ help :: String -> Mod f a
 help s = optionMod $ \p -> p { propHelp = s }
 
 -- | Specify the 'Option' reader.
-reader :: (String -> Maybe a) -> Mod OptionFields a
+reader :: (String -> Either ParseError a) -> Mod OptionFields a
 reader f = fieldMod $ \p -> p { optReader = f }
 
+-- | Specify the error to display when no argument is provided to this option.
+noArgError :: ParseError -> Mod OptionFields a
+noArgError e = fieldMod $ \p -> p { optNoArgError = e }
+
 -- | Specify the metavariable.
 metavar :: String -> Mod f a
 metavar var = optionMod $ \p -> p { propMetaVar = var }
@@ -209,9 +215,9 @@ nullOption :: Mod OptionFields a -> Parser a
 nullOption m = mkParser d g rdr
   where
     Mod f d g = metavar "ARG" `mappend` m
-    fields = f (OptionFields [] mempty disabled)
+    fields = f (OptionFields [] mempty disabled (ErrorMsg ""))
     crdr = CReader (optCompleter fields) (optReader fields)
-    rdr = OptReader (optNames fields) crdr
+    rdr = OptReader (optNames fields) crdr (optNoArgError fields)
 
 -- | Builder for an option taking a 'String' argument.
 strOption :: Mod OptionFields String -> Parser String
@@ -283,7 +289,8 @@ prefs m = applyPrefsMod m base
   where
     base = ParserPrefs
       { prefMultiSuffix = ""
-      , prefDisambiguate = False }
+      , prefDisambiguate = False
+      , prefShowHelpOnError = False }
 
 -- convenience shortcuts
 

Options/Applicative/Builder/Internal.hs

@@ -30,7 +30,8 @@ import Options.Applicative.Types
 data OptionFields a = OptionFields
   { optNames :: [OptName]
   , optCompleter :: Completer
-  , optReader :: String -> Maybe a }
+  , optReader :: String -> Either ParseError a
+  , optNoArgError :: ParseError }
   deriving Functor
 
 data FlagFields a = FlagFields

Options/Applicative/Common.hs

@@ -54,7 +54,7 @@ import Options.Applicative.Internal
 import Options.Applicative.Types
 
 optionNames :: OptReader a -> [OptName]
-optionNames (OptReader names _) = names
+optionNames (OptReader names _ _) = names
 optionNames (FlagReader names _) = names
 optionNames _ = []
 
@@ -80,24 +80,29 @@ type Matcher m a = [String] -> m (a, [String])
 
 optMatches :: MonadP m => Bool -> OptReader a -> String -> Maybe (Matcher m a)
 optMatches disambiguate opt arg = case opt of
-  OptReader names rdr -> do
+  OptReader names rdr no_arg_err -> do
     (arg1, val) <- parsed
     guard $ has_name arg1 names
     return $ \args -> do
       let mb_args = uncons $ maybeToList val ++ args
-      (arg', args') <- maybe (missingArgP (crCompleter rdr)) return mb_args
-      r <- liftMaybe $ crReader rdr arg'
+      let missing_arg = missingArgP no_arg_err (crCompleter rdr)
+      (arg', args') <- maybe missing_arg return mb_args
+      r <- liftEither (crReader rdr arg')
       return (r, args')
   FlagReader names x -> do
     (arg1, Nothing) <- parsed
     guard $ has_name arg1 names
     return $ \args -> return (x, args)
-  ArgReader rdr ->
-    flip fmap (crReader rdr arg) $ \result args -> return (result, args)
+  ArgReader rdr -> do
+    result <- crReader rdr arg
+    return $ \args -> return (result, args)
   CmdReader _ f ->
     flip fmap (f arg) $ \subp args -> do
       setContext (Just arg) subp
-      runParser (infoParser subp) args
+      x <- tryP $ runParser (infoParser subp) args
+      case x of
+        Left e -> errorP e
+        Right r -> return r
   where
     parsed =
       case arg of
@@ -152,7 +157,9 @@ runParser p args = case args of
     prefs <- getPrefs
     x <- tryP $ do_step prefs arg argt
     case x of
-      Left e -> liftMaybe result <|> errorP e
+      Left e -> case (result, e) of
+        (Just r, ErrorMsg _) -> return r
+        _ -> errorP e
       Right (p', args') -> runParser p' args'
   where
     result = (,) <$> evalParser p <*> pure args
@@ -162,9 +169,18 @@ runParser p args = case args of
           [m] -> m
           _   -> empty
       | otherwise
-      = msum parses
+      = case parses of
+          [] -> parseError arg
+          (m : _) -> m
       where parses = stepParser prefs p arg argt
 
+parseError :: MonadP m => String -> m a
+parseError arg = errorP . ErrorMsg $ msg
+  where
+    msg = case arg of
+      ('-':_) -> "Invalid option `" ++ arg ++ "'"
+      _       -> "Invalid argument `" ++ arg ++ "'"
+
 runParserFully :: MonadP m => Parser a -> [String] -> m a
 runParserFully p args = do
   (r, args') <- runParser p args

Options/Applicative/Extra.hs

@@ -27,6 +27,8 @@ import System.IO
 helper :: Parser (a -> a)
 helper = nullOption
        ( long "help"
+       & reader (const (Left ShowHelpText))
+       & noArgError ShowHelpText
        & short 'h'
        & help "Show this help text"
        & value id
@@ -68,24 +70,50 @@ execParserPure pprefs pinfo args =
     (Right r, _) -> case r of
       Result a -> Right a
       Extra failure -> Left failure
-    (Left msg, ctx) -> Left ParserFailure
-      { errMessage = \progn
-          -> with_context ctx pinfo $ \names ->
-                 return
-               . parserHelpText pprefs
-               . add_error msg
-               . add_usage names progn
-      , errExitCode = ExitFailure (infoFailureCode pinfo) }
+    (Left msg, ctx) -> Left $
+      parserFailure pprefs pinfo msg ctx
   where
     parser = infoParser pinfo
+    parser' = (Extra <$> bashCompletionParser parser pprefs)
+          <|> (Result <$> parser)
+    p = runParserFully parser' args
+
+parserFailure :: ParserPrefs -> ParserInfo a
+              -> ParseError -> Context
+              -> ParserFailure
+parserFailure pprefs pinfo msg ctx = ParserFailure
+  { errMessage = \progn
+      -> with_context ctx pinfo $ \names ->
+             return
+           . show_help
+           . add_error
+           . add_usage names progn
+  , errExitCode = ExitFailure (infoFailureCode pinfo) }
+  where
     add_usage names progn i = i
       { infoHeader = vcat
-          [ infoHeader i
-          , usage pprefs (infoParser i) ename ] }
+          ( header_line i ++
+            [ usage pprefs (infoParser i) ename ] ) }
       where
         ename = unwords (progn : names)
-    add_error msg i = i
-      { infoHeader = vcat [msg, infoHeader i] }
+    add_error i = i
+      { infoHeader = vcat (error_msg ++ [infoHeader i]) }
+    error_msg = case msg of
+      ShowHelpText -> []
+      ErrorMsg m   -> [m]
+    show_full_help = case msg of
+      ShowHelpText -> True
+      _            -> prefShowHelpOnError pprefs
+    show_help i
+      | show_full_help
+      = parserHelpText pprefs i
+      | otherwise
+      = unlines $ filter (not . null) [ infoHeader i ]
+    header_line i
+      | show_full_help
+      = [ infoHeader i ]
+      | otherwise
+      = []
 
     with_context :: Context
                  -> ParserInfo a
@@ -94,10 +122,6 @@ execParserPure pprefs pinfo args =
     with_context NullContext i f = f [] i
     with_context (Context n i) _ f = f n i
 
-    parser' = (Extra <$> bashCompletionParser parser pprefs)
-          <|> (Result <$> parser)
-    p = runParserFully parser' args
-
 -- | Generate option summary.
 usage :: ParserPrefs -> Parser a -> String -> String
 usage pprefs p progn = foldr (<+>) ""

Options/Applicative/Internal.hs

@@ -3,9 +3,11 @@ module Options.Applicative.Internal
   ( P
   , Context(..)
   , MonadP(..)
+  , ParseError(..)
 
   , uncons
   , liftMaybe
+  , liftEither
 
   , runP
 
@@ -31,12 +33,12 @@ class (Alternative m, MonadPlus m) => MonadP m where
   setParser :: Maybe String -> Parser a -> m ()
   getPrefs :: m ParserPrefs
 
-  missingArgP :: Completer -> m a
-  tryP :: m a -> m (Either String a)
-  errorP :: String -> m a
+  missingArgP :: ParseError -> Completer -> m a
+  tryP :: m a -> m (Either ParseError a)
+  errorP :: ParseError -> m a
   exitP :: Parser b -> Maybe a -> m a
 
-newtype P a = P (ErrorT String (WriterT Context (Reader ParserPrefs)) a)
+newtype P a = P (ErrorT ParseError (WriterT Context (Reader ParserPrefs)) a)
 
 instance Functor P where
   fmap f (P m) = P $ fmap f m
@@ -76,15 +78,18 @@ instance MonadP P where
   setParser _ _ = return ()
   getPrefs = P . lift . lift $ ask
 
-  missingArgP _ = P empty
+  missingArgP e _ = errorP e
   tryP (P p) = P $ lift $ runErrorT p
   exitP _ = P . liftMaybe
   errorP = P . throwError
 
 liftMaybe :: MonadPlus m => Maybe a -> m a
 liftMaybe = maybe mzero return
 
-runP :: P a -> ParserPrefs -> (Either String a, Context)
+liftEither :: MonadP m => Either ParseError a -> m a
+liftEither = either errorP return
+
+runP :: P a -> ParserPrefs -> (Either ParseError a, Context)
 runP (P p) = runReader . runWriterT . runErrorT $ p
 
 uncons :: [a] -> Maybe (a, [a])
@@ -121,7 +126,7 @@ instance Monad ComplResult where
     ComplOption c -> ComplOption c
 
 newtype Completion a =
-  Completion (ErrorT String (ReaderT ParserPrefs ComplResult) a)
+  Completion (ErrorT ParseError (ReaderT ParserPrefs ComplResult) a)
 
 instance Functor Completion where
   fmap f (Completion m) = Completion $ fmap f m
@@ -147,7 +152,7 @@ instance MonadP Completion where
   setParser _ _ = return ()
   getPrefs = Completion $ lift ask
 
-  missingArgP = Completion . lift . lift . ComplOption
+  missingArgP _ = Completion . lift . lift . ComplOption
   tryP (Completion p) = Completion $ catchError (Right <$> p) (return . Left)
   exitP p _ = Completion . lift . lift . ComplParser $ SomeParser p
   errorP = Completion . throwError

Options/Applicative/Types.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE GADTs, DeriveFunctor, Rank2Types #-}
 module Options.Applicative.Types (
+  ParseError(..),
   ParserInfo(..),
   ParserPrefs(..),
 
@@ -33,6 +34,14 @@ import Control.Monad.Trans.Error
 import Data.Monoid
 import System.Exit
 
+data ParseError
+  = ErrorMsg String
+  | ShowHelpText
+  deriving Show
+
+instance Error ParseError where
+  strMsg = ErrorMsg
+
 -- | A full description for a runnable 'Parser' for a program.
 data ParserInfo a = ParserInfo
   { infoParser :: Parser a            -- ^ the option parser for the program
@@ -47,6 +56,7 @@ data ParserInfo a = ParserInfo
 data ParserPrefs = ParserPrefs
   { prefMultiSuffix :: String    -- ^ metavar suffix for multiple options
   , prefDisambiguate :: Bool     -- ^ automatically disambiguate abbreviations
+  , prefShowHelpOnError :: Bool  -- ^ always show help text on parse errors
   }
 
 data OptName = OptShort !Char
@@ -74,16 +84,19 @@ data Option a = Option
   , optProps :: OptProperties            -- ^ properties of this option
   } deriving Functor
 
-data CReader a = CReader
+data CReader m a = CReader
   { crCompleter :: Completer
-  , crReader :: String -> Maybe a }
+  , crReader :: String -> m a }
   deriving Functor
 
+type OptCReader = CReader (Either ParseError)
+type ArgCReader = CReader Maybe
+
 -- | An 'OptReader' defines whether an option matches an command line argument.
 data OptReader a
-  = OptReader [OptName] (CReader a)                     -- ^ option reader
+  = OptReader [OptName] (OptCReader a) ParseError       -- ^ option reader
   | FlagReader [OptName] !a                             -- ^ flag reader
-  | ArgReader (CReader a)                               -- ^ argument reader
+  | ArgReader (ArgCReader a)                            -- ^ argument reader
   | CmdReader [String] (String -> Maybe (ParserInfo a)) -- ^ command reader
   deriving Functor