Handle option argument parse errors without 'error'

This inlines the rest of System.Console.GetOpt, since ArgDesc
and OptDesc changed.

Distribution.ReadE.readEOrFail is no more.

Cabal/src/Distribution/GetOpt.hs

@@ -17,6 +17,8 @@
 -- * Line wrapping in the 'usageInfo' output, plus a more compact
 --   rendering of short options, and slightly less padding.
 --
+-- * Parsing of option arguments is allowed to fail.
+--
 -- If you want to take on the challenge of merging this with the GetOpt
 -- from the base package then go for it!
 --
@@ -36,8 +38,35 @@ module Distribution.GetOpt (
 
 import Prelude ()
 import Distribution.Compat.Prelude
-import System.Console.GetOpt
-         ( ArgOrder(..), OptDescr(..), ArgDescr(..) )
+
+-- | What to do with options following non-options
+data ArgOrder a
+  = RequireOrder                -- ^ no option processing after first non-option
+  | Permute                     -- ^ freely intersperse options and non-options
+  | ReturnInOrder (String -> a) -- ^ wrap non-options into options
+
+data OptDescr a =              -- description of a single options:
+   Option [Char]                --    list of short option characters
+          [String]              --    list of long option strings (without "--")
+          (ArgDescr a)          --    argument descriptor
+          String                --    explanation of option for user
+
+instance Functor OptDescr where
+    fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c
+
+-- | Describes whether an option takes an argument or not, and if so
+-- how the argument is parsed to a value of type @a@.
+--
+-- Compared to System.Console.GetOpt, we allow for parse errors.
+data ArgDescr a
+   = NoArg                   a                       -- ^   no argument expected
+   | ReqArg (String       -> Either String a) String -- ^   option requires argument
+   | OptArg (Maybe String -> Either String a) String -- ^   optional argument
+
+instance Functor ArgDescr where
+    fmap f (NoArg a)    = NoArg (f a)
+    fmap f (ReqArg g s) = ReqArg (fmap f . g) s
+    fmap f (OptArg g s) = OptArg (fmap f . g) s
 
 data OptKind a                -- kind of cmd line arg (internal use only):
    = Opt       a                --    an option
@@ -181,15 +210,16 @@ longOpt ls rs optDescr = long ads arg rs
          options   = if null exact then getWith isPrefixOf else exact
          ads       = [ ad | Option _ _ ad _ <- options ]
          optStr    = "--" ++ opt
+         fromRes   = fromParseResult optStr
 
          long (_:_:_)      _        rest     = (errAmbig options optStr,rest)
          long [NoArg  a  ] []       rest     = (Opt a,rest)
          long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)
          long [ReqArg _ d] []       []       = (errReq d optStr,[])
-         long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)
-         long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)
-         long [OptArg f _] []       rest     = (Opt (f Nothing),rest)
-         long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)
+         long [ReqArg f _] []       (r:rest) = (fromRes (f r),rest)
+         long [ReqArg f _] ('=':xs) rest     = (fromRes (f xs),rest)
+         long [OptArg f _] []       rest     = (fromRes (f Nothing),rest)
+         long [OptArg f _] ('=':xs) rest     = (fromRes (f (Just xs)),rest)
          long _            _        rest     = (UnreqOpt ("--"++ls),rest)
 
 -- handle short option
@@ -198,15 +228,16 @@ shortOpt y ys rs optDescr = short ads ys rs
   where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]
         ads     = [ ad | Option _ _ ad _ <- options ]
         optStr  = '-':[y]
+        fromRes = fromParseResult optStr
 
         short (_:_:_)        _  rest     = (errAmbig options optStr,rest)
         short (NoArg  a  :_) [] rest     = (Opt a,rest)
         short (NoArg  a  :_) xs rest     = (Opt a,('-':xs):rest)
         short (ReqArg _ d:_) [] []       = (errReq d optStr,[])
-        short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
-        short (ReqArg f _:_) xs rest     = (Opt (f xs),rest)
-        short (OptArg f _:_) [] rest     = (Opt (f Nothing),rest)
-        short (OptArg f _:_) xs rest     = (Opt (f (Just xs)),rest)
+        short (ReqArg f _:_) [] (r:rest) = (fromRes (f r),rest)
+        short (ReqArg f _:_) xs rest     = (fromRes (f xs),rest)
+        short (OptArg f _:_) [] rest     = (fromRes (f Nothing),rest)
+        short (OptArg f _:_) xs rest     = (fromRes (f (Just xs)),rest)
         short []             [] rest     = (UnreqOpt optStr,rest)
         short []             xs rest     = (UnreqOpt (optStr++xs),rest)
         -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest)
@@ -215,9 +246,14 @@ shortOpt y ys rs optDescr = short ads ys rs
         -- But why was no equivalent change required for longOpt? So could
         -- this change go upstream?
 
+fromParseResult :: String -> Either String a -> OptKind a
+fromParseResult optStr res = case res of
+  Right x   -> Opt x
+  Left  err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n")
+
 -- miscellaneous error formatting
 
-errAmbig :: [OptDescr a] -> String -> OptKind a
+errAmbig :: [OptDescr a] -> String -> OptKind b
 errAmbig ods optStr = OptErr (usageInfo header ods)
    where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
 

Cabal/src/Distribution/ReadE.hs

@@ -13,7 +13,6 @@ module Distribution.ReadE (
    -- * ReadE
    ReadE(..), succeedReadE, failReadE,
    -- * Projections
-   readEOrFail,
    parsecToReadE,
   ) where
 
@@ -38,9 +37,6 @@ succeedReadE f = ReadE (Right . f)
 failReadE :: ErrorMsg -> ReadE a
 failReadE = ReadE . const . Left
 
-readEOrFail :: ReadE a -> String -> a
-readEOrFail r = either error id . runReadE r
-
 parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a
 parsecToReadE err p = ReadE $ \txt ->
     case runParsecParser p "<parsecToReadE>" (fieldLineStreamFromString txt) of

Cabal/src/Distribution/Simple/Command.hs

@@ -223,16 +223,15 @@ commandGetOpts :: ShowOrParseArgs -> CommandUI flags
 commandGetOpts showOrParse command =
     concatMap viewAsGetOpt (commandOptions command showOrParse)
 
-viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)]
+viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)]
 viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
   where
     optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) =
-         [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d]
-             where set' = readEOrFail set
+         [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d]
     optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) =
          [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d]
-             where set' Nothing    = def
-                   set' (Just txt) = readEOrFail set txt
+             where set' Nothing    = Right def
+                   set' (Just txt) = runReadE set txt
     optDescrToGetOpt (ChoiceOpt alts) =
          [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ]
     optDescrToGetOpt (BoolOpt d (sfT, lfT) ([],  [])  set _) =
@@ -391,13 +390,8 @@ addCommonFlags :: ShowOrParseArgs
                -> [GetOpt.OptDescr a]
                -> [GetOpt.OptDescr (Either CommonFlag a)]
 addCommonFlags showOrParseArgs options =
-     map (fmapOptDesc Left)  (commonFlags showOrParseArgs)
-  ++ map (fmapOptDesc Right) options
-  where fmapOptDesc f (GetOpt.Option s l d m) =
-                       GetOpt.Option s l (fmapArgDesc f d) m
-        fmapArgDesc f (GetOpt.NoArg a)    = GetOpt.NoArg (f a)
-        fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d
-        fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d
+     map (fmap Left)  (commonFlags showOrParseArgs)
+  ++ map (fmap Right) options
 
 -- | Parse a bunch of command line arguments
 --

changelog.d/option-argument-errors

+synopsis: Handle option argument parse errors without 'error'
+packages: Cabal, cabal-install
+prs: #7579
+issues: #7573
+description: {
+- Errors parsing arguments such as `-v=3` no longer result in
+  stack traces.
+- `Distribution.ReadE.readEOrFail` was removed.
+}