Commit 702a39d4 authored by Robert Henderson's avatar Robert Henderson

Added qualifer to 'UserConstraint' data type.

Amended parsing and pretty-printing code of UserConstraint to
handle qualifiers.

Qualified constraints are now accepted on the command line, but
the solver and other subsystems currently just ignore the
qualifiers and don't do anything differently from before.
parent d2bf16ea
......@@ -13,7 +13,9 @@ import Distribution.Client.ProjectConfig
, commandLineFlagsToProjectConfig, writeProjectLocalFreezeConfig
, findProjectRoot, getProjectFileName )
import Distribution.Client.Targets
( UserConstraint(..) )
( UserQualifier(..), UserConstraint(..) )
import Distribution.Solver.Types.PackageConstraint
( PackageProperty(..) )
import Distribution.Solver.Types.ConstraintSource
( ConstraintSource(..) )
import Distribution.Client.DistDirLayout
......@@ -148,7 +150,8 @@ projectFreezeConstraints plan =
versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
versionConstraints =
Map.mapWithKey
(\p v -> [(UserConstraintVersion p v, ConstraintSourceFreeze)])
(\p v -> [(UserConstraint UserUnqualified p (PackagePropertyVersion v),
ConstraintSourceFreeze)])
versionRanges
versionRanges :: Map PackageName VersionRange
......@@ -165,7 +168,8 @@ projectFreezeConstraints plan =
flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
flagConstraints =
Map.mapWithKey
(\p f -> [(UserConstraintFlags p f, ConstraintSourceFreeze)])
(\p f -> [(UserConstraint UserUnqualified p (PackagePropertyFlags f),
ConstraintSourceFreeze)])
flagAssignments
flagAssignments :: Map PackageName FlagAssignment
......@@ -201,7 +205,7 @@ projectFreezeConstraints plan =
else Just constraints)
#endif
isVersionConstraint UserConstraintVersion{} = True
isVersionConstraint (UserConstraint _ _ (PackagePropertyVersion _)) = True
isVersionConstraint _ = False
localPackages :: Map PackageName ()
......
......@@ -248,8 +248,8 @@ freezePackages verbosity globalFlags pkgs = do
(pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig userPackageEnvironmentFile)
where
pkgIdToConstraint pkgId =
UserConstraintVersion (packageName pkgId)
(thisVersion $ packageVersion pkgId)
UserConstraint UserUnqualified (packageName pkgId)
(PackagePropertyVersion $ thisVersion (packageVersion pkgId))
createPkgEnv config = mempty { pkgEnvSavedConfig = config }
showPkgEnv = BS.Char8.pack . showPackageEnvironment
......
......@@ -42,6 +42,7 @@ module Distribution.Client.Targets (
disambiguatePackageName,
-- * User constraints
UserQualifier(..),
UserConstraint(..),
userConstraintPackageName,
readUserConstraint,
......@@ -79,13 +80,11 @@ import Distribution.Client.GlobalFlags
( RepoContext(..) )
import Distribution.PackageDescription
( GenericPackageDescription, FlagAssignment
, dispFlagAssignment, parseFlagAssignment )
( GenericPackageDescription, parseFlagAssignment )
import Distribution.PackageDescription.Parse
( readPackageDescription, parsePackageDescription, ParseResult(..) )
import Distribution.Version
( nullVersion, thisVersion, anyVersion, isAnyVersion
, VersionRange )
( nullVersion, thisVersion, anyVersion, isAnyVersion )
import Distribution.Text
( Text(..), display )
import Distribution.Verbosity (Verbosity)
......@@ -105,7 +104,6 @@ import Distribution.Compat.ReadP
( (+++), (<++) )
import Distribution.ParseUtils
( readPToMaybe )
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint
( (<+>) )
import System.FilePath
......@@ -688,31 +686,41 @@ extraPackageNameEnv names = PackageNameEnv pkgNameLookup
-- * Package constraints
-- ------------------------------------------------------------
data UserConstraint =
UserConstraintVersion PackageName VersionRange
| UserConstraintInstalled PackageName
| UserConstraintSource PackageName
| UserConstraintFlags PackageName FlagAssignment
| UserConstraintStanzas PackageName [OptionalStanza]
-- | Version of 'Qualifier' that a user may specify on the
-- command line.
data UserQualifier =
-- | Top-level dependency.
UserUnqualified
-- | Setup dependency.
| UserSetup PackageName
-- | Executable dependency.
| UserExe PackageName PackageName
deriving (Eq, Show, Generic)
instance Binary UserQualifier
fromUserQualifier :: UserQualifier -> Qualifier
fromUserQualifier UserUnqualified = Unqualified
fromUserQualifier (UserSetup name) = Setup name
fromUserQualifier (UserExe name1 name2) = Exe name1 name2
-- | Version of 'PackageConstraint' that the user can specify on
-- the command line.
data UserConstraint = UserConstraint UserQualifier PackageName PackageProperty
deriving (Eq, Show, Generic)
instance Binary UserConstraint
userConstraintPackageName :: UserConstraint -> PackageName
userConstraintPackageName uc = case uc of
UserConstraintVersion name _ -> name
UserConstraintInstalled name -> name
UserConstraintSource name -> name
UserConstraintFlags name _ -> name
UserConstraintStanzas name _ -> name
userConstraintPackageName (UserConstraint _ name _) = name
userToPackageConstraint :: UserConstraint -> PackageConstraint
userToPackageConstraint uc = case uc of
UserConstraintVersion name ver -> PackageConstraint (unqualified name) (PackagePropertyVersion ver)
UserConstraintInstalled name -> PackageConstraint (unqualified name) PackagePropertyInstalled
UserConstraintSource name -> PackageConstraint (unqualified name) PackagePropertySource
UserConstraintFlags name flags -> PackageConstraint (unqualified name) (PackagePropertyFlags flags)
UserConstraintStanzas name stanzas -> PackageConstraint (unqualified name) (PackagePropertyStanzas stanzas)
userToPackageConstraint (UserConstraint qual name prop) =
PackageConstraint (Q path name) prop
where
path = PackagePath DefaultNamespace (fromUserQualifier qual)
readUserConstraint :: String -> Either String UserConstraint
readUserConstraint str =
......@@ -725,35 +733,39 @@ readUserConstraint str =
++ "either a version range, 'installed', 'source' or flags"
instance Text UserConstraint where
disp (UserConstraintVersion pkgname verrange) = disp pkgname
<+> disp verrange
disp (UserConstraintInstalled pkgname) = disp pkgname
<+> Disp.text "installed"
disp (UserConstraintSource pkgname) = disp pkgname
<+> Disp.text "source"
disp (UserConstraintFlags pkgname flags) = disp pkgname
<+> dispFlagAssignment flags
disp (UserConstraintStanzas pkgname stanzas) = disp pkgname
<+> dispStanzas stanzas
where
dispStanzas = Disp.hsep . map (Disp.text . showStanza)
parse = parse >>= parseConstraint
where
parseConstraint pkgname =
((parse >>= return . UserConstraintVersion pkgname)
+++ (do Parse.skipSpaces1
_ <- Parse.string "installed"
return (UserConstraintInstalled pkgname))
+++ (do Parse.skipSpaces1
_ <- Parse.string "source"
return (UserConstraintSource pkgname))
+++ (do Parse.skipSpaces1
_ <- Parse.string "test"
return (UserConstraintStanzas pkgname [TestStanzas]))
+++ (do Parse.skipSpaces1
_ <- Parse.string "bench"
return (UserConstraintStanzas pkgname [BenchStanzas])))
<++ (do Parse.skipSpaces1
flags <- parseFlagAssignment
return (UserConstraintFlags pkgname flags))
disp (UserConstraint qual name prop) =
dispQualifier (fromUserQualifier qual) <<>> disp name
<+> dispPackageProperty prop
parse = do
-- Qualified name
pn <- parse
(qual, name) <- return (UserUnqualified, pn)
+++
do _ <- Parse.string ":setup."
pn2 <- parse
return (UserSetup pn, pn2)
+++
do _ <- Parse.string ":"
pn2 <- parse
_ <- Parse.string ":exe."
pn3 <- parse
return (UserExe pn pn2, pn3)
-- 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])
<++
(Parse.skipSpaces1 >> parseFlagAssignment
>>= return . PackagePropertyFlags)
-- Result
return (UserConstraint qual name prop)
......@@ -32,6 +32,7 @@ import Distribution.Client.Targets
import Distribution.Utils.NubList
import Network.URI
import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.Settings
......@@ -202,7 +203,7 @@ hackProjectConfigShared config =
projectConfigConstraints =
--TODO: [required eventually] parse ambiguity in constraint
-- "pkgname -any" as either any version or disabled flag "any".
let ambiguous ((UserConstraintFlags _pkg flags), _) =
let ambiguous (UserConstraint _ _ (PackagePropertyFlags flags), _) =
(not . null) [ () | (name, False) <- flags
, "any" `isPrefixOf` unFlagName name ]
ambiguous _ = False
......@@ -573,6 +574,16 @@ instance Arbitrary UserConstraint where
, UserConstraintStanzas <$> arbitrary <*> ((\x->[x]) <$> arbitrary)
]
instance Arbitrary UserConstraint where
arbitrary =
oneof [ UserConstraint UserUnqualified <$> arbitrary <*> prop
| prop <- [ PackagePropertyVersion <$> arbitrary
, pure PackagePropertyInstalled
, pure PackagePropertySource
, PackagePropertyFlags <$> shortListOf1 3 arbitrary
, PackagePropertyStanzas . (\x->[x]) <$> arbitrary
] ]
instance Arbitrary OptionalStanza where
arbitrary = elements [minBound..maxBound]
......
......@@ -2,12 +2,15 @@ module UnitTests.Distribution.Client.Targets (
tests
) where
import Distribution.Client.Targets (UserConstraint (..), readUserConstraint)
import Distribution.Client.Targets (UserQualifier(..), UserConstraint(..)
,readUserConstraint)
import Distribution.Compat.ReadP (ReadP, readP_to_S)
import Distribution.Package (mkPackageName)
import Distribution.ParseUtils (parseCommaList)
import Distribution.Text (parse)
import Distribution.Solver.Types.PackageConstraint (PackageProperty(..))
import Test.Tasty
import Test.Tasty.HUnit
......@@ -26,7 +29,8 @@ readUserConstraintTest =
pkgName = "template-haskell"
constr = pkgName ++ " installed"
expected = UserConstraintInstalled (mkPackageName pkgName)
expected = UserConstraint UserUnqualified (mkPackageName pkgName)
PackagePropertyInstalled
actual = let (Right r) = readUserConstraint constr in r
parseUserConstraintTest :: Assertion
......@@ -36,7 +40,8 @@ parseUserConstraintTest =
pkgName = "template-haskell"
constr = pkgName ++ " installed"
expected = [UserConstraintInstalled (mkPackageName pkgName)]
expected = [UserConstraint UserUnqualified (mkPackageName pkgName)
PackagePropertyInstalled]
actual = [ x | (x, ys) <- readP_to_S parseUserConstraint constr
, all isSpace ys]
......@@ -50,7 +55,8 @@ readUserConstraintsTest =
pkgName = "template-haskell"
constr = pkgName ++ " installed"
expected = [[UserConstraintInstalled (mkPackageName pkgName)]]
expected = [[UserConstraint UserUnqualified (mkPackageName pkgName)
PackagePropertyInstalled]]
actual = [ x | (x, ys) <- readP_to_S parseUserConstraints constr
, all isSpace ys]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment