Merge pull request #8140 from ulysses4ever/issue-7740-empty-allow-new…

…er-parse

Improve error message for empty --allow-newer= (fix #7740)

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 "<parsecToReadE>" (fieldLineStreamFromString txt)
+
 parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a
 parsecToReadE err p = ReadE $ \txt ->
-    case runParsecParser p "<parsecToReadE>" (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
+

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,15 +680,15 @@ 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"]
     ("Ignore upper bounds in all dependencies or DEPS")
     (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                     = []

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