Remove Text RelaxDeps instances

cabal-install/Distribution/Client/Config.hs

@@ -129,7 +129,7 @@ import qualified Distribution.Deprecated.ReadP as Parse
 import Distribution.Compat.Semigroup
 import qualified Text.PrettyPrint as Disp
          ( render, text, empty )
-import Distribution.Parsec (parsec, simpleParsec)
+import Distribution.Parsec (parsec, simpleParsec, parsecOptCommaList)
 import Distribution.Pretty (pretty)
 import Text.PrettyPrint
          ( ($+$) )
@@ -960,14 +960,14 @@ configFieldDescriptions src =
        (configureExOptions ParseArgs src)
        []
        [let pkgs            = (Just . AllowOlder . RelaxDepsSome)
-                              `fmap` parseOptCommaList Text.parse
+                              `fmap` parsecOptCommaList parsec
             parseAllowOlder = ((Just . AllowOlder . toRelaxDeps)
                                `fmap` Text.parse) Parse.<++ pkgs
          in simpleField "allow-older"
             (showRelaxDeps . fmap unAllowOlder) parseAllowOlder
             configAllowOlder (\v flags -> flags { configAllowOlder = v })
        ,let pkgs            = (Just . AllowNewer . RelaxDepsSome)
-                              `fmap` parseOptCommaList Text.parse
+                              `fmap` parsecOptCommaList parsec
             parseAllowNewer = ((Just . AllowNewer . toRelaxDeps)
                                `fmap` Text.parse) Parse.<++ pkgs
          in simpleField "allow-newer"

cabal-install/Distribution/Client/IndexUtils/ActiveRepos.hs

@@ -14,7 +14,7 @@ import Distribution.Client.Types.RepoName (RepoName (..))
 import Prelude ()
 
 import Distribution.FieldGrammar.Described
-import Distribution.Parsec                 (Parsec (..), parsecLeadingCommaList)
+import Distribution.Parsec                 (Parsec (..), parsecLeadingCommaNonEmpty)
 import Distribution.Pretty                 (Pretty (..), prettyShow)
 
 import qualified Distribution.Compat.CharParsing as P
@@ -63,7 +63,7 @@ instance Pretty ActiveRepos where
 instance Parsec ActiveRepos where
     parsec = ActiveRepos [] <$ P.try (P.string ":none")
         <|> do
-            repos <- parsecLeadingCommaList parsec
+            repos <- parsecLeadingCommaNonEmpty parsec
             return (ActiveRepos (toList repos))
 
 instance Described ActiveRepos where

cabal-install/Distribution/Client/ProjectConfig/Legacy.hs

@@ -76,7 +76,7 @@ import Distribution.Deprecated.ReadP
 import qualified Text.PrettyPrint as Disp
 import Text.PrettyPrint
          ( Doc, ($+$) )
-import qualified Distribution.Deprecated.ParseUtils as ParseUtils (field)
+import qualified Distribution.Deprecated.ParseUtils as ParseUtils
 import Distribution.Deprecated.ParseUtils
          ( ParseResult(..), PError(..), syntaxError, PWarning(..)
          , simpleField, commaNewLineListField, newLineListField, parseTokenQ
@@ -87,6 +87,8 @@ import Distribution.Simple.Command
          , OptionField, option, reqArg' )
 import Distribution.Types.PackageVersionConstraint
          ( PackageVersionConstraint )
+import Distribution.Parsec (Parsec (..), ParsecParser)
+import Distribution.Pretty (Pretty (..))
 
 import qualified Data.Map as Map
 
@@ -965,13 +967,13 @@ legacySharedConfigFieldDescrs =
         disp parse
         configPreferences (\v conf -> conf { configPreferences = v })
 
-      , monoidField "allow-older"
-        (maybe mempty disp) (fmap Just parse)
+      , monoidFieldParsec "allow-older"
+        (maybe mempty pretty) (fmap Just parsec)
         (fmap unAllowOlder . configAllowOlder)
         (\v conf -> conf { configAllowOlder = fmap AllowOlder v })
 
-      , monoidField "allow-newer"
-        (maybe mempty disp) (fmap Just parse)
+      , monoidFieldParsec "allow-newer"
+        (maybe mempty pretty) (fmap Just parsec)
         (fmap unAllowNewer . configAllowNewer)
         (\v conf -> conf { configAllowNewer = fmap AllowNewer v })
       ]
@@ -1425,10 +1427,11 @@ remoteRepoSectionDescr = SectionDescr
 
 -- | Parser combinator for simple fields which uses the field type's
 -- 'Monoid' instance for combining multiple occurrences of the field.
-monoidField :: Monoid a => String -> (a -> Doc) -> ReadP a a
-            -> (b -> a) -> (a -> b -> b) -> FieldDescr b
-monoidField name showF readF get' set =
-  liftField get' set' $ ParseUtils.field name showF readF
+monoidFieldParsec
+    :: Monoid a => String -> (a -> Doc) -> ParsecParser a
+    -> (b -> a) -> (a -> b -> b) -> FieldDescr b
+monoidFieldParsec name showF readF get' set =
+  liftField get' set' $ ParseUtils.fieldParsec name showF readF
   where
     set' xs b = set (get' b `mappend` xs) b
 

