diff --git a/Cabal/src/Distribution/ReadE.hs b/Cabal/src/Distribution/ReadE.hs index ba278b947c9..04a1031ed42 100644 --- a/Cabal/src/Distribution/ReadE.hs +++ b/Cabal/src/Distribution/ReadE.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.ReadE @@ -13,13 +14,17 @@ module Distribution.ReadE ( -- * ReadE ReadE(..), succeedReadE, failReadE, -- * Projections - parsecToReadE, + parsecToReadE, parsecToReadEErr, + -- * Parse Errors + unexpectMsgString, ) where import Distribution.Compat.Prelude import Prelude () +import qualified Data.Bifunctor as Bi (first) import Distribution.Parsec +import qualified Text.Parsec.Error as Parsec import Distribution.Parsec.FieldLineStream -- | Parser with simple error reporting @@ -37,9 +42,22 @@ succeedReadE f = ReadE (Right . f) failReadE :: ErrorMsg -> ReadE a failReadE = ReadE . const . Left +runParsecFromString :: ParsecParser a -> String -> Either Parsec.ParseError a +runParsecFromString p txt = + runParsecParser p "" (fieldLineStreamFromString txt) + parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a parsecToReadE err p = ReadE $ \txt -> - case runParsecParser p "" (fieldLineStreamFromString txt) of - Right x -> Right x - Left _e -> Left (err txt) --- TODO: use parsec error to make 'ErrorMsg'. + (const $ err txt) `Bi.first` runParsecFromString p txt + +parsecToReadEErr :: (Parsec.ParseError -> ErrorMsg) -> ParsecParser a -> ReadE a +parsecToReadEErr err p = ReadE $ + Bi.first err . runParsecFromString p + +-- Show only unexpected error messages +unexpectMsgString :: Parsec.ParseError -> String +unexpectMsgString = unlines + . map Parsec.messageString + . filter (\case { Parsec.UnExpect _ -> True; _ -> False }) + . Parsec.errorMessages + diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index a132b01d528..f309a6bf1f6 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -115,7 +115,7 @@ import Distribution.PackageDescription ( BuildType(..), RepoKind(..), LibraryName(..) ) import Distribution.System ( Platform ) import Distribution.ReadE - ( ReadE(..), succeedReadE, parsecToReadE ) + ( ReadE(..), succeedReadE, parsecToReadE, parsecToReadEErr, unexpectMsgString ) import qualified Distribution.Compat.CharParsing as P import Distribution.Verbosity ( lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) @@ -680,7 +680,7 @@ configureExOptions _showOrParseArgs src = (fmap unAllowOlder . configAllowOlder) (\v flags -> flags { configAllowOlder = fmap AllowOlder v}) (optArg "DEPS" - (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser) + (parsecToReadEErr unexpectMsgString relaxDepsParser) (Just RelaxDepsAll) relaxDepsPrinter) , option [] ["allow-newer"] @@ -688,7 +688,7 @@ configureExOptions _showOrParseArgs src = (fmap unAllowNewer . configAllowNewer) (\v flags -> flags { configAllowNewer = fmap AllowNewer v}) (optArg "DEPS" - (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser) + (parsecToReadEErr unexpectMsgString relaxDepsParser) (Just RelaxDepsAll) relaxDepsPrinter) , option [] ["write-ghc-environment-files"] @@ -720,8 +720,13 @@ writeGhcEnvironmentFilesPolicyPrinter = \case relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps) -relaxDepsParser = - (Just . RelaxDepsSome . toList) `fmap` P.sepByNonEmpty parsec (P.char ',') +relaxDepsParser = do + rs <- P.sepBy parsec (P.char ',') + if null rs + then fail $ "empty argument list is not allowed. " + ++ "Note: use --allow-newer without the equals sign to permit all " + ++ "packages to use newer versions." + else return . Just . RelaxDepsSome . toList $ rs relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] relaxDepsPrinter Nothing = [] diff --git a/changelog.d/pr-8140 b/changelog.d/pr-8140 new file mode 100644 index 00000000000..f5229829fcb --- /dev/null +++ b/changelog.d/pr-8140 @@ -0,0 +1,11 @@ +synopsis: Improve error message for empty --allow-newer= +packages: Cabal, cabal-install +prs: #8140 +issues: #7740 +description: { + +Instead of internal error, the message now explains that empty argument for +--allow-newer= is not allowed and reminds what --allow-newer (with the empty +argument) means. + +}