From b8c67bbfe0e1f14b2429719d90fced9c8d238f54 Mon Sep 17 00:00:00 2001
From: Artem Pelenitsyn <a.pelenitsyn@gmail.com>
Date: Sat, 14 May 2022 05:15:29 +0200
Subject: [PATCH] Improve error message for empty --allow-newer= (fix #7740)

---
 Cabal/src/Distribution/ReadE.hs               | 28 +++++++++++++++----
 .../src/Distribution/Client/Setup.hs          | 15 ++++++----
 changelog.d/pr-8140                           | 11 ++++++++
 3 files changed, 44 insertions(+), 10 deletions(-)
 create mode 100644 changelog.d/pr-8140

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