cabal-install/Distribution/Client/Setup.hs

@@ -81,7 +81,7 @@ import Distribution.Client.Targets
          ( UserConstraint, readUserConstraint )
 import Distribution.Utils.NubList
          ( NubList, toNubList, fromNubList)
-import Distribution.Parsec (simpleParsec, parsec)
+import Distribution.Parsec (CabalParsing, simpleParsec, parsec, eitherParsec )
 import Distribution.Pretty (prettyShow)
 
 import Distribution.Solver.Types.ConstraintSource
@@ -123,10 +123,11 @@ import Distribution.PackageDescription
 import Distribution.System ( Platform )
 import Distribution.Deprecated.Text
          ( Text(..), display )
+import qualified Distribution.Compat.CharParsing as P
 import Distribution.ReadE
          ( ReadE(..), succeedReadE, parsecToReadE )
 import qualified Distribution.Deprecated.ReadP as Parse
-         ( ReadP, char, sepBy1 )
+         ( char, sepBy1 )
 import Distribution.Verbosity
          ( Verbosity, lessVerbose, normal, verboseNoFlags, verboseNoTimestamp )
 import Distribution.Simple.Utils
@@ -137,7 +138,6 @@ import Distribution.Client.GlobalFlags
          )
 import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions)
 import Distribution.Parsec.Newtypes (SpecVersion (..))
-import Distribution.Parsec (eitherParsec)
 
 import Data.List
          ( deleteFirstsBy )
@@ -717,14 +717,14 @@ writeGhcEnvironmentFilesPolicyPrinter = \case
   NoFlag                                               -> []
 
 
-relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps)
+relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps)
 relaxDepsParser =
-  (Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',')
+  (Just . RelaxDepsSome . toList) `fmap` P.sepByNonEmpty parsec (P.char ',')
 
 relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String]
 relaxDepsPrinter Nothing                     = []
 relaxDepsPrinter (Just RelaxDepsAll)         = [Nothing]
-relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs
+relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs
 
 
 instance Monoid ConfigExFlags where

cabal-install/Distribution/Client/Types/AllowNewer.hs

