Merge pull request #7579 from robx/cabal-arg-error

Handle option argument parse errors without 'error' (fixes #7573)

Author: Mikolaj

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

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

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
+  ]

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:"
 

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

@@ -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.
+}