diff --git a/Cabal-tests/Cabal-tests.cabal b/Cabal-tests/Cabal-tests.cabal
index e4a6ca71c2524a631d45305b7e5e5a4619b03553..eb9509f5e5df5c944046b59d06decef2a669a93e 100644
--- a/Cabal-tests/Cabal-tests.cabal
+++ b/Cabal-tests/Cabal-tests.cabal
@@ -31,6 +31,7 @@ test-suite unit-tests
UnitTests.Distribution.Compat.Time
UnitTests.Distribution.Described
UnitTests.Distribution.PkgconfigVersion
+ UnitTests.Distribution.Simple.Command
UnitTests.Distribution.Simple.Glob
UnitTests.Distribution.Simple.Program.GHC
UnitTests.Distribution.Simple.Program.Internal
diff --git a/Cabal-tests/tests/UnitTests.hs b/Cabal-tests/tests/UnitTests.hs
index 611e3dd5bdb8eb435d84752442e874e53a2474a6..9ef73b80d9b35d3917799a36d376fb1779e15eaf 100644
--- a/Cabal-tests/tests/UnitTests.hs
+++ b/Cabal-tests/tests/UnitTests.hs
@@ -16,6 +16,7 @@ import Distribution.Compat.Time
import qualified UnitTests.Distribution.Compat.CreatePipe
import qualified UnitTests.Distribution.Compat.Time
import qualified UnitTests.Distribution.Compat.Graph
+import qualified UnitTests.Distribution.Simple.Command
import qualified UnitTests.Distribution.Simple.Glob
import qualified UnitTests.Distribution.Simple.Program.GHC
import qualified UnitTests.Distribution.Simple.Program.Internal
@@ -49,6 +50,8 @@ tests mtimeChangeCalibrated =
(UnitTests.Distribution.Compat.Time.tests mtimeChange)
, testGroup "Distribution.Compat.Graph"
UnitTests.Distribution.Compat.Graph.tests
+ , testGroup "Distribution.Simple.Command"
+ UnitTests.Distribution.Simple.Command.tests
, testGroup "Distribution.Simple.Glob"
UnitTests.Distribution.Simple.Glob.tests
, UnitTests.Distribution.Simple.Program.GHC.tests
diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs
new file mode 100644
index 0000000000000000000000000000000000000000..ed93409e938ef176327370088b6f21913caf6bce
--- /dev/null
+++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs
@@ -0,0 +1,44 @@
+module UnitTests.Distribution.Simple.Command
+ ( tests
+ ) where
+
+import Distribution.Simple.Command
+import qualified Distribution.Simple.Flag as Flag
+import Distribution.Simple.Setup (optionVerbosity)
+import qualified Distribution.Verbosity as Verbosity
+import Test.Tasty
+import Test.Tasty.HUnit
+
+argumentTests :: [TestTree]
+argumentTests =
+ [ testCase "parses verbosity successfully" $ do
+ let p = commandParseArgs cmdUI isGlobal ["-v2"]
+ assertEqual "expected verbose" (Right verbose) $ evalParse p
+ , testCase "handles argument parse error gracefully" $ do
+ let p = commandParseArgs cmdUI isGlobal ["-v=2"]
+ assertEqual "expected error" (Left "errors") $ evalParse p
+ ]
+ where
+ -- evaluate command parse result, to force possible exceptions in 'f'
+ evalParse p = case p of
+ CommandErrors _ -> Left "errors"
+ CommandHelp _ -> Left "help"
+ CommandList _ -> Left "list"
+ CommandReadyToGo (f, _) -> Right $ f Flag.NoFlag
+ verbose = Flag.Flag Verbosity.verbose
+ isGlobal = True
+ cmdUI = CommandUI
+ { commandName = "cmd"
+ , commandSynopsis = "the command"
+ , commandUsage = \name -> name ++ " cmd -v[N]"
+ , commandDescription = Nothing
+ , commandNotes = Nothing
+ , commandDefaultFlags = Flag.NoFlag
+ , commandOptions = const [ optField ]
+ }
+ optField = optionVerbosity id const
+
+tests :: [TestTree]
+tests =
+ [ testGroup "option argument tests" argumentTests
+ ]
diff --git a/Cabal/src/Distribution/GetOpt.hs b/Cabal/src/Distribution/GetOpt.hs
index 4c3bcca09d726355f240905f94a4a0be1d7e2384..18352df87b0636d92623a973f18ef1ca58a04f4f 100644
--- a/Cabal/src/Distribution/GetOpt.hs
+++ b/Cabal/src/Distribution/GetOpt.hs
@@ -17,8 +17,9 @@
-- * Line wrapping in the 'usageInfo' output, plus a more compact
-- rendering of short options, and slightly less padding.
--
--- If you want to take on the challenge of merging this with the GetOpt
--- from the base package then go for it!
+-- * Parsing of option arguments is allowed to fail.
+--
+-- * 'ReturnInOrder' argument order is removed.
--
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -36,8 +37,34 @@ 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
+
+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
@@ -155,10 +182,8 @@ getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)
procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[])
procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)
- procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es)
procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])
procNextOpt EndOfOpts Permute = ([],rest,[],[])
- procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[])
procNextOpt (OptErr e) _ = (os,xs,us,e:es)
(opt,rest) = getNext arg args optDescr
@@ -181,15 +206,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 +224,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 +242,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:"
diff --git a/Cabal/src/Distribution/ReadE.hs b/Cabal/src/Distribution/ReadE.hs
index 863049dea611a63b3975e7c698aad4acc6112d6b..ba278b947c9cd3fdaeddcaee2226c09d5c9999d5 100644
--- a/Cabal/src/Distribution/ReadE.hs
+++ b/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
diff --git a/Cabal/src/Distribution/Simple/Command.hs b/Cabal/src/Distribution/Simple/Command.hs
index ec7870f2ceb130d093cd27bd4bf7197278aa293d..69e0a1976598966ad1e071c27a4c554523c485ac 100644
--- a/Cabal/src/Distribution/Simple/Command.hs
+++ b/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
--
diff --git a/changelog.d/option-argument-errors b/changelog.d/option-argument-errors
new file mode 100644
index 0000000000000000000000000000000000000000..d2e9019019aca982c5b2e0d18159bafe74bb9c0b
--- /dev/null
+++ b/changelog.d/option-argument-errors
@@ -0,0 +1,9 @@
+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.
+}