Change Text insances into Pretty/Parsec

Author: phadej

Cabal/Distribution/Types/Flag.hs

@@ -18,6 +18,8 @@ module Distribution.Types.Flag (
     showFlagValue,
     dispFlagAssignment,
     parsecFlagAssignment,
+    parsecFlagAssignmentNonEmpty,
+    describeFlagAssignment,
     ) where
 
 import Prelude ()
@@ -255,3 +257,25 @@ parsecFlagAssignment = mkFlagAssignment <$>
         _ <- P.char '-'
         f <- parsec
         return (f, False)
+
+-- | Parse a non-empty flag assignment
+--
+-- The flags have to explicitly start with minus or plus.
+--
+-- @since 3.4.0.0
+parsecFlagAssignmentNonEmpty :: CabalParsing m => m FlagAssignment
+parsecFlagAssignmentNonEmpty = mkFlagAssignment . toList <$>
+    P.sepByNonEmpty (onFlag <|> offFlag) P.skipSpaces1
+  where
+    onFlag = do
+        _ <- P.char '+'
+        f <- parsec
+        return (f, True)
+    offFlag = do
+        _ <- P.char '-'
+        f <- parsec
+        return (f, False)
+
+describeFlagAssignment :: GrammarRegex void
+describeFlagAssignment = REMunch1 RESpaces1 $
+    REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName)

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

@@ -15,18 +15,15 @@ module Distribution.Client.BuildReports.Types (
     ReportLevel(..),
   ) where
 
-import qualified Distribution.Deprecated.Text as Text
-         ( Text(..) )
-
-import qualified Distribution.Deprecated.ReadP as Parse
-         ( pfail, munch1 )
+import qualified Distribution.Compat.CharParsing as P
 import qualified Text.PrettyPrint as Disp
-         ( text )
 
 import Data.Char as Char
          ( isAlpha, toLower )
 import GHC.Generics (Generic)
 import Distribution.Compat.Binary (Binary)
+import Distribution.Parsec (Parsec (..))
+import Distribution.Pretty (Pretty (..))
 import Distribution.Utils.Structured (Structured)
 
 data ReportLevel = NoReports | AnonymousReports | DetailedReports
@@ -35,17 +32,19 @@ data ReportLevel = NoReports | AnonymousReports | DetailedReports
 instance Binary ReportLevel
 instance Structured ReportLevel
 
-instance Text.Text ReportLevel where
-  disp NoReports        = Disp.text "none"
-  disp AnonymousReports = Disp.text "anonymous"
-  disp DetailedReports  = Disp.text "detailed"
-  parse = do
-    name <- Parse.munch1 Char.isAlpha
+instance Pretty ReportLevel where
+  pretty NoReports        = Disp.text "none"
+  pretty AnonymousReports = Disp.text "anonymous"
+  pretty DetailedReports  = Disp.text "detailed"
+
+instance Parsec ReportLevel where
+  parsec = do
+    name <- P.munch1 Char.isAlpha
     case lowercase name of
       "none"       -> return NoReports
       "anonymous"  -> return AnonymousReports
       "detailed"   -> return DetailedReports
-      _            -> Parse.pfail
+      _            -> P.unexpected $ "ReportLevel: " ++ name
 
 lowercase :: String -> String
 lowercase = map Char.toLower

cabal-install/Distribution/Client/Configure.hs

@@ -26,6 +26,7 @@ import Prelude ()
 import Distribution.Client.Compat.Prelude
 import Distribution.Utils.Generic (safeHead)
 
+import Distribution.Pretty (prettyShow)
 import Distribution.Client.Dependency
 import qualified Distribution.Client.InstallPlan as InstallPlan
 import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
@@ -287,7 +288,7 @@ checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do
     unknown pkg = null (lookupPackageName installedPkgIndex pkg)
                && not (elemByPackageName sourcePkgIndex pkg)
     showConstraint (uc, src) =
-        display uc ++ " (" ++ showConstraintSource src ++ ")"
+        prettyShow uc ++ " (" ++ showConstraintSource src ++ ")"
 
 -- | Make an 'InstallPlan' for the unpacked package in the current directory,
 -- and all its dependencies.

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

@@ -8,10 +8,11 @@ module Distribution.Client.Dependency.Types (
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
-import Distribution.Deprecated.Text (Text (..))
-import Text.PrettyPrint             (text)
+import Distribution.Parsec (Parsec (..))
+import Distribution.Pretty (Pretty (..))
+import Text.PrettyPrint (text)
 
-import qualified Distribution.Deprecated.ReadP as Parse (munch1, pfail)
+import qualified Distribution.Compat.CharParsing as P
 
 
 -- | All the solvers that can be selected.
@@ -28,13 +29,15 @@ instance Binary Solver
 instance Structured PreSolver
 instance Structured Solver
 
-instance Text PreSolver where
-  disp AlwaysModular = text "modular"
-  parse = do
-    name <- Parse.munch1 isAlpha
-    case map toLower name of
-      "modular" -> return AlwaysModular
-      _         -> Parse.pfail
+instance Pretty PreSolver where
+    pretty AlwaysModular = text "modular"
+
+instance Parsec PreSolver where
+    parsec = do
+        name <- P.munch1 isAlpha
+        case map toLower name of
+            "modular" -> return AlwaysModular
+            _         -> P.unexpected $ "PreSolver: " ++ name
 
 -- | Global policy for all packages to say if we prefer package versions that
 -- are already installed locally or if we just prefer the latest available.

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

@@ -40,6 +40,8 @@ import Distribution.Client.CmdInstall.ClientInstallFlags
 
 import Distribution.Solver.Types.ConstraintSource
 
+import Distribution.Pretty (Pretty (..))
+import Distribution.Parsec (Parsec (..))
 import Distribution.Package
 import Distribution.PackageDescription
          ( dispFlagAssignment )
@@ -79,16 +81,15 @@ import Text.PrettyPrint
 import qualified Distribution.Deprecated.ParseUtils as ParseUtils
 import Distribution.Deprecated.ParseUtils
          ( ParseResult(..), PError(..), syntaxError, PWarning(..)
-         , simpleField, commaNewLineListField, newLineListField, parseTokenQ
+         , simpleField, commaNewLineListFieldParsec, newLineListField, parseTokenQ
          , parseHaskellString, showToken )
 import Distribution.Client.ParseUtils
 import Distribution.Simple.Command
          ( CommandUI(commandOptions), ShowOrParseArgs(..)
          , OptionField, option, reqArg' )
 import Distribution.Types.PackageVersionConstraint
          ( PackageVersionConstraint )
-import Distribution.Parsec (Parsec (..), ParsecParser)
-import Distribution.Pretty (Pretty (..))
+import Distribution.Parsec (ParsecParser)
 
 import qualified Data.Map as Map
 
@@ -860,8 +861,8 @@ legacyProjectConfigFieldDescrs =
         (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ
         legacyPackagesOptional
         (\v flags -> flags { legacyPackagesOptional = v })
-    , commaNewLineListField "extra-packages"
-        disp parse
+    , commaNewLineListFieldParsec "extra-packages"
+        pretty parsec
         legacyPackagesNamed
         (\v flags -> flags { legacyPackagesNamed = v })
     ]
@@ -959,12 +960,12 @@ legacySharedConfigFieldDescrs =
       legacyConfigureExFlags
       (\flags conf -> conf { legacyConfigureExFlags = flags })
   . addFields
-      [ commaNewLineListField "constraints"
-        (disp . fst) (fmap (\constraint -> (constraint, constraintSrc)) parse)
+      [ commaNewLineListFieldParsec "constraints"
+        (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec)
         configExConstraints (\v conf -> conf { configExConstraints = v })
 
-      , commaNewLineListField "preferences"
-        disp parse
+      , commaNewLineListFieldParsec "preferences"
+        pretty parsec
         configPreferences (\v conf -> conf { configPreferences = v })
 
       , monoidFieldParsec "allow-older"
@@ -1014,7 +1015,7 @@ legacySharedConfigFieldDescrs =
   . commandOptionsToFields
   ) (clientInstallOptions ParseArgs)
   where
-    constraintSrc = ConstraintSourceProjectConfig "TODO"
+    constraintSrc = ConstraintSourceProjectConfig "TODO" -- TODO: is a filepath
 
 
 legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]

cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs

@@ -54,6 +54,8 @@ import System.Directory                ( doesFileExist )
 import System.FilePath                 ( (</>) )
 import System.IO.Error                 ( isDoesNotExistError )
 import Text.PrettyPrint                ( ($+$) )
+import Distribution.Parsec             (Parsec (..))
+import Distribution.Pretty             (Pretty (..))
 
 import qualified Text.PrettyPrint          as Disp
 import qualified Distribution.Deprecated.ParseUtils   as ParseUtils ( Field(..) )
@@ -144,7 +146,7 @@ loadUserConfig verbosity pkgEnvDir globalConfigLocation =
 pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
 pkgEnvFieldDescrs src =
   [ commaNewLineListField "constraints"
-    (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse)
+    (pretty . fst) ((\pc -> (pc, src)) `fmap` parsec)
     (sortConstraints . configExConstraints
      . savedConfigureExFlags . pkgEnvSavedConfig)
     (\v pkgEnv -> updateConfigureExFlags pkgEnv