Skip to content

Commit

Permalink
Improve error message for empty --allow-newer= (fix #7740)
Browse files Browse the repository at this point in the history
  • Loading branch information
ulysses4ever authored and mergify[bot] committed May 17, 2022
1 parent 731a983 commit b8c67bb
Show file tree
Hide file tree
Showing 3 changed files with 44 additions and 10 deletions.
28 changes: 23 additions & 5 deletions Cabal/src/Distribution/ReadE.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.ReadE
Expand All @@ -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
Expand All @@ -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

15 changes: 10 additions & 5 deletions cabal-install/src/Distribution/Client/Setup.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 )
Expand Down Expand Up @@ -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"]
Expand Down Expand Up @@ -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 = []
Expand Down
11 changes: 11 additions & 0 deletions changelog.d/pr-8140
Original file line number Diff line number Diff line change
@@ -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.

}

0 comments on commit b8c67bb

Please sign in to comment.