Merge pull request #6764 from phadej/remove-text-instances

Remove text instances

Author: phadej

Cabal/Distribution/Compat/CharParsing.hs

@@ -38,6 +38,7 @@ module Distribution.Compat.CharParsing
   , CharParsing(..)
   -- * Cabal additions
   , integral
+  , signedIntegral
   , munch1
   , munch
   , skipSpaces1
@@ -331,6 +332,14 @@ integral = toNumber <$> some d <?> "integral"
     f _   = error "panic! integral"
 {-# INLINE integral #-}
 
+-- | Accepts negative (starting with @-@) and positive (without sign) integral
+-- numbers.
+-- 
+-- @since 3.4.0.0
+signedIntegral :: (CharParsing m, Integral a) => m a
+signedIntegral = negate <$ char '-' <*> integral <|> integral
+{-# INLINE signedIntegral #-}
+
 -- | Greedily munch characters while predicate holds.
 -- Require at least one character.
 munch1 :: CharParsing m => (Char -> Bool) -> m String

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/Anonymous.hs

@@ -49,7 +49,9 @@ import qualified Distribution.Deprecated.Text as Text
 import Distribution.Deprecated.ParseUtils
          ( FieldDescr(..), ParseResult(..), Field(..)
          , simpleField, listField, ppFields, readFields
-         , syntaxError, locatedErrorMsg )
+         , syntaxError, locatedErrorMsg, simpleFieldParsec )
+import Distribution.Pretty (pretty)
+import Distribution.Parsec (parsec)
 import Distribution.Simple.Utils
          ( comparing )
 
@@ -238,7 +240,7 @@ fieldDescrs =
                                  package        (\v r -> r { package = v })
  , simpleField "os"              Text.disp      Text.parse
                                  os             (\v r -> r { os = v })
- , simpleField "arch"            Text.disp      Text.parse
+ , simpleFieldParsec "arch"      pretty         parsec
                                  arch           (\v r -> r { arch = v })
  , simpleField "compiler"        Text.disp      Text.parse
                                  compiler       (\v r -> r { compiler = v })

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/Config.hs

@@ -94,7 +94,9 @@ import Distribution.Deprecated.ParseUtils
          , locatedErrorMsg, showPWarning
          , readFields, warning, lineNo
          , simpleField, listField, spaceListField
-         , parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError)
+         , parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError
+         , simpleFieldParsec
+         )
 import Distribution.Client.ParseUtils
          ( parseFields, ppFields, ppSection )
 import Distribution.Client.HttpUtils
@@ -115,6 +117,7 @@ import Distribution.Compiler
          ( CompilerFlavor(..), defaultCompilerFlavor )
 import Distribution.Verbosity
          ( Verbosity, normal )
+import qualified Distribution.Compat.CharParsing as P
 
 import Distribution.Solver.Types.ConstraintSource
 
@@ -1345,8 +1348,8 @@ remoteRepoFields =
   , listField "root-keys"
     text                     parseTokenQ
     remoteRepoRootKeys       (\x repo -> repo { remoteRepoRootKeys = x })
-  , simpleField "key-threshold"
-    showThreshold            Text.parse
+  , simpleFieldParsec "key-threshold"
+    showThreshold            P.integral
     remoteRepoKeyThreshold   (\x repo -> repo { remoteRepoKeyThreshold = x })
   ]
   where

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/Get.hs

@@ -36,7 +36,6 @@ import Distribution.Simple.Utils
 import Distribution.Verbosity
          ( Verbosity )
 import Distribution.Pretty (prettyShow)
-import Distribution.Deprecated.Text (display)
 import qualified Distribution.PackageDescription as PD
 import Distribution.Simple.Program
          ( programName )
@@ -171,7 +170,7 @@ unpackPackage :: Verbosity -> FilePath -> PackageId
               -> PackageDescriptionOverride
               -> FilePath  -> IO ()
 unpackPackage verbosity prefix pkgid descOverride pkgPath = do
-    let pkgdirname               = display pkgid
+    let pkgdirname               = prettyShow pkgid
         pkgdir                   = prefix </> pkgdirname
         pkgdir'                  = addTrailingPathSeparator pkgdir
         emptyDirectory directory = null <$> listDirectory directory
@@ -190,7 +189,7 @@ unpackPackage verbosity prefix pkgid descOverride pkgPath = do
     case descOverride of
       Nothing     -> return ()
       Just pkgtxt -> do
-        let descFilePath = pkgdir </> display (packageName pkgid) <.> "cabal"
+        let descFilePath = pkgdir </> prettyShow (packageName pkgid) <.> "cabal"
         info verbosity $
           "Updating " ++ descFilePath
                       ++ " with the latest revision from the index."
@@ -214,37 +213,37 @@ data ClonePackageException =
 
 instance Exception ClonePackageException where
   displayException (ClonePackageNoSourceRepos pkgid) =
-       "Cannot fetch a source repository for package " ++ display pkgid
+       "Cannot fetch a source repository for package " ++ prettyShow pkgid
     ++ ". The package does not specify any source repositories."
 
   displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) =
-       "Cannot fetch a source repository for package " ++ display pkgid
+       "Cannot fetch a source repository for package " ++ prettyShow pkgid
     ++ ". The package does not specify a source repository of the requested "
-    ++ "kind" ++ maybe "." (\k -> " (kind " ++ display k ++ ").") repoKind
+    ++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind
 
   displayException (ClonePackageNoRepoType pkgid _repo) =
-       "Cannot fetch the source repository for package " ++ display pkgid
+       "Cannot fetch the source repository for package " ++ prettyShow pkgid
     ++ ". The package's description specifies a source repository but does "
     ++ "not specify the repository 'type' field (e.g. git, darcs or hg)."
 
   displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) =
-       "Cannot fetch the source repository for package " ++ display pkgid
-    ++ ". The repository type '" ++ display repoType
+       "Cannot fetch the source repository for package " ++ prettyShow pkgid
+    ++ ". The repository type '" ++ prettyShow repoType
     ++ "' is not yet supported."
 
   displayException (ClonePackageNoRepoLocation pkgid _repo) =
-       "Cannot fetch the source repository for package " ++ display pkgid
+       "Cannot fetch the source repository for package " ++ prettyShow pkgid
     ++ ". The package's description specifies a source repository but does "
     ++ "not specify the repository 'location' field (i.e. the URL)."
 
   displayException (ClonePackageDestinationExists pkgid dest isdir) =
-       "Not fetching the source repository for package " ++ display pkgid ++ ". "
+       "Not fetching the source repository for package " ++ prettyShow pkgid ++ ". "
     ++ if isdir then "The destination directory " ++ dest ++ " already exists."
                 else "A file " ++ dest ++ " is in the way."
 
   displayException (ClonePackageFailedWithExitCode
                       pkgid repo vcsprogname exitcode) =
-       "Failed to fetch the source repository for package " ++ display pkgid
+       "Failed to fetch the source repository for package " ++ prettyShow pkgid
     ++ ", repository location " ++ srpLocation repo ++ " ("
     ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")."
 
@@ -302,7 +301,7 @@ clonePackagesFromSourceRepo verbosity destDirPrefix
         Left SourceRepoLocationUnspecified ->
           throwIO (ClonePackageNoRepoLocation pkgid repo)
 
-      let destDir = destDirPrefix </> display (packageName pkgid)
+      let destDir = destDirPrefix </> prettyShow (packageName pkgid)
       destDirExists  <- doesDirectoryExist destDir
       destFileExists <- doesFileExist      destDir
       when (destDirExists || destFileExists) $

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]