From f1a4a693d3435f6623018b99f532ef961b5bc734 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 8 May 2020 11:55:32 +0300 Subject: [PATCH 1/4] Change Text insances into Pretty/Parsec --- Cabal/Distribution/Compat/CharParsing.hs | 9 + Cabal/Distribution/Types/Flag.hs | 24 +++ .../Distribution/Client/BuildReports/Types.hs | 25 ++- .../Distribution/Client/Configure.hs | 3 +- .../Distribution/Client/Dependency/Types.hs | 23 +-- .../Client/ProjectConfig/Legacy.hs | 21 +-- .../Client/Sandbox/PackageEnvironment.hs | 4 +- cabal-install/Distribution/Client/Setup.hs | 94 +++++----- cabal-install/Distribution/Client/Targets.hs | 162 ++++++++++-------- .../Distribution/Deprecated/ParseUtils.hs | 13 +- .../Distribution/Solver/Types/Settings.hs | 14 +- .../Distribution/Client/ArbitraryInstances.hs | 43 +++++ .../Distribution/Client/Described.hs | 2 + .../Distribution/Client/ProjectConfig.hs | 29 ---- .../UnitTests/Distribution/Client/Targets.hs | 20 +-- 15 files changed, 275 insertions(+), 211 deletions(-) diff --git a/Cabal/Distribution/Compat/CharParsing.hs b/Cabal/Distribution/Compat/CharParsing.hs index a6460f2e886..688343d86e8 100644 --- a/Cabal/Distribution/Compat/CharParsing.hs +++ b/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 diff --git a/Cabal/Distribution/Types/Flag.hs b/Cabal/Distribution/Types/Flag.hs index f9779aacd8d..d23f9fe157d 100644 --- a/Cabal/Distribution/Types/Flag.hs +++ b/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) diff --git a/cabal-install/Distribution/Client/BuildReports/Types.hs b/cabal-install/Distribution/Client/BuildReports/Types.hs index e126d5759af..4c4f4234299 100644 --- a/cabal-install/Distribution/Client/BuildReports/Types.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs index 06c6f594e5c..5e186c1ef6c 100644 --- a/cabal-install/Distribution/Client/Configure.hs +++ b/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. diff --git a/cabal-install/Distribution/Client/Dependency/Types.hs b/cabal-install/Distribution/Client/Dependency/Types.hs index a9646ca1241..0f19012868b 100644 --- a/cabal-install/Distribution/Client/Dependency/Types.hs +++ b/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. diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 2bebf6c18c3..c15fccf0632 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/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,7 +81,7 @@ 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 @@ -87,8 +89,7 @@ import Distribution.Simple.Command , 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] diff --git a/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs index f8dd6b204b0..458327cb34d 100644 --- a/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 4f7f4e42de2..b37daddfad8 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -60,8 +60,6 @@ module Distribution.Client.Setup import Prelude () import Distribution.Client.Compat.Prelude hiding (get) -import Distribution.Deprecated.ReadP (readP_to_E) - import Distribution.Client.Types.Credentials (Username (..), Password (..)) import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..)) import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..), RelaxDeps(..)) @@ -81,7 +79,7 @@ import Distribution.Client.Targets ( UserConstraint, readUserConstraint ) import Distribution.Utils.NubList ( NubList, toNubList, fromNubList) -import Distribution.Parsec (CabalParsing, simpleParsec, parsec, eitherParsec ) +import Distribution.Parsec (CabalParsing, simpleParsec, parsec, eitherParsec) import Distribution.Pretty (prettyShow) import Distribution.Solver.Types.ConstraintSource @@ -121,13 +119,9 @@ import Distribution.Types.UnqualComponentName import Distribution.PackageDescription ( BuildType(..), RepoKind(..), LibraryName(..) ) 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 - ( char, sepBy1 ) +import qualified Distribution.Compat.CharParsing as P import Distribution.Verbosity ( Verbosity, lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) import Distribution.Simple.Utils @@ -653,23 +647,23 @@ configureExOptions _showOrParseArgs src = ("Select which version of the Cabal lib to use to build packages " ++ "(useful for testing).") configCabalVersion (\v flags -> flags { configCabalVersion = v }) - (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++) - (fmap toFlag parse)) - (map display . flagToList)) + (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++) + (fmap toFlag parsec)) + (map prettyShow. flagToList)) , option [] ["constraint"] "Specify constraints on a package (version, installed/source, flags)" configExConstraints (\v flags -> flags { configExConstraints = v }) (reqArg "CONSTRAINT" ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint) - (map $ display . fst)) + (map $ prettyShow . fst)) , option [] ["preference"] "Specify preferences (soft constraints) on the version of a package" configPreferences (\v flags -> flags { configPreferences = v }) (reqArg "CONSTRAINT" - (readP_to_E (const "dependency expected") - (fmap (\x -> [x]) parse)) - (map display)) + (parsecToReadE (const "dependency expected") + (fmap (\x -> [x]) parsec)) + (map prettyShow)) , optionSolver configSolver (\v flags -> flags { configSolver = v }) @@ -678,7 +672,7 @@ configureExOptions _showOrParseArgs src = (fmap unAllowOlder . configAllowOlder) (\v flags -> flags { configAllowOlder = fmap AllowOlder v}) (optArg "DEPS" - (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser) + (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser) (Just RelaxDepsAll) relaxDepsPrinter) , option [] ["allow-newer"] @@ -686,7 +680,7 @@ configureExOptions _showOrParseArgs src = (fmap unAllowNewer . configAllowNewer) (\v flags -> flags { configAllowNewer = fmap AllowNewer v}) (optArg "DEPS" - (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser) + (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser) (Just RelaxDepsAll) relaxDepsPrinter) , option [] ["write-ghc-environment-files"] @@ -1235,7 +1229,7 @@ outdatedCommand = CommandUI { ,option [] ["ignore"] "Packages to ignore" outdatedIgnore (\v flags -> flags { outdatedIgnore = v }) - (reqArg "PKGS" pkgNameListParser (map display)) + (reqArg "PKGS" pkgNameListParser (map prettyShow)) ,option [] ["minor"] "Ignore major version bumps for these packages" @@ -1251,14 +1245,14 @@ outdatedCommand = CommandUI { ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= [] ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing] ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) = - map (Just . display) $ pkgs + map (Just . prettyShow) $ pkgs ignoreMajorVersionBumpsParser = (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser - pkgNameListParser = readP_to_E + pkgNameListParser = parsecToReadE ("Couldn't parse the list of package names: " ++) - (Parse.sepBy1 parse (Parse.char ',')) + (fmap toList (P.sepByNonEmpty parsec (P.char ','))) -- ------------------------------------------------------------ -- * Update command @@ -1480,8 +1474,8 @@ getCommand = CommandUI { ,option "s" ["source-repository"] "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)." getSourceRepository (\v flags -> flags { getSourceRepository = v }) - (optArg "[head|this|...]" (readP_to_E (const "invalid source-repository") - (fmap (toFlag . Just) parse)) + (optArg "[head|this|...]" (parsecToReadE (const "invalid source-repository") + (fmap (toFlag . Just) parsec)) (Flag Nothing) (map (fmap show) . flagToList)) @@ -1747,7 +1741,7 @@ defaultSolver :: PreSolver defaultSolver = AlwaysModular allSolvers :: String -allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver])) +allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver])) installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags , HaddockFlags, TestFlags, BenchmarkFlags @@ -2005,10 +1999,10 @@ installOptions showOrParseArgs = , option [] ["remote-build-reporting"] "Generate build reports to send to a remote server (none, anonymous or detailed)." installBuildReports (\v flags -> flags { installBuildReports = v }) - (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', " + (reqArg "LEVEL" (parsecToReadE (const $ "report level must be 'none', " ++ "'anonymous' or 'detailed'") - (toFlag `fmap` parse)) - (flagToList . fmap display)) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) , option [] ["report-planning-failure"] "Generate build reports when the dependency solver fails. This is used by the Hackage build bot." @@ -2307,32 +2301,32 @@ initOptions _ = "Specify the default language." IT.language (\v flags -> flags { IT.language = v }) - (reqArg "LANGUAGE" (readP_to_E ("Cannot parse language: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) + (reqArg "LANGUAGE" (parsecToReadE ("Cannot parse language: "++) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) , option ['o'] ["expose-module"] "Export a module from the package." IT.exposedModules (\v flags -> flags { IT.exposedModules = v }) - (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++) - ((Just . (:[])) `fmap` parse)) - (maybe [] (fmap display))) + (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++) + ((Just . (:[])) `fmap` parsec)) + (maybe [] (fmap prettyShow))) , option [] ["extension"] "Use a LANGUAGE extension (in the other-extensions field)." IT.otherExts (\v flags -> flags { IT.otherExts = v }) - (reqArg "EXTENSION" (readP_to_E ("Cannot parse extension: "++) - ((Just . (:[])) `fmap` parse)) - (maybe [] (fmap display))) + (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++) + ((Just . (:[])) `fmap` parsec)) + (maybe [] (fmap prettyShow))) , option ['d'] ["dependency"] "Package dependency." IT.dependencies (\v flags -> flags { IT.dependencies = v }) - (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++) - ((Just . (:[])) `fmap` parse)) - (maybe [] (fmap display))) + (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++) + ((Just . (:[])) `fmap` parsec)) + (maybe [] (fmap prettyShow))) , option [] ["application-dir"] "Directory containing package application executable." @@ -2415,9 +2409,9 @@ actAsSetupCommand = CommandUI { [option "" ["build-type"] "Use the given build type." actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v }) - (reqArg "BUILD-TYPE" (readP_to_E ("Cannot parse build type: "++) - (fmap toFlag parse)) - (map display . flagToList)) + (reqArg "BUILD-TYPE" (parsecToReadE ("Cannot parse build type: "++) + (fmap toFlag parsec)) + (map prettyShow . flagToList)) ] } @@ -2578,11 +2572,11 @@ optionSolver :: (flags -> Flag PreSolver) -> OptionField flags optionSolver get set = option [] ["solver"] - ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ".") + ("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".") get set - (reqArg "SOLVER" (readP_to_E (const $ "solver must be one of: " ++ allSolvers) - (toFlag `fmap` parse)) - (flagToList . fmap display)) + (reqArg "SOLVER" (parsecToReadE (const $ "solver must be one of: " ++ allSolvers) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) optionSolverFlags :: ShowOrParseArgs -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) @@ -2602,7 +2596,7 @@ optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc [ option [] ["max-backjumps"] ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") getmbj setmbj - (reqArg "NUM" (readP_to_E ("Cannot parse number: "++) (fmap toFlag parse)) + (reqArg "NUM" (parsecToReadE ("Cannot parse number: "++) (fmap toFlag P.signedIntegral)) (map show . flagToList)) , option [] ["reorder-goals"] "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." @@ -2651,10 +2645,10 @@ optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc getoc setoc (reqArg "none|all" - (readP_to_E + (parsecToReadE (const "reject-unconstrained-dependencies must be 'none' or 'all'") - (toFlag `fmap` parse)) - (flagToList . fmap display)) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) ] diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs index 4659f11e64a..604c134481f 100644 --- a/cabal-install/Distribution/Client/Targets.hs +++ b/cabal-install/Distribution/Client/Targets.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} @@ -50,8 +50,6 @@ module Distribution.Client.Targets ( import Prelude () import Distribution.Client.Compat.Prelude -import Distribution.Deprecated.ParseUtils (parseFlagAssignment) - import Distribution.Package ( Package(..), PackageName, unPackageName, mkPackageName , packageName ) @@ -79,13 +77,15 @@ import Distribution.Types.PackageVersionConstraint ( PackageVersionConstraint (..) ) import Distribution.PackageDescription - ( GenericPackageDescription, nullFlagAssignment) + ( GenericPackageDescription ) +import Distribution.Types.Flag + ( nullFlagAssignment, parsecFlagAssignmentNonEmpty, describeFlagAssignment ) import Distribution.Version - ( anyVersion, isAnyVersion ) -import Distribution.Deprecated.Text - ( Text(..), display ) + ( VersionRange, anyVersion, isAnyVersion ) +import Distribution.Pretty (Pretty (..), prettyShow) +import Distribution.Parsec (Parsec (..), CabalParsing, explicitEitherParsec, eitherParsec) +import Distribution.FieldGrammar.Described (Described (..), GrammarRegex (..)) import Distribution.Verbosity (Verbosity) -import Distribution.Parsec (eitherParsec) import Distribution.Simple.Utils ( die', warn, lowercase ) @@ -99,11 +99,7 @@ import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS import qualified Distribution.Client.GZipUtils as GZipUtils import Control.Monad (mapM) -import qualified Distribution.Deprecated.ReadP as Parse -import Distribution.Deprecated.ReadP - ( (+++), (<++) ) -import Distribution.Deprecated.ParseUtils - ( readPToMaybe ) +import qualified Distribution.Compat.CharParsing as P import System.FilePath ( takeExtension, dropExtension, takeDirectory, splitPath ) import System.Directory @@ -560,7 +556,7 @@ reportPackageTargetProblems verbosity problems = do , not (isUserTagetWorld originalTarget) ] of [] -> return () pkgs -> die' verbosity $ unlines - [ "There is no package named '" ++ display name ++ "'. " + [ "There is no package named '" ++ prettyShow name ++ "'. " | name <- pkgs ] ++ "You may need to run 'cabal update' to get the latest " ++ "list of available packages." @@ -568,11 +564,11 @@ reportPackageTargetProblems verbosity problems = do case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of [] -> return () ambiguities -> die' verbosity $ unlines - [ "There is no package named '" ++ display name ++ "'. " + [ "There is no package named '" ++ prettyShow name ++ "'. " ++ (if length matches > 1 then "However, the following package names exist: " else "However, the following package name exists: ") - ++ intercalate ", " [ "'" ++ display m ++ "'" | m <- matches] + ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches] ++ "." | (name, matches) <- ambiguities ] @@ -581,7 +577,7 @@ reportPackageTargetProblems verbosity problems = do pkgs -> warn verbosity $ "The following 'world' packages will be ignored because " ++ "they refer to packages that cannot be found: " - ++ intercalate ", " (map display pkgs) ++ "\n" + ++ intercalate ", " (map prettyShow pkgs) ++ "\n" ++ "You can suppress this warning by correcting the world file." where isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False @@ -709,69 +705,83 @@ userToPackageConstraint (UserConstraint scope prop) = readUserConstraint :: String -> Either String UserConstraint readUserConstraint str = - case readPToMaybe parse str of - Nothing -> Left msgCannotParse - Just c -> Right c + case explicitEitherParsec parsec str of + Left err -> Left $ msgCannotParse ++ err + Right c -> Right c where msgCannotParse = "expected a (possibly qualified) package name followed by a " ++ "constraint, which is either a version range, 'installed', " ++ - "'source', 'test', 'bench', or flags" + "'source', 'test', 'bench', or flags. " -instance Text UserConstraint where - disp (UserConstraint scope prop) = +instance Pretty UserConstraint where + pretty (UserConstraint scope prop) = dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop - parse = - let parseConstraintScope :: Parse.ReadP a UserConstraintScope - parseConstraintScope = - do - _ <- Parse.string "any." - pn <- parse - return (UserAnyQualifier pn) - +++ - do - _ <- Parse.string "setup." - pn <- parse - return (UserAnySetupQualifier pn) - +++ - do - -- Qualified name - pn <- parse - (return (UserQualified UserQualToplevel pn) - +++ - do _ <- Parse.string ":setup." - pn2 <- parse - return (UserQualified (UserQualSetup pn) pn2)) - - -- -- TODO: Re-enable parsing of UserQualExe once we decide on a syntax. - -- - -- +++ - -- do _ <- Parse.string ":" - -- pn2 <- parse - -- _ <- Parse.string ":exe." - -- pn3 <- parse - -- return (UserQualExe pn pn2, pn3) - in do - scope <- parseConstraintScope - - -- Package property - let keyword str x = Parse.skipSpaces1 >> Parse.string str >> return x - prop <- ((parse >>= return . PackagePropertyVersion) - +++ - keyword "installed" PackagePropertyInstalled - +++ - keyword "source" PackagePropertySource - +++ - keyword "test" (PackagePropertyStanzas [TestStanzas]) - +++ - keyword "bench" (PackagePropertyStanzas [BenchStanzas])) - -- Note: the parser is left-biased here so that we - -- don't get an ambiguous parse from 'installed', - -- 'source', etc. being regarded as flags. - <++ - (Parse.skipSpaces1 >> parseFlagAssignment - >>= return . PackagePropertyFlags) - - -- Result - return (UserConstraint scope prop) +instance Described UserConstraint where + describe _ = REAppend + [ describeConstraintScope + , describeConstraintProperty + ] + where + describeConstraintScope :: GrammarRegex void + describeConstraintScope = REUnion + [ fromString "any." <> describePN + , fromString "setup." <> describePN + , describePN + , describePN <> fromString ":setup." <> describePN + ] + + describeConstraintProperty :: GrammarRegex void + describeConstraintProperty = REUnion + -- TODO: change first to RESpaces when -any and -none are removed + [ RESpaces1 <> RENamed "version-range" (describe (Proxy :: Proxy VersionRange)) + , RESpaces1 <> describeConstraintProperty' + ] + + describeConstraintProperty' :: GrammarRegex void + describeConstraintProperty' = REUnion + [ fromString "installed" + , fromString "source" + , fromString "test" + , fromString "bench" + , describeFlagAssignment + ] + + describePN :: GrammarRegex void + describePN = RENamed "package-name" (describe (Proxy :: Proxy PackageName)) + +instance Parsec UserConstraint where + parsec = do + scope <- parseConstraintScope + P.spaces + prop <- P.choice + [ PackagePropertyFlags <$> parsecFlagAssignmentNonEmpty -- headed by "+-" + , PackagePropertyVersion <$> parsec -- headed by "<=>" (will be) + , PackagePropertyInstalled <$ P.string "installed" + , PackagePropertySource <$ P.string "source" + , PackagePropertyStanzas [TestStanzas] <$ P.string "test" + , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench" + ] + return (UserConstraint scope prop) + + where + parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope + parseConstraintScope = do + pn <- parsec + P.choice + [ P.char '.' *> withDot pn + , P.char ':' *> withColon pn + , return (UserQualified UserQualToplevel pn) + ] + where + withDot :: PackageName -> m UserConstraintScope + withDot pn + | pn == mkPackageName "any" = UserAnyQualifier <$> parsec + | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec + | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn + + withColon :: PackageName -> m UserConstraintScope + withColon pn = UserQualified (UserQualSetup pn) + <$ P.string "setup." + <*> parsec diff --git a/cabal-install/Distribution/Deprecated/ParseUtils.hs b/cabal-install/Distribution/Deprecated/ParseUtils.hs index 0d8ebaf59f6..9a9f1d14fd0 100644 --- a/cabal-install/Distribution/Deprecated/ParseUtils.hs +++ b/cabal-install/Distribution/Deprecated/ParseUtils.hs @@ -39,7 +39,7 @@ module Distribution.Deprecated.ParseUtils ( optsField, liftField, boolField, parseQuoted, parseMaybeQuoted, readPToMaybe, - fieldParsec, + fieldParsec, commaNewLineListFieldParsec, UnrecFieldParser, warnUnrec, ignoreUnrec, ) where @@ -69,7 +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) +import Distribution.Parsec (ParsecParser, explicitEitherParsec, parsecLeadingCommaList) -- ----------------------------------------------------------------------------- @@ -231,6 +231,15 @@ commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b commaNewLineListField = commaListFieldWithSep sep +commaNewLineListFieldParsec + :: String -> (a -> Doc) -> ParsecParser a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaNewLineListFieldParsec name showF readF get set = liftField get set' $ + fieldParsec name showF' (parsecLeadingCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = sep . punctuate comma . map showF + spaceListField :: String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b spaceListField name showF readF get set = diff --git a/cabal-install/Distribution/Solver/Types/Settings.hs b/cabal-install/Distribution/Solver/Types/Settings.hs index c8a4f7e99fc..3ec49cd242f 100644 --- a/cabal-install/Distribution/Solver/Types/Settings.hs +++ b/cabal-install/Distribution/Solver/Types/Settings.hs @@ -19,10 +19,10 @@ import Distribution.Simple.Setup ( BooleanFlag(..) ) import Distribution.Compat.Binary (Binary) import Distribution.Utils.Structured (Structured) import Distribution.Pretty ( Pretty(pretty) ) -import Distribution.Deprecated.Text ( Text(parse) ) +import Distribution.Parsec ( Parsec(parsec) ) import GHC.Generics (Generic) -import qualified Distribution.Deprecated.ReadP as Parse +import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as PP newtype ReorderGoals = ReorderGoals Bool @@ -90,12 +90,12 @@ instance Structured OnlyConstrained instance Structured SolveExecutables instance Pretty OnlyConstrained where - pretty OnlyConstrainedAll = PP.text "all" + pretty OnlyConstrainedAll = PP.text "all" pretty OnlyConstrainedNone = PP.text "none" -instance Text OnlyConstrained where - parse = Parse.choice - [ Parse.string "all" >> return OnlyConstrainedAll - , Parse.string "none" >> return OnlyConstrainedNone +instance Parsec OnlyConstrained where + parsec = P.choice + [ P.string "all" >> return OnlyConstrainedAll + , P.string "none" >> return OnlyConstrainedNone ] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 74ec79b0469..162c555bdbd 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -22,6 +22,7 @@ import Prelude () import Distribution.Simple.InstallDirs import Distribution.Simple.Setup +import Distribution.Types.Flag (mkFlagAssignment) import Distribution.Utils.NubList @@ -31,8 +32,11 @@ import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState) import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp) import Distribution.Client.InstallSymlink (OverwritePolicy) +import Distribution.Client.Targets import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy) import Distribution.Client.Types.AllowNewer +import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..)) +import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) import Test.QuickCheck import Test.QuickCheck.Instances.Cabal () @@ -204,6 +208,10 @@ instance Arbitrary OverwritePolicy where instance Arbitrary InstallMethod where arbitrary = arbitraryBoundedEnum +------------------------------------------------------------------------------- +-- ActiveRepos +------------------------------------------------------------------------------- + instance Arbitrary ActiveRepos where arbitrary = ActiveRepos <$> shortListOf 5 arbitrary @@ -217,6 +225,9 @@ instance Arbitrary CombineStrategy where arbitrary = arbitraryBoundedEnum shrink = shrinkBoundedEnum +------------------------------------------------------------------------------- +-- AllowNewer +------------------------------------------------------------------------------- instance Arbitrary AllowNewer where arbitrary = AllowNewer <$> arbitrary @@ -246,3 +257,35 @@ instance Arbitrary RelaxDepSubject where instance Arbitrary RelaxedDep where arbitrary = RelaxedDep <$> arbitrary <*> arbitrary <*> arbitrary + +------------------------------------------------------------------------------- +-- UserConstraint +------------------------------------------------------------------------------- + +instance Arbitrary UserConstraintScope where + arbitrary = oneof [ UserQualified <$> arbitrary <*> arbitrary + , UserAnySetupQualifier <$> arbitrary + , UserAnyQualifier <$> arbitrary + ] + +instance Arbitrary UserQualifier where + arbitrary = oneof [ pure UserQualToplevel + , UserQualSetup <$> arbitrary + + -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. + -- , UserQualExe <$> arbitrary <*> arbitrary + ] + +instance Arbitrary UserConstraint where + arbitrary = UserConstraint <$> arbitrary <*> arbitrary + +instance Arbitrary PackageProperty where + arbitrary = oneof [ PackagePropertyVersion <$> arbitrary + , pure PackagePropertyInstalled + , pure PackagePropertySource + , PackagePropertyFlags . mkFlagAssignment <$> shortListOf1 3 arbitrary + , PackagePropertyStanzas . (\x->[x]) <$> arbitrary + ] + +instance Arbitrary OptionalStanza where + arbitrary = elements [minBound..maxBound] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Described.hs b/cabal-install/tests/UnitTests/Distribution/Client/Described.hs index 1b76805de50..aeb8c0c5f68 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Described.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Described.hs @@ -20,6 +20,7 @@ import qualified Distribution.Utils.CharSet as CS import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepos) import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState) import Distribution.Client.IndexUtils.Timestamp (Timestamp) +import Distribution.Client.Targets (UserConstraint) import Distribution.Client.Types (RepoName) import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep) @@ -39,6 +40,7 @@ tests = testGroup "Described" , testDescribed (Proxy :: Proxy RelaxDepSubject) , testDescribed (Proxy :: Proxy RelaxedDep) , testDescribed (Proxy :: Proxy RelaxDeps) + , testDescribed (Proxy :: Proxy UserConstraint) ] ------------------------------------------------------------------------------- diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 221065d119d..0a10705c212 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -40,7 +40,6 @@ import Distribution.Utils.NubList import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.Settings import Distribution.Client.ProjectConfig @@ -786,34 +785,6 @@ instance Arbitrary LocalRepo where <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths <*> arbitrary -instance Arbitrary UserConstraintScope where - arbitrary = oneof [ UserQualified <$> arbitrary <*> arbitrary - , UserAnySetupQualifier <$> arbitrary - , UserAnyQualifier <$> arbitrary - ] - -instance Arbitrary UserQualifier where - arbitrary = oneof [ pure UserQualToplevel - , UserQualSetup <$> arbitrary - - -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. - -- , UserQualExe <$> arbitrary <*> arbitrary - ] - -instance Arbitrary UserConstraint where - arbitrary = UserConstraint <$> arbitrary <*> arbitrary - -instance Arbitrary PackageProperty where - arbitrary = oneof [ PackagePropertyVersion <$> arbitrary - , pure PackagePropertyInstalled - , pure PackagePropertySource - , PackagePropertyFlags . mkFlagAssignment <$> shortListOf1 3 arbitrary - , PackagePropertyStanzas . (\x->[x]) <$> arbitrary - ] - -instance Arbitrary OptionalStanza where - arbitrary = elements [minBound..maxBound] - instance Arbitrary PreSolver where arbitrary = elements [minBound..maxBound] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs index fd0fecc065e..0e4e93b8aab 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs @@ -9,9 +9,7 @@ import Distribution.Package (mkPackageName) import Distribution.PackageDescription (mkFlagName, mkFlagAssignment) import Distribution.Version (anyVersion, thisVersion, mkVersion) -import Distribution.Deprecated.ReadP (readP_to_S) -import Distribution.Deprecated.ParseUtils (parseCommaList) -import Distribution.Deprecated.Text (parse) +import Distribution.Parsec (explicitEitherParsec, parsec, parsecCommaList) import Distribution.Solver.Types.PackageConstraint (PackageProperty(..)) import Distribution.Solver.Types.OptionalStanza (OptionalStanza(..)) @@ -19,7 +17,6 @@ import Distribution.Solver.Types.OptionalStanza (OptionalStanza(..)) import Test.Tasty import Test.Tasty.HUnit -import Data.Char (isSpace) import Data.List (intercalate) -- Helper function: makes a test group by mapping each element @@ -51,7 +48,7 @@ exampleConstraints = UserConstraint (UserQualified UserQualToplevel (pn "template-haskell")) PackagePropertyInstalled) - , ("bytestring -any", + , ("bytestring >= 0", UserConstraint (UserQualified UserQualToplevel (pn "bytestring")) (PackagePropertyVersion anyVersion)) @@ -67,7 +64,8 @@ exampleConstraints = UserConstraint (UserQualified (UserQualSetup (pn "process")) (pn "bytestring")) (PackagePropertyVersion (thisVersion (mkVersion [5, 2])))) - , ("network:setup.containers +foo -bar baz", + -- flag MUST be prefixed with - or + + , ("network:setup.containers +foo -bar +baz", UserConstraint (UserQualified (UserQualSetup (pn "network")) (pn "containers")) (PackagePropertyFlags (mkFlagAssignment [(fn "foo", True), @@ -95,14 +93,12 @@ parseUserConstraintTest :: String -> UserConstraint -> Assertion parseUserConstraintTest str uc = assertEqual ("Couldn't parse constraint: '" ++ str ++ "'") expected actual where - expected = [uc] - actual = [ x | (x, ys) <- readP_to_S parse str - , all isSpace ys] + expected = Right uc + actual = explicitEitherParsec parsec str readUserConstraintsTest :: String -> [UserConstraint] -> Assertion readUserConstraintsTest str ucs = assertEqual ("Couldn't read constraints: '" ++ str ++ "'") expected actual where - expected = [ucs] - actual = [ x | (x, ys) <- readP_to_S (parseCommaList parse) str - , all isSpace ys] + expected = Right ucs + actual = explicitEitherParsec (parsecCommaList parsec) str From 301827e89666daf52fb47d79ec9c486763a1162b Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 11 May 2020 18:08:55 +0300 Subject: [PATCH 2/4] Use Pretty in D.S.T.PackagePath --- .../Distribution/Solver/Types/PackagePath.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/cabal-install/Distribution/Solver/Types/PackagePath.hs b/cabal-install/Distribution/Solver/Types/PackagePath.hs index 9bf90752884..b7c0683dfe0 100644 --- a/cabal-install/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install/Distribution/Solver/Types/PackagePath.hs @@ -10,7 +10,7 @@ module Distribution.Solver.Types.PackagePath ) where import Distribution.Package -import Distribution.Deprecated.Text +import Distribution.Pretty (pretty, flatStyle) import qualified Text.PrettyPrint as Disp import Distribution.Solver.Compat.Prelude ((<<>>)) @@ -35,7 +35,7 @@ data Namespace = -- ends in a period, so it can be prepended onto a qualifier. dispNamespace :: Namespace -> Disp.Doc dispNamespace DefaultNamespace = Disp.empty -dispNamespace (Independent i) = disp i <<>> Disp.text "." +dispNamespace (Independent i) = pretty i <<>> Disp.text "." -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = @@ -79,10 +79,10 @@ data Qualifier = -- 'Base' qualifier, will always be @base@). dispQualifier :: Qualifier -> Disp.Doc dispQualifier QualToplevel = Disp.empty -dispQualifier (QualSetup pn) = disp pn <<>> Disp.text ":setup." -dispQualifier (QualExe pn pn2) = disp pn <<>> Disp.text ":" <<>> - disp pn2 <<>> Disp.text ":exe." -dispQualifier (QualBase pn) = disp pn <<>> Disp.text "." +dispQualifier (QualSetup pn) = pretty pn <<>> Disp.text ":setup." +dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> + pretty pn2 <<>> Disp.text ":exe." +dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a @@ -94,7 +94,7 @@ type QPN = Qualified PackageName -- | Pretty-prints a qualified package name. dispQPN :: QPN -> Disp.Doc dispQPN (Q (PackagePath ns qual) pn) = - dispNamespace ns <<>> dispQualifier qual <<>> disp pn + dispNamespace ns <<>> dispQualifier qual <<>> pretty pn -- | String representation of a qualified package name. showQPN :: QPN -> String From fa57ddb559c0934bba1e0b5d375443db869ad2f5 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 12 May 2020 10:27:14 +0300 Subject: [PATCH 3/4] Remove commented out instances --- cabal-install/Distribution/Deprecated/Text.hs | 28 ------------------- 1 file changed, 28 deletions(-) diff --git a/cabal-install/Distribution/Deprecated/Text.hs b/cabal-install/Distribution/Deprecated/Text.hs index 27e8b43dccd..8fbe33ea361 100644 --- a/cabal-install/Distribution/Deprecated/Text.hs +++ b/cabal-install/Distribution/Deprecated/Text.hs @@ -379,31 +379,3 @@ ident = liftM2 (:) firstChar rest validModuleChar :: Char -> Bool validModuleChar c = isAlphaNum c || c == '_' || c == '\'' - -------------------------------------------------------------------------------- --- Rest of instances, we don't seem to need -------------------------------------------------------------------------------- - --- instance Text D.AbiDependency --- instance Text D.AbiHash --- instance Text D.AbiTa --- instance Text D.BenchmarkType --- instance Text D.ExecutableScope --- instance Text D.ExeDependency --- instance Text D.ExposedModule --- instance Text D.ForeignLibOption --- instance Text D.ForeignLibType --- instance Text D.IncludeRenaming --- instance Text D.KnownExtension --- instance Text D.LegacyExeDependency --- instance Text D.LibVersionInfo --- instance Text D.License --- instance Text D.Mixin --- instance Text D.ModuleReexport --- instance Text D.ModuleRenaming --- instance Text D.MungedPackageName --- instance Text D.OpenModule --- instance Text D.OpenUnitId --- instance Text D.PackageVersionConstraint --- instance Text D.PkgconfigDependency --- instance Text D.TestType From 492f74635cf703005f8d499e3296227681fbe07a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 12 May 2020 10:44:07 +0300 Subject: [PATCH 4/4] Remove few more Text instances --- .../Client/BuildReports/Anonymous.hs | 6 +++-- cabal-install/Distribution/Client/Config.hs | 9 ++++--- cabal-install/Distribution/Client/Get.hs | 25 +++++++++---------- .../Distribution/Client/ProjectPlanOutput.hs | 24 +++++++++--------- .../Distribution/Client/SetupWrapper.hs | 17 ++++++------- .../Distribution/Deprecated/ParseUtils.hs | 7 +++++- cabal-install/Distribution/Deprecated/Text.hs | 24 ------------------ 7 files changed, 48 insertions(+), 64 deletions(-) diff --git a/cabal-install/Distribution/Client/BuildReports/Anonymous.hs b/cabal-install/Distribution/Client/BuildReports/Anonymous.hs index 0b07f01339c..83c68d02212 100644 --- a/cabal-install/Distribution/Client/BuildReports/Anonymous.hs +++ b/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 }) diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 4f790bb2f64..acdce45a0aa 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/Get.hs b/cabal-install/Distribution/Client/Get.hs index bac80071093..26099e2c397 100644 --- a/cabal-install/Distribution/Client/Get.hs +++ b/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) $ diff --git a/cabal-install/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/Distribution/Client/ProjectPlanOutput.hs index 058a1e9ae1e..062abb615ee 100644 --- a/cabal-install/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/Distribution/Client/ProjectPlanOutput.hs @@ -44,7 +44,7 @@ import Distribution.Simple.GHC ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles) , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile , writeGhcEnvironmentFile ) -import Distribution.Deprecated.Text +import Distribution.Pretty (Pretty, prettyShow) import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, Node) import qualified Distribution.Compat.Binary as Binary @@ -236,19 +236,19 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ["bin-file" J..= J.String bin] where bin = if elabBuildStyle elab == BuildInplaceOnly - then dist_dir "build" display s display s - else InstallDirs.bindir (elabInstallDirs elab) display s + then dist_dir "build" prettyShow s prettyShow s + else InstallDirs.bindir (elabInstallDirs elab) prettyShow s -- TODO: maybe move this helper to "ComponentDeps" module? -- Or maybe define a 'Text' instance? comp2str :: ComponentDeps.Component -> String comp2str c = case c of ComponentDeps.ComponentLib -> "lib" - ComponentDeps.ComponentSubLib s -> "lib:" <> display s - ComponentDeps.ComponentFLib s -> "flib:" <> display s - ComponentDeps.ComponentExe s -> "exe:" <> display s - ComponentDeps.ComponentTest s -> "test:" <> display s - ComponentDeps.ComponentBench s -> "bench:" <> display s + ComponentDeps.ComponentSubLib s -> "lib:" <> prettyShow s + ComponentDeps.ComponentFLib s -> "flib:" <> prettyShow s + ComponentDeps.ComponentExe s -> "exe:" <> prettyShow s + ComponentDeps.ComponentTest s -> "test:" <> prettyShow s + ComponentDeps.ComponentBench s -> "bench:" <> prettyShow s ComponentDeps.ComponentSetup -> "setup" style2str :: Bool -> BuildStyle -> String @@ -256,8 +256,8 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = style2str False BuildInplaceOnly = "inplace" style2str False BuildAndInstall = "global" - jdisplay :: Text a => a -> J.Value - jdisplay = J.String . display + jdisplay :: Pretty a => a -> J.Value + jdisplay = J.String . prettyShow ----------------------------------------------------------------------------- @@ -692,7 +692,7 @@ updatePostBuildProjectStatus verbosity distDirLayout return currentBuildStatus where - displayPackageIdSet = intercalate ", " . map display . Set.toList + displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList -- | Helper for reading the cache file. -- @@ -836,7 +836,7 @@ argsEquivalentOfGhcEnvironmentFileGhc selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan -- TODO use proper flags? but packageDbArgsDb is private clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"] - packageIdFlag uid = ["-package-id", display uid] + packageIdFlag uid = ["-package-id", prettyShow uid] -- We're producing an environment for users to use in ghci, so of course diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs index 4f4cdf003bd..4aae534a17b 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/Distribution/Client/SetupWrapper.hs @@ -100,8 +100,7 @@ import Distribution.Client.Utils import Distribution.ReadE import Distribution.System ( Platform(..), buildPlatform ) -import Distribution.Deprecated.Text - ( display ) +import Distribution.Pretty (prettyShow) import Distribution.Utils.NubList ( toNubListR ) import Distribution.Verbosity @@ -477,7 +476,7 @@ runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do selfExecSetupMethod :: SetupRunner selfExecSetupMethod verbosity options bt args0 = do let args = ["act-as-setup", - "--build-type=" ++ display bt, + "--build-type=" ++ prettyShow bt, "--"] ++ args0 info verbosity $ "Using self-exec internal setup method with build-type " ++ show bt ++ " and args:\n " ++ show args @@ -570,7 +569,7 @@ getExternalSetupMethod verbosity options pkg bt = do ++ show (useDependenciesExclusive options) createDirectoryIfMissingVerbose verbosity True setupDir (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse - debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion + debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion path <- if useCachedSetupExecutable then getCachedSetupExecutable options' cabalLibVersion mCabalLibInstalledPkgId @@ -728,9 +727,9 @@ getExternalSetupMethod verbosity options pkg bt = do cabalDepVersion = useCabalVersion options' options'' = options' { usePackageIndex = Just index } case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of - [] -> die' verbosity $ "The package '" ++ display (packageName pkg) + [] -> die' verbosity $ "The package '" ++ prettyShow (packageName pkg) ++ "' requires Cabal library version " - ++ display (useCabalVersion options) + ++ prettyShow (useCabalVersion options) ++ " but no suitable version is installed." pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs err = error "Distribution.Client.installedCabalVersion: empty version list" @@ -799,11 +798,11 @@ getExternalSetupMethod verbosity options pkg bt = do return (setupCacheDir, cachedSetupProgFile) where buildTypeString = show bt - cabalVersionString = "Cabal-" ++ (display cabalLibVersion) - compilerVersionString = display $ + cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion + compilerVersionString = prettyShow $ maybe buildCompilerId compilerId $ useCompiler options' - platformString = display platform + platformString = prettyShow platform -- | Look up the setup executable in the cache; update the cache if the setup -- executable is not found. diff --git a/cabal-install/Distribution/Deprecated/ParseUtils.hs b/cabal-install/Distribution/Deprecated/ParseUtils.hs index 9a9f1d14fd0..f46af096e54 100644 --- a/cabal-install/Distribution/Deprecated/ParseUtils.hs +++ b/cabal-install/Distribution/Deprecated/ParseUtils.hs @@ -39,7 +39,7 @@ module Distribution.Deprecated.ParseUtils ( optsField, liftField, boolField, parseQuoted, parseMaybeQuoted, readPToMaybe, - fieldParsec, commaNewLineListFieldParsec, + fieldParsec, simpleFieldParsec, commaNewLineListFieldParsec, UnrecFieldParser, warnUnrec, ignoreUnrec, ) where @@ -214,6 +214,11 @@ simpleField :: String -> (a -> Doc) -> ReadP a a simpleField name showF readF get set = liftField get set $ field name showF readF +simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleFieldParsec name showF readF get set + = liftField get set $ fieldParsec name showF readF + commaListFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b commaListFieldWithSep separator name showF readF get set = diff --git a/cabal-install/Distribution/Deprecated/Text.hs b/cabal-install/Distribution/Deprecated/Text.hs index 8fbe33ea361..35e24b3fc04 100644 --- a/cabal-install/Distribution/Deprecated/Text.hs +++ b/cabal-install/Distribution/Deprecated/Text.hs @@ -45,7 +45,6 @@ import qualified Distribution.PackageDescription as D import qualified Distribution.Simple.Setup as D import qualified Distribution.System as D import qualified Distribution.Types.PackageVersionConstraint as D -import qualified Distribution.Types.SourceRepo as D import qualified Distribution.Types.UnqualComponentName as D import qualified Distribution.Version as D import qualified Language.Haskell.Extension as E @@ -97,9 +96,6 @@ instance Text Bool where , (Parse.string "False" Parse.+++ Parse.string "false") >> return False ] -instance Text Int where - parse = fmap negate (Parse.char '-' >> parseNat) Parse.+++ parseNat - instance Text a => Text (Identity a) where disp = disp . runIdentity parse = fmap Identity parse @@ -123,20 +119,6 @@ instance Text Version where -- Instances ------------------------------------------------------------------------------- -instance Text D.Arch where - parse = fmap (D.classifyArch D.Strict) ident - -instance Text D.BuildType where - parse = do - name <- Parse.munch1 isAlphaNum - case name of - "Simple" -> return D.Simple - "Configure" -> return D.Configure - "Custom" -> return D.Custom - "Make" -> return D.Make - "Default" -> return D.Custom - _ -> fail ("unknown build-type: '" ++ name ++ "'") - instance Text D.CompilerFlavor where parse = do comp <- Parse.munch1 isAlphaNum @@ -275,12 +257,6 @@ instance Text D.Platform where where firstChar = Parse.satisfy isAlpha rest = Parse.munch (\c -> isAlphaNum c || c == '_') -instance Text D.RepoKind where - parse = fmap D.classifyRepoKind ident - -instance Text D.RepoType where - parse = fmap D.classifyRepoType ident - instance Text D.UnqualComponentName where parse = D.mkUnqualComponentName <$> parsePackageName