Commit f1a4a693 authored by Oleg Grenrus's avatar Oleg Grenrus

Change Text insances into Pretty/Parsec

parent 05bbea3e
......@@ -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
......
......@@ -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)
......@@ -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
......@@ -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.
......
......@@ -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.
......
......@@ -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]
......
......@@ -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
......
......@@ -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))
]
......
{-# 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)
+++