@@ -3,6 +3,7 @@ module Distribution.Client.Types.AllowNewer (
     AllowNewer (..),
     AllowOlder (..),
     RelaxDeps (..),
+    mkRelaxDepSome,
     RelaxDepMod (..),
     RelaxDepScope (..),
     RelaxDepSubject (..),
@@ -13,15 +14,18 @@ module Distribution.Client.Types.AllowNewer (
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
-import Distribution.Types.PackageId   (PackageId, pkgVersion)
+import Distribution.Types.PackageId   (PackageId, PackageIdentifier (..))
 import Distribution.Types.PackageName (PackageName, mkPackageName)
 import Distribution.Types.Version     (nullVersion)
 
-import qualified Text.PrettyPrint as Disp
+import qualified Distribution.Compat.CharParsing as P
+import qualified Text.PrettyPrint                as Disp
 
-import           Distribution.Deprecated.ParseUtils (parseOptCommaList)
-import qualified Distribution.Deprecated.ReadP      as Parse
-import           Distribution.Deprecated.Text       (Text (..))
+import Distribution.Parsec (CabalParsing, Parsec (..), parsecLeadingCommaList)
+import Distribution.Pretty (Pretty (..))
+
+-- $setup
+-- >>> import Distribution.Parsec
 
 -- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled,
 -- it may make sense to move these definitions to the Solver.Types
@@ -82,59 +86,95 @@ data RelaxDepSubject = RelaxDepSubjectAll
                      | RelaxDepSubjectPkg !PackageName
                      deriving (Eq, Ord, Read, Show, Generic)
 
-instance Text RelaxedDep where
-  disp (RelaxedDep scope rdmod subj) = case scope of
-      RelaxDepScopeAll          -> Disp.text "all:"           Disp.<> modDep
-      RelaxDepScopePackage   p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep
-      RelaxDepScopePackageId p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep
+instance Pretty RelaxedDep where
+  pretty (RelaxedDep scope rdmod subj) = case scope of
+      RelaxDepScopeAll          -> Disp.text "*:"               Disp.<> modDep
+      RelaxDepScopePackage   p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep
+      RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep
     where
       modDep = case rdmod of
-               RelaxDepModNone  -> disp subj
-               RelaxDepModCaret -> Disp.char '^' Disp.<> disp subj
-
-  parse = RelaxedDep <$> scopeP <*> modP <*> parse
-    where
-      -- "greedy" choices
-      scopeP =           (pure RelaxDepScopeAll  <* Parse.char '*' <* Parse.char ':')
-               Parse.<++ (pure RelaxDepScopeAll  <* Parse.string "all:")
-               Parse.<++ (RelaxDepScopePackageId <$> pidP  <* Parse.char ':')
-               Parse.<++ (RelaxDepScopePackage   <$> parse <* Parse.char ':')
-               Parse.<++ (pure RelaxDepScopeAll)
-
-      modP =           (pure RelaxDepModCaret <* Parse.char '^')
-             Parse.<++ (pure RelaxDepModNone)
-
-      -- | Stricter 'PackageId' parser which doesn't overlap with 'PackageName' parser
-      pidP = do
-          p0 <- parse
-          when (pkgVersion p0 == nullVersion) Parse.pfail
-          pure p0
-
-instance Text RelaxDepSubject where
-  disp RelaxDepSubjectAll      = Disp.text "all"
-  disp (RelaxDepSubjectPkg pn) = disp pn
-
-  parse = (pure RelaxDepSubjectAll <* Parse.char '*') Parse.<++ pkgn
+               RelaxDepModNone  -> pretty subj
+               RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj
+
+instance Parsec RelaxedDep where
+    parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP)
+
+-- continuation after *
+relaxedDepStarP :: CabalParsing m => m RelaxedDep
+relaxedDepStarP =
+    RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec
+    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)
+
+-- continuation after package identifier
+relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep
+relaxedDepPkgidP pid@(PackageIdentifier pn v)
+    | pn == mkPackageName "all"
+    , v == nullVersion
+    =  RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec
+    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)
+
+    | v == nullVersion
+    = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec
+    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn))
+
+    | otherwise
+    = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec
+
+modP :: P.CharParsing m => m RelaxDepMod
+modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone
+
+instance Pretty RelaxDepSubject where
+  pretty RelaxDepSubjectAll      = Disp.text "*"
+  pretty (RelaxDepSubjectPkg pn) = pretty pn
+
+instance Parsec RelaxDepSubject where
+  parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn
     where
       pkgn = do
-          pn <- parse
-          pure (if (pn == mkPackageName "all")
-                then RelaxDepSubjectAll
-                else RelaxDepSubjectPkg pn)
-
-instance Text RelaxDeps where
-  disp rd | not (isRelaxDeps rd) = Disp.text "none"
-  disp (RelaxDepsSome pkgs)      = Disp.fsep .
+          pn <- parsec
+          pure $ if pn == mkPackageName "all"
+              then RelaxDepSubjectAll
+              else RelaxDepSubjectPkg pn
+
+instance Pretty RelaxDeps where
+  pretty rd | not (isRelaxDeps rd) = Disp.text "none"
+  pretty (RelaxDepsSome pkgs)      = Disp.fsep .
                                    Disp.punctuate Disp.comma .
-                                   map disp $ pkgs
-  disp RelaxDepsAll              = Disp.text "all"
+                                   map pretty $ pkgs
+  pretty RelaxDepsAll              = Disp.text "all"
 
-  parse =           (const mempty        <$> ((Parse.string "none" Parse.+++
-                                               Parse.string "None") <* Parse.eof))
-          Parse.<++ (const RelaxDepsAll  <$> ((Parse.string "all"  Parse.+++
-                                               Parse.string "All"  Parse.+++
-                                               Parse.string "*")  <* Parse.eof))
-          Parse.<++ (      RelaxDepsSome <$> parseOptCommaList parse)
+-- |
+--
+-- >>> simpleParsec "all" :: Maybe RelaxDeps
+-- Just RelaxDepsAll
+--
+-- >>> simpleParsec "none" :: Maybe RelaxDeps
+-- Just (RelaxDepsSome [])
+--
+-- >>> simpleParsec "*, *" :: Maybe RelaxDeps
+-- Just RelaxDepsAll
+--
+-- >>> simpleParsec "*:*" :: Maybe RelaxDeps
+-- Just RelaxDepsAll
+--
+-- >>> simpleParsec "foo:bar, quu:puu" :: Maybe RelaxDeps
+-- Just (RelaxDepsSome [RelaxedDep (RelaxDepScopePackage (PackageName "foo")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "bar")),RelaxedDep (RelaxDepScopePackage (PackageName "quu")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "puu"))])
+--
+-- This is not a glitch, even it looks like:
+--
+-- >>> simpleParsec ", all" :: Maybe RelaxDeps
+-- Just RelaxDepsAll
+-- 
+instance Parsec RelaxDeps where
+    parsec = do
+        xs <- parsecLeadingCommaList parsec
+        pure $ case xs of
+            [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]
+                -> RelaxDepsAll
+            [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)]
+                | pn == mkPackageName "none"                                
+                -> mempty
+            _   -> mkRelaxDepSome xs
 
 instance Binary RelaxDeps
 instance Binary RelaxDepMod
@@ -160,16 +200,25 @@ isRelaxDeps (RelaxDepsSome [])    = False
 isRelaxDeps (RelaxDepsSome (_:_)) = True
 isRelaxDeps RelaxDepsAll          = True
 
+-- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@.
+mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps
+mkRelaxDepSome xs
+    | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs
+    = RelaxDepsAll
+
+    | otherwise
+    = RelaxDepsSome xs
+
 -- | 'RelaxDepsAll' is the /absorbing element/
 instance Semigroup RelaxDeps where
-  -- identity element
-  RelaxDepsSome []    <> r                   = r
-  l@(RelaxDepsSome _) <> RelaxDepsSome []    = l
-  -- absorbing element
-  l@RelaxDepsAll      <> _                   = l
-  (RelaxDepsSome   _) <> r@RelaxDepsAll      = r
-  -- combining non-{identity,absorbing} elements
-  (RelaxDepsSome   a) <> (RelaxDepsSome b)   = RelaxDepsSome (a ++ b)
+    -- identity element
+    RelaxDepsSome []    <> r                   = r
+    l@(RelaxDepsSome _) <> RelaxDepsSome []    = l
+    -- absorbing element
+    l@RelaxDepsAll      <> _                   = l
+    (RelaxDepsSome   _) <> r@RelaxDepsAll      = r
+    -- combining non-{identity,absorbing} elements
+    (RelaxDepsSome   a) <> (RelaxDepsSome b)   = RelaxDepsSome (a ++ b)
 
 -- | @'RelaxDepsSome' []@ is the /identity element/
 instance Monoid RelaxDeps where

cabal-install/Distribution/Deprecated/ParseUtils.hs

@@ -39,6 +39,8 @@ module Distribution.Deprecated.ParseUtils (
         optsField, liftField, boolField, parseQuoted, parseMaybeQuoted,
         readPToMaybe,
 
+        fieldParsec,
+
         UnrecFieldParser, warnUnrec, ignoreUnrec,
   ) where
 
@@ -67,6 +69,7 @@ import qualified Text.Read as Read
 import qualified Data.Map  as Map
 
 import qualified Control.Monad.Fail as Fail
+import Distribution.Parsec (ParsecParser, explicitEitherParsec)
 
 -- -----------------------------------------------------------------------------
 
@@ -188,6 +191,12 @@ field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a
 field name showF readF =
   FieldDescr name showF (\line val _st -> runP line name readF val)
 
+fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
+fieldParsec name showF readF =
+  FieldDescr name showF $ \line val _st -> case explicitEitherParsec readF val of
+    Left err -> ParseFailed (FromString err (Just line))
+    Right x  -> ParseOk [] x
+
 -- Lift a field descriptor storing into an 'a' to a field descriptor storing
 -- into a 'b'.
 liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
@@ -721,4 +730,4 @@ parseFlagAssignment = mkFlagAssignment <$>
 -------------------------------------------------------------------------------
 
 showTestedWith :: (CompilerFlavor, VersionRange) -> Doc
-showTestedWith = pretty . pack' TestedWith
+showTestedWith = pretty . pack' TestedWith