From 39c3cb6db19301a1815f1425acb03d9485194b39 Mon Sep 17 00:00:00 2001 From: Robert Henderson Date: Fri, 6 Jan 2017 20:08:01 +0000 Subject: [PATCH 1/7] Added pretty-printing functions and 'unqualified' constructor. I modified the pretty-printing code so that it uses the 'Text.PrettyPrint' system rather than raw strings. I updated the syntax of pretty-printed qualifiers to use colons as separators rather than hyphens to fix an ambiguity problem (since hyphens can occur in package names). See issue 3502. --- .../Distribution/Solver/Types/PackagePath.hs | 61 +++++++++++-------- 1 file changed, 35 insertions(+), 26 deletions(-) diff --git a/cabal-install/Distribution/Solver/Types/PackagePath.hs b/cabal-install/Distribution/Solver/Types/PackagePath.hs index 5ba2ecac4e5..9dd010c43a3 100644 --- a/cabal-install/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install/Distribution/Solver/Types/PackagePath.hs @@ -2,13 +2,18 @@ module Distribution.Solver.Types.PackagePath ( PackagePath(..) , Namespace(..) , Qualifier(..) - , QPN + , dispQualifier , Qualified(..) + , unqualified + , QPN + , dispQPN , showQPN ) where import Distribution.Package import Distribution.Text +import qualified Text.PrettyPrint as Disp +import Distribution.Client.Compat.Prelude ((<<>>)) -- | A package path consists of a namespace and a package path inside that -- namespace. @@ -29,6 +34,12 @@ data Namespace = | Independent Int deriving (Eq, Ord, Show) +-- | Pretty-prints a namespace. The result is either empty or +-- ends in a period, so it can be prepended onto a package name. +dispNamespace :: Namespace -> Disp.Doc +dispNamespace DefaultNamespace = Disp.empty +dispNamespace (Independent i) = Disp.int i <<>> Disp.text "." + -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = -- | Top-level dependency in this namespace @@ -61,39 +72,37 @@ data Qualifier = | Exe PackageName PackageName deriving (Eq, Ord, Show) --- | String representation of a package path. +-- | Pretty-prints a qualifier. The result is either empty or +-- ends in a period, so it can be prepended onto a package name. -- --- NOTE: The result of 'showPP' is either empty or results in a period, so that --- it can be prepended to a package name. -showPP :: PackagePath -> String -showPP (PackagePath ns q) = - case ns of - DefaultNamespace -> go q - Independent i -> show i ++ "." ++ go q - where - -- Print the qualifier - -- - -- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is - -- there to make sure different dependencies on base are all independent. - -- So we want to print something like @"A.base"@, where the @"A."@ part - -- is the qualifier and @"base"@ is the actual dependency (which, for the - -- 'Base' qualifier, will always be @base@). - go Unqualified = "" - go (Setup pn) = display pn ++ "-setup." - go (Exe pn pn2) = display pn ++ "-" ++ display pn2 ++ "-exe." - go (Base pn) = display pn ++ "." +-- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is +-- there to make sure different dependencies on base are all independent. +-- So we want to print something like @"A.base"@, where the @"A."@ part +-- is the qualifier and @"base"@ is the actual dependency (which, for the +-- 'Base' qualifier, will always be @base@). +dispQualifier :: Qualifier -> Disp.Doc +dispQualifier Unqualified = Disp.empty +dispQualifier (Setup pn) = disp pn <<>> Disp.text ":setup." +dispQualifier (Exe pn pn2) = disp pn <<>> Disp.text ":" <<>> + disp pn2 <<>> Disp.text ":exe." +dispQualifier (Base pn) = disp pn <<>> Disp.text "." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a deriving (Eq, Ord, Show) --- | Standard string representation of a qualified entity. -showQ :: (a -> String) -> (Qualified a -> String) -showQ showa (Q pp x) = showPP pp ++ showa x +-- | Marks the entity as a top-level dependency in the default namespace. +unqualified :: a -> Qualified a +unqualified = Q (PackagePath DefaultNamespace Unqualified) -- | Qualified package name. type QPN = Qualified PackageName --- | String representation of a qualified package path. +-- | Pretty-prints a qualified package name. +dispQPN :: QPN -> Disp.Doc +dispQPN (Q (PackagePath ns qual) pn) = + dispNamespace ns <<>> dispQualifier qual <<>> disp pn + +-- | String representation of a qualified package name. showQPN :: QPN -> String -showQPN = showQ display +showQPN = Disp.renderStyle flatStyle . dispQPN From 79d562bfacf6f263c2120cac15f9f59855f7c2a3 Mon Sep 17 00:00:00 2001 From: Robert Henderson Date: Sat, 7 Jan 2017 14:46:35 +0000 Subject: [PATCH 2/7] Added qualifier to 'PackageConstraint' data type. Refactored PackageConstraint in two ways: 1) split it into a package name and a 'PackageProperty' to make the code a bit cleaner; 2) changed PackageName to 'Qualified PackageName'. Added a Binary instance for Qualifier in PackagePath.hs (needed for PackageConstraint). Added pretty-printing code for PackageConstraint. For now, all the code that creates a PackageConstraint just sets the qualifier to 'unqualified', so this commit will not change the external behaviour of cabal-install. --- .../Distribution/Client/Configure.hs | 8 +- .../Distribution/Client/Dependency.hs | 15 ++-- cabal-install/Distribution/Client/Freeze.hs | 3 +- cabal-install/Distribution/Client/Install.hs | 14 +-- cabal-install/Distribution/Client/List.hs | 2 +- .../Distribution/Client/ProjectPlanning.hs | 9 +- cabal-install/Distribution/Client/Targets.hs | 34 +++---- cabal-install/Distribution/Solver/Modular.hs | 7 +- .../Distribution/Solver/Modular/Preference.hs | 10 +-- .../Solver/Types/PackageConstraint.hs | 89 ++++++++++++------- .../Distribution/Solver/Types/PackagePath.hs | 19 +++- .../Distribution/Solver/Modular/DSL.hs | 5 +- 12 files changed, 133 insertions(+), 82 deletions(-) diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs index 4d4ece7bef8..006682e9c87 100644 --- a/cabal-install/Distribution/Client/Configure.hs +++ b/cabal-install/Distribution/Client/Configure.hs @@ -335,15 +335,17 @@ planLocalPackage verbosity comp platform configFlags configExFlags . addConstraints -- package flags from the config file or command line - [ let pc = PackageConstraintFlags (packageName pkg) - (configConfigurationsFlags configFlags) + [ let pc = PackageConstraint + (unqualified $ packageName pkg) + (PackagePropertyFlags $ configConfigurationsFlags configFlags) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget ] . addConstraints -- '--enable-tests' and '--enable-benchmarks' constraints from -- the config file or command line - [ let pc = PackageConstraintStanzas (packageName pkg) $ + [ let pc = PackageConstraint (unqualified $ packageName pkg) . + PackagePropertyStanzas $ [ TestStanzas | testsEnabled ] ++ [ BenchStanzas | benchmarksEnabled ] in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs index 6cfee98c804..92d9fbe3ee1 100644 --- a/cabal-install/Distribution/Client/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency.hs @@ -23,7 +23,9 @@ module Distribution.Client.Dependency ( resolveWithoutDependencies, -- * Constructing resolver policies + PackageProperty(..), PackageConstraint(..), + unqualified, PackagesPreferenceDefault(..), PackagePreference(..), @@ -346,7 +348,7 @@ dontUpgradeNonUpgradeablePackages params = where extraConstraints = [ LabeledPackageConstraint - (PackageConstraintInstalled pkgname) + (PackageConstraint (unqualified pkgname) PackagePropertyInstalled) ConstraintSourceNonUpgradeablePackage | Set.notMember (mkPackageName "base") (depResolverTargets params) -- If you change this enumeration, make sure to update the list in @@ -477,7 +479,8 @@ addSetupCabalMinVersionConstraint :: Version addSetupCabalMinVersionConstraint minVersion = addConstraints [ LabeledPackageConstraint - (PackageConstraintVersion cabalPkgname (orLaterVersion minVersion)) + (PackageConstraint (unqualified cabalPkgname) + (PackagePropertyVersion $ orLaterVersion minVersion)) ConstraintSetupCabalMinVersion ] where @@ -583,8 +586,9 @@ applySandboxInstallPolicy (thisVersion (packageVersion pkg)) | pkg <- otherDeps ] . addConstraints - [ let pc = PackageConstraintVersion (packageName pkg) - (thisVersion (packageVersion pkg)) + [ let pc = PackageConstraint + (unqualified $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep | pkg <- modifiedDeps ] @@ -925,7 +929,8 @@ resolveWithoutDependencies (DepResolverParams targets constraints packageVersionConstraintMap = let pcs = map unlabelPackageConstraint constraints in Map.fromList [ (name, range) - | PackageConstraintVersion name range <- pcs ] + | PackageConstraint + (Q _ name) (PackagePropertyVersion range) <- pcs ] packagePreferences :: PackageName -> PackagePreferences packagePreferences = interpretPackagesPreference targets defpref prefs diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs index 5ef886c59f8..607472cbc53 100644 --- a/cabal-install/Distribution/Client/Freeze.hs +++ b/cabal-install/Distribution/Client/Freeze.hs @@ -181,7 +181,8 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags . addConstraints [ let pkg = pkgSpecifierTarget pkgSpecifier - pc = PackageConstraintStanzas pkg stanzas + pc = PackageConstraint (unqualified pkg) + (PackagePropertyStanzas stanzas) in LabeledPackageConstraint pc ConstraintSourceFreeze | pkgSpecifier <- pkgSpecifiers ] diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index f263d84cc8c..f78e2040714 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -407,16 +407,18 @@ planPackages comp platform mSandboxPkgInfo solver . addConstraints --FIXME: this just applies all flags to all targets which -- is silly. We should check if the flags are appropriate - [ let pc = PackageConstraintFlags - (pkgSpecifierTarget pkgSpecifier) flags + [ let pc = PackageConstraint + (unqualified $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyFlags flags) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget | let flags = configConfigurationsFlags configFlags , not (null flags) , pkgSpecifier <- pkgSpecifiers ] . addConstraints - [ let pc = PackageConstraintStanzas - (pkgSpecifierTarget pkgSpecifier) stanzas + [ let pc = PackageConstraint + (unqualified $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyStanzas stanzas) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget | pkgSpecifier <- pkgSpecifiers ] @@ -775,8 +777,8 @@ reportPlanningFailure verbosity theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec = case pkgSpec of - NamedPackage name [PackageConstraintVersion name' version] - | name == name' -> PackageIdentifier name <$> trivialRange version + NamedPackage name [PackageConstraint name' (PackagePropertyVersion version)] + | name' == unqualified name -> PackageIdentifier name <$> trivialRange version NamedPackage _ _ -> Nothing SpecificSourcePackage pkg -> Just $ packageId pkg where diff --git a/cabal-install/Distribution/Client/List.hs b/cabal-install/Distribution/Client/List.hs index 20d032fcd5e..237589fc363 100644 --- a/cabal-install/Distribution/Client/List.hs +++ b/cabal-install/Distribution/Client/List.hs @@ -238,7 +238,7 @@ info verbosity packageDBs repoCtxt comp progdb -- supplied a non-trivial version constraint showPkgVersion = not (null verConstraints) verConstraint = foldr intersectVersionRanges anyVersion verConstraints - verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ] + verConstraints = [ vr | PackageConstraint _ (PackagePropertyVersion vr) <- constraints ] gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) = diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 33ebe979c66..5235ac27d31 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -983,7 +983,8 @@ planPackages comp platform solver SolverSettings{..} . addConstraints -- enable stanza constraints where the user asked to enable [ LabeledPackageConstraint - (PackageConstraintStanzas pkgname stanzas) + (PackageConstraint (unqualified pkgname) + (PackagePropertyStanzas stanzas)) ConstraintSourceConfigFlagOrTarget | pkg <- localPackages , let pkgname = packageName pkg @@ -997,7 +998,8 @@ planPackages comp platform solver SolverSettings{..} --TODO: [nice to have] should have checked at some point that the -- package in question actually has these flags. [ LabeledPackageConstraint - (PackageConstraintFlags pkgname flags) + (PackageConstraint (unqualified pkgname) + (PackagePropertyFlags flags)) ConstraintSourceConfigFlagOrTarget | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] @@ -1007,7 +1009,8 @@ planPackages comp platform solver SolverSettings{..} -- former we just apply all these flags to all local targets which -- is silly. We should check if the flags are appropriate. [ LabeledPackageConstraint - (PackageConstraintFlags pkgname flags) + (PackageConstraint (unqualified pkgname) + (PackagePropertyFlags flags)) ConstraintSourceConfigFlagOrTarget | let flags = solverSettingFlagAssignment , not (null flags) diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs index aedd5b08cc2..6c3d78c000e 100644 --- a/cabal-install/Distribution/Client/Targets.hs +++ b/cabal-install/Distribution/Client/Targets.hs @@ -63,6 +63,7 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.SourcePackage @@ -204,8 +205,9 @@ pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints pkgSpecifierConstraints (SpecificSourcePackage pkg) = [LabeledPackageConstraint pc ConstraintSourceUserTarget] where - pc = PackageConstraintVersion (packageName pkg) - (thisVersion (packageVersion pkg)) + pc = PackageConstraint + (unqualified $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) -- ------------------------------------------------------------ -- * Parsing and checking user targets @@ -420,7 +422,8 @@ expandUserTarget :: FilePath expandUserTarget worldFile userTarget = case userTarget of UserTargetNamed (Dependency name vrange) -> - let constraints = [ PackageConstraintVersion name vrange + let constraints = [ PackageConstraint (unqualified name) + (PackagePropertyVersion vrange) | not (isAnyVersion vrange) ] in return [PackageTargetNamedFuzzy name constraints userTarget] @@ -429,9 +432,11 @@ expandUserTarget worldFile userTarget = case userTarget of --TODO: should we warn if there are no world targets? return [ PackageTargetNamed name constraints userTarget | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs - , let constraints = [ PackageConstraintVersion name vrange + , let constraints = [ PackageConstraint (unqualified name) + (PackagePropertyVersion vrange) | not (isAnyVersion vrange) ] - ++ [ PackageConstraintFlags name flags + ++ [ PackageConstraint (unqualified name) + (PackagePropertyFlags flags) | not (null flags) ] ] UserTargetLocalDir dir -> @@ -717,21 +722,16 @@ userConstraintPackageName uc = case uc of UserConstraintStanzas name _ -> name userToPackageConstraint :: UserConstraint -> PackageConstraint --- At the moment, the types happen to be directly equivalent userToPackageConstraint uc = case uc of - UserConstraintVersion name ver -> PackageConstraintVersion name ver - UserConstraintInstalled name -> PackageConstraintInstalled name - UserConstraintSource name -> PackageConstraintSource name - UserConstraintFlags name flags -> PackageConstraintFlags name flags - UserConstraintStanzas name stanzas -> PackageConstraintStanzas name stanzas + 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) renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint -renamePackageConstraint name pc = case pc of - PackageConstraintVersion _ ver -> PackageConstraintVersion name ver - PackageConstraintInstalled _ -> PackageConstraintInstalled name - PackageConstraintSource _ -> PackageConstraintSource name - PackageConstraintFlags _ flags -> PackageConstraintFlags name flags - PackageConstraintStanzas _ stanzas -> PackageConstraintStanzas name stanzas +renamePackageConstraint name (PackageConstraint _ prop) = + PackageConstraint (unqualified name) prop readUserConstraint :: String -> Either String UserConstraint readUserConstraint str = diff --git a/cabal-install/Distribution/Solver/Modular.hs b/cabal-install/Distribution/Solver/Modular.hs index 8f71629bd5a..9061ceda192 100644 --- a/cabal-install/Distribution/Solver/Modular.hs +++ b/cabal-install/Distribution/Solver/Modular.hs @@ -31,6 +31,7 @@ import Distribution.Solver.Modular.Solver ( SolverConfig(..), solve ) import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.DependencyResolver import Distribution.System ( Platform(..) ) @@ -59,8 +60,4 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns -- Helper function to extract the PN from a constraint. pcName :: PackageConstraint -> PN - pcName (PackageConstraintVersion pn _) = pn - pcName (PackageConstraintInstalled pn ) = pn - pcName (PackageConstraintSource pn ) = pn - pcName (PackageConstraintFlags pn _) = pn - pcName (PackageConstraintStanzas pn _) = pn + pcName (PackageConstraint (Q _ pn) _) = pn diff --git a/cabal-install/Distribution/Solver/Modular/Preference.hs b/cabal-install/Distribution/Solver/Modular/Preference.hs index 04bfc40956e..7295279060e 100644 --- a/cabal-install/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install/Distribution/Solver/Modular/Preference.hs @@ -162,13 +162,13 @@ processPackageConstraintP pp _ _ (LabeledPackageConstraint _ src) r processPackageConstraintP _ c i (LabeledPackageConstraint pc src) r = go i pc where - go (I v _) (PackageConstraintVersion _ vr) + go (I v _) (PackageConstraint _ (PackagePropertyVersion vr)) | checkVR vr v = r | otherwise = Fail c (GlobalConstraintVersion vr src) - go _ (PackageConstraintInstalled _) + go _ (PackageConstraint _ PackagePropertyInstalled) | instI i = r | otherwise = Fail c (GlobalConstraintInstalled src) - go _ (PackageConstraintSource _) + go _ (PackageConstraint _ PackagePropertySource) | not (instI i) = r | otherwise = Fail c (GlobalConstraintSource src) go _ _ = r @@ -185,7 +185,7 @@ processPackageConstraintF :: Flag -> Tree d c processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r = go pc where - go (PackageConstraintFlags _ fa) = + go (PackageConstraint _ (PackagePropertyFlags fa)) = case L.lookup f fa of Nothing -> r Just b | b == b' -> r @@ -204,7 +204,7 @@ processPackageConstraintS :: OptionalStanza -> Tree d c processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc where - go (PackageConstraintStanzas _ ss) = + go (PackageConstraint _ (PackagePropertyStanzas ss)) = if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src) else r go _ = r diff --git a/cabal-install/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install/Distribution/Solver/Types/PackageConstraint.hs index 4482215ad2a..7e4911326f9 100644 --- a/cabal-install/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install/Distribution/Solver/Types/PackageConstraint.hs @@ -1,46 +1,75 @@ {-# LANGUAGE DeriveGeneric #-} + +-- | Per-package constraints. Package constraints must be respected by the +-- solver. Multiple constraints for each package can be given, though obviously +-- it is possible to construct conflicting constraints (eg impossible version +-- range or inconsistent flag assignment). +-- module Distribution.Solver.Types.PackageConstraint ( + PackageProperty(..), + dispPackageProperty, PackageConstraint(..), + dispPackageConstraint, showPackageConstraint, ) where -import Distribution.Compat.Binary (Binary(..)) -import Distribution.PackageDescription (FlagAssignment, unFlagName) -import Distribution.Package (PackageName) -import Distribution.Solver.Types.OptionalStanza -import Distribution.Text (display) import Distribution.Version (VersionRange, simplifyVersionRange) +import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath (QPN, dispQPN) + import GHC.Generics (Generic) +import Distribution.Compat.Binary (Binary) --- | Per-package constraints. Package constraints must be respected by the --- solver. Multiple constraints for each package can be given, though obviously --- it is possible to construct conflicting constraints (eg impossible version --- range or inconsistent flag assignment). --- -data PackageConstraint - = PackageConstraintVersion PackageName VersionRange - | PackageConstraintInstalled PackageName - | PackageConstraintSource PackageName - | PackageConstraintFlags PackageName FlagAssignment - | PackageConstraintStanzas PackageName [OptionalStanza] +import Distribution.Text (disp, flatStyle) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<+>)) + +-- | A package property is a logical predicate on packages. +data PackageProperty + = PackagePropertyVersion VersionRange + | PackagePropertyInstalled + | PackagePropertySource + | PackagePropertyFlags FlagAssignment + | PackagePropertyStanzas [OptionalStanza] + deriving (Eq, Show, Generic) + +instance Binary PackageProperty + +-- | Pretty-prints a package property. +dispPackageProperty :: PackageProperty -> Disp.Doc +dispPackageProperty (PackagePropertyVersion verrange) = disp verrange +dispPackageProperty PackagePropertyInstalled = Disp.text "installed" +dispPackageProperty PackagePropertySource = Disp.text "source" +dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags +dispPackageProperty (PackagePropertyStanzas stanzas) = + Disp.hsep $ map (Disp.text . showStanza) stanzas + +-- | A package constraint consists of a package plus a property +-- that must hold for that package. +data PackageConstraint = PackageConstraint QPN PackageProperty deriving (Eq, Show, Generic) instance Binary PackageConstraint --- | Provide a textual representation of a package constraint --- for debugging purposes. +-- | Pretty-prints a package constraint. +dispPackageConstraint :: PackageConstraint -> Disp.Doc +dispPackageConstraint (PackageConstraint qpn prop) = + dispQPN qpn <+> dispPackageProperty prop + +-- | Alternative textual representation of a package constraint +-- for debugging purposes (slightly more verbose than that +-- produced by 'dispPackageConstraint'). -- showPackageConstraint :: PackageConstraint -> String -showPackageConstraint (PackageConstraintVersion pn vr) = - display pn ++ " " ++ display (simplifyVersionRange vr) -showPackageConstraint (PackageConstraintInstalled pn) = - display pn ++ " installed" -showPackageConstraint (PackageConstraintSource pn) = - display pn ++ " source" -showPackageConstraint (PackageConstraintFlags pn fs) = - "flags " ++ display pn ++ " " ++ unwords (map (uncurry showFlag) fs) +showPackageConstraint pc@(PackageConstraint qpn prop) = + Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 where - showFlag f True = "+" ++ unFlagName f - showFlag f False = "-" ++ unFlagName f -showPackageConstraint (PackageConstraintStanzas pn ss) = - "stanzas " ++ display pn ++ " " ++ unwords (map showStanza ss) + pc2 = case prop of + PackagePropertyVersion vr -> + PackageConstraint qpn $ PackagePropertyVersion (simplifyVersionRange vr) + _ -> pc + postprocess = case prop of + PackagePropertyFlags _ -> (Disp.text "flags" <+>) + PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>) + _ -> id diff --git a/cabal-install/Distribution/Solver/Types/PackagePath.hs b/cabal-install/Distribution/Solver/Types/PackagePath.hs index 9dd010c43a3..ba098cc92ee 100644 --- a/cabal-install/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install/Distribution/Solver/Types/PackagePath.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.PackagePath ( PackagePath(..) , Namespace(..) @@ -14,11 +15,15 @@ import Distribution.Package import Distribution.Text import qualified Text.PrettyPrint as Disp import Distribution.Client.Compat.Prelude ((<<>>)) +import GHC.Generics (Generic) +import Distribution.Compat.Binary (Binary) -- | A package path consists of a namespace and a package path inside that -- namespace. data PackagePath = PackagePath Namespace Qualifier - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Binary PackagePath -- | Top-level namespace -- @@ -32,7 +37,9 @@ data Namespace = -- -- For now we just number these (rather than giving them more structure). | Independent Int - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Binary Namespace -- | Pretty-prints a namespace. The result is either empty or -- ends in a period, so it can be prepended onto a package name. @@ -70,7 +77,9 @@ data Qualifier = -- tracked only @pn2@, that would require us to pick only one -- version of an executable over the entire install plan.) | Exe PackageName PackageName - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Binary Qualifier -- | Pretty-prints a qualifier. The result is either empty or -- ends in a period, so it can be prepended onto a package name. @@ -89,7 +98,9 @@ dispQualifier (Base pn) = disp pn <<>> Disp.text "." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Binary a => Binary (Qualified a) -- | Marks the entity as a top-level dependency in the default namespace. unqualified :: a -> Qualified a diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index 0c45943c619..3c6ac256090 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -546,8 +546,9 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder , packagePreferences = Map.empty } enableTests - | asBool enableAllTests = fmap (\p -> PackageConstraintStanzas - (C.mkPackageName p) [TestStanzas]) + | asBool enableAllTests = fmap (\p -> PackageConstraint + (unqualified (C.mkPackageName p)) + (PackagePropertyStanzas [TestStanzas])) (exDbPkgs db) | otherwise = [] targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets From ee866975b25d4b51bb1b8d956a10ad455f71e725 Mon Sep 17 00:00:00 2001 From: Robert Henderson Date: Sat, 7 Jan 2017 15:58:57 +0000 Subject: [PATCH 3/7] Code cleanup: refactored 'PackageSpecifier' and 'PackageTarget'. Changed PackageConstraint to PackageProperty in both cases, since the name in the PackageConstraint was redundant. --- cabal-install/Distribution/Client/Install.hs | 4 +- cabal-install/Distribution/Client/List.hs | 4 +- cabal-install/Distribution/Client/Targets.hs | 61 +++++++++----------- 3 files changed, 31 insertions(+), 38 deletions(-) diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index f78e2040714..66d42a5a2cb 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -777,8 +777,8 @@ reportPlanningFailure verbosity theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec = case pkgSpec of - NamedPackage name [PackageConstraint name' (PackagePropertyVersion version)] - | name' == unqualified name -> PackageIdentifier name <$> trivialRange version + NamedPackage name [PackagePropertyVersion version] + -> PackageIdentifier name <$> trivialRange version NamedPackage _ _ -> Nothing SpecificSourcePackage pkg -> Just $ packageId pkg where diff --git a/cabal-install/Distribution/Client/List.hs b/cabal-install/Distribution/Client/List.hs index 237589fc363..751d28ef277 100644 --- a/cabal-install/Distribution/Client/List.hs +++ b/cabal-install/Distribution/Client/List.hs @@ -213,7 +213,7 @@ info verbosity packageDBs repoCtxt comp progdb PackageSpecifier UnresolvedSourcePackage -> Either String PackageDisplayInfo gatherPkgInfo prefs installedPkgIndex sourcePkgIndex - (NamedPackage name constraints) + (NamedPackage name props) | null (selectedInstalledPkgs) && null (selectedSourcePkgs) = Left $ "There is no available version of " ++ display name ++ " that satisfies " @@ -238,7 +238,7 @@ info verbosity packageDBs repoCtxt comp progdb -- supplied a non-trivial version constraint showPkgVersion = not (null verConstraints) verConstraint = foldr intersectVersionRanges anyVersion verConstraints - verConstraints = [ vr | PackageConstraint _ (PackagePropertyVersion vr) <- constraints ] + verConstraints = [ vr | PackagePropertyVersion vr <- props ] gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) = diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs index 6c3d78c000e..a260eceb3d9 100644 --- a/cabal-install/Distribution/Client/Targets.hs +++ b/cabal-install/Distribution/Client/Targets.hs @@ -181,10 +181,10 @@ data PackageSpecifier pkg = -- | A partially specified reference to a package (either source or -- installed). It is specified by package name and optionally some - -- additional constraints. Use a dependency resolver to pick a specific - -- package satisfying these constraints. + -- required properties. Use a dependency resolver to pick a specific + -- package satisfying these properties. -- - NamedPackage PackageName [PackageConstraint] + NamedPackage PackageName [PackageProperty] -- | A fully specified source package. -- @@ -199,9 +199,11 @@ pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg pkgSpecifierConstraints :: Package pkg => PackageSpecifier pkg -> [LabeledPackageConstraint] -pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints +pkgSpecifierConstraints (NamedPackage name props) = map toLpc props where - toLpc pc = LabeledPackageConstraint pc ConstraintSourceUserTarget + toLpc prop = LabeledPackageConstraint + (PackageConstraint (unqualified name) prop) + ConstraintSourceUserTarget pkgSpecifierConstraints (SpecificSourcePackage pkg) = [LabeledPackageConstraint pc ConstraintSourceUserTarget] where @@ -400,11 +402,11 @@ resolveUserTargets verbosity repoCtxt worldFile available userTargets = do -- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. -- data PackageTarget pkg = - PackageTargetNamed PackageName [PackageConstraint] UserTarget + PackageTargetNamed PackageName [PackageProperty] UserTarget -- | A package identified by name, but case insensitively, so it needs -- to be resolved to the right case-sensitive name. - | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget + | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget | PackageTargetLocation pkg deriving Show @@ -422,22 +424,19 @@ expandUserTarget :: FilePath expandUserTarget worldFile userTarget = case userTarget of UserTargetNamed (Dependency name vrange) -> - let constraints = [ PackageConstraint (unqualified name) - (PackagePropertyVersion vrange) - | not (isAnyVersion vrange) ] - in return [PackageTargetNamedFuzzy name constraints userTarget] + let props = [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) ] + in return [PackageTargetNamedFuzzy name props userTarget] UserTargetWorld -> do worldPkgs <- World.getContents worldFile --TODO: should we warn if there are no world targets? - return [ PackageTargetNamed name constraints userTarget + return [ PackageTargetNamed name props userTarget | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs - , let constraints = [ PackageConstraint (unqualified name) - (PackagePropertyVersion vrange) - | not (isAnyVersion vrange) ] - ++ [ PackageConstraint (unqualified name) - (PackagePropertyFlags flags) - | not (null flags) ] ] + , let props = [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) ] + ++ [ PackagePropertyFlags flags + | not (null flags) ] ] UserTargetLocalDir dir -> return [ PackageTargetLocation (LocalUnpackedPackage dir) ] @@ -469,8 +468,8 @@ fetchPackageTarget :: Verbosity -> PackageTarget (PackageLocation ()) -> IO (PackageTarget ResolvedPkgLoc) fetchPackageTarget verbosity repoCtxt target = case target of - PackageTargetNamed n cs ut -> return (PackageTargetNamed n cs ut) - PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut) + PackageTargetNamed n ps ut -> return (PackageTargetNamed n ps ut) + PackageTargetNamedFuzzy n ps ut -> return (PackageTargetNamedFuzzy n ps ut) PackageTargetLocation location -> do location' <- fetchPackage verbosity repoCtxt (fmap (const Nothing) location) return (PackageTargetLocation location') @@ -485,11 +484,11 @@ readPackageTarget :: Verbosity -> IO (PackageTarget UnresolvedSourcePackage) readPackageTarget verbosity target = case target of - PackageTargetNamed pkgname constraints userTarget -> - return (PackageTargetNamed pkgname constraints userTarget) + PackageTargetNamed pkgname props userTarget -> + return (PackageTargetNamed pkgname props userTarget) - PackageTargetNamedFuzzy pkgname constraints userTarget -> - return (PackageTargetNamedFuzzy pkgname constraints userTarget) + PackageTargetNamedFuzzy pkgname props userTarget -> + return (PackageTargetNamedFuzzy pkgname props userTarget) PackageTargetLocation location -> case location of @@ -595,20 +594,18 @@ disambiguatePackageTargets availablePkgIndex availableExtra targets = disambiguatePackageTarget packageTarget = case packageTarget of PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) - PackageTargetNamed pkgname constraints userTarget + PackageTargetNamed pkgname props userTarget | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) -> Left (PackageNameUnknown pkgname userTarget) - | otherwise -> Right (NamedPackage pkgname constraints) + | otherwise -> Right (NamedPackage pkgname props) - PackageTargetNamedFuzzy pkgname constraints userTarget -> + PackageTargetNamedFuzzy pkgname props userTarget -> case disambiguatePackageName packageNameEnv pkgname of None -> Left (PackageNameUnknown pkgname userTarget) Ambiguous pkgnames -> Left (PackageNameAmbiguous pkgname pkgnames userTarget) - Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints') - where - constraints' = map (renamePackageConstraint pkgname') constraints + Unambiguous pkgname' -> Right (NamedPackage pkgname' props) -- use any extra specific available packages to help us disambiguate packageNameEnv :: PackageNameEnv @@ -729,10 +726,6 @@ userToPackageConstraint uc = case uc of UserConstraintFlags name flags -> PackageConstraint (unqualified name) (PackagePropertyFlags flags) UserConstraintStanzas name stanzas -> PackageConstraint (unqualified name) (PackagePropertyStanzas stanzas) -renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint -renamePackageConstraint name (PackageConstraint _ prop) = - PackageConstraint (unqualified name) prop - readUserConstraint :: String -> Either String UserConstraint readUserConstraint str = case readPToMaybe parse str of From d2bf16ea4b3e974c1d8d906792039afbff170e1c Mon Sep 17 00:00:00 2001 From: Robert Henderson Date: Sat, 7 Jan 2017 17:15:38 +0000 Subject: [PATCH 4/7] Code cleanup: added Traversable instance for PackageTarget. This eliminates some boilerplate code. --- cabal-install/Distribution/Client/Targets.hs | 50 ++++++++------------ 1 file changed, 19 insertions(+), 31 deletions(-) diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs index a260eceb3d9..59c9e3b2d3c 100644 --- a/cabal-install/Distribution/Client/Targets.hs +++ b/cabal-install/Distribution/Client/Targets.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} ----------------------------------------------------------------------------- -- | @@ -408,7 +409,7 @@ data PackageTarget pkg = -- to be resolved to the right case-sensitive name. | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget | PackageTargetLocation pkg - deriving Show + deriving (Show, Functor, Foldable, Traversable) -- ------------------------------------------------------------ @@ -467,12 +468,8 @@ fetchPackageTarget :: Verbosity -> RepoContext -> PackageTarget (PackageLocation ()) -> IO (PackageTarget ResolvedPkgLoc) -fetchPackageTarget verbosity repoCtxt target = case target of - PackageTargetNamed n ps ut -> return (PackageTargetNamed n ps ut) - PackageTargetNamedFuzzy n ps ut -> return (PackageTargetNamedFuzzy n ps ut) - PackageTargetLocation location -> do - location' <- fetchPackage verbosity repoCtxt (fmap (const Nothing) location) - return (PackageTargetLocation location') +fetchPackageTarget verbosity repoCtxt = traverse $ + fetchPackage verbosity repoCtxt . fmap (const Nothing) -- | Given a package target that has been fetched, read the .cabal file. @@ -482,26 +479,19 @@ fetchPackageTarget verbosity repoCtxt target = case target of readPackageTarget :: Verbosity -> PackageTarget ResolvedPkgLoc -> IO (PackageTarget UnresolvedSourcePackage) -readPackageTarget verbosity target = case target of - - PackageTargetNamed pkgname props userTarget -> - return (PackageTargetNamed pkgname props userTarget) - - PackageTargetNamedFuzzy pkgname props userTarget -> - return (PackageTargetNamedFuzzy pkgname props userTarget) - - PackageTargetLocation location -> case location of +readPackageTarget verbosity = traverse modifyLocation + where + modifyLocation location = case location of LocalUnpackedPackage dir -> do pkg <- tryFindPackageDesc dir (localPackageError dir) >>= readPackageDescription verbosity - return $ PackageTargetLocation $ - SourcePackage { - packageInfoId = packageId pkg, - packageDescription = pkg, - packageSource = fmap Just location, - packageDescrOverride = Nothing - } + return $ SourcePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location, + packageDescrOverride = Nothing + } LocalTarballPackage tarballFile -> readTarballPackageTarget location tarballFile tarballFile @@ -513,7 +503,6 @@ readPackageTarget verbosity target = case target of error "TODO: readPackageTarget RepoTarballPackage" -- For repo tarballs this info should be obtained from the index. - where readTarballPackageTarget location tarballFile tarballOriginalLoc = do (filename, content) <- extractTarballPackageCabalFile tarballFile tarballOriginalLoc @@ -521,13 +510,12 @@ readPackageTarget verbosity target = case target of Nothing -> die $ "Could not parse the cabal file " ++ filename ++ " in " ++ tarballFile Just pkg -> - return $ PackageTargetLocation $ - SourcePackage { - packageInfoId = packageId pkg, - packageDescription = pkg, - packageSource = fmap Just location, - packageDescrOverride = Nothing - } + return $ SourcePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location, + packageDescrOverride = Nothing + } extractTarballPackageCabalFile :: FilePath -> String -> IO (FilePath, BS.ByteString) From 702a39d4f9c6639c7247db07fe58c83ad23b3116 Mon Sep 17 00:00:00 2001 From: Robert Henderson Date: Sat, 7 Jan 2017 19:52:40 +0000 Subject: [PATCH 5/7] 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. --- .../Distribution/Client/CmdFreeze.hs | 12 +- cabal-install/Distribution/Client/Freeze.hs | 4 +- cabal-install/Distribution/Client/Targets.hs | 122 ++++++++++-------- .../Distribution/Client/ProjectConfig.hs | 13 +- .../UnitTests/Distribution/Client/Targets.hs | 14 +- 5 files changed, 99 insertions(+), 66 deletions(-) diff --git a/cabal-install/Distribution/Client/CmdFreeze.hs b/cabal-install/Distribution/Client/CmdFreeze.hs index c84fc70cb99..9c3332fd757 100644 --- a/cabal-install/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/Distribution/Client/CmdFreeze.hs @@ -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 () diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs index 607472cbc53..0dc3afdec85 100644 --- a/cabal-install/Distribution/Client/Freeze.hs +++ b/cabal-install/Distribution/Client/Freeze.hs @@ -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 diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs index 59c9e3b2d3c..a256f04385e 100644 --- a/cabal-install/Distribution/Client/Targets.hs +++ b/cabal-install/Distribution/Client/Targets.hs @@ -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) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 09de1a1d5be..da1ec66bb17 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -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] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs index 9956d284b8b..6c343c6caab 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs @@ -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] From b992faed47211a4e0efe7457de730fcc2e5ac16a Mon Sep 17 00:00:00 2001 From: Robert Henderson Date: Sun, 8 Jan 2017 15:42:05 +0000 Subject: [PATCH 6/7] Corrected minor error (forgot to delete old instance). --- .../UnitTests/Distribution/Client/ProjectConfig.hs | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index da1ec66bb17..3b5699124a0 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -564,16 +564,6 @@ instance Arbitrary RemoteRepo where shortListOf1 5 (oneof [ choose ('0', '9') , choose ('a', 'f') ]) -instance Arbitrary UserConstraint where - arbitrary = - oneof - [ UserConstraintVersion <$> arbitrary <*> arbitrary - , UserConstraintInstalled <$> arbitrary - , UserConstraintSource <$> arbitrary - , UserConstraintFlags <$> arbitrary <*> shortListOf1 3 arbitrary - , UserConstraintStanzas <$> arbitrary <*> ((\x->[x]) <$> arbitrary) - ] - instance Arbitrary UserConstraint where arbitrary = oneof [ UserConstraint UserUnqualified <$> arbitrary <*> prop From 14b5e9d8b6725d9038f2e19453dfc7bf2cf73a79 Mon Sep 17 00:00:00 2001 From: Robert Henderson Date: Sun, 8 Jan 2017 17:09:27 +0000 Subject: [PATCH 7/7] Corrected missing parentheses and added comment. --- cabal-install/Distribution/Client/Targets.hs | 21 +++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs index a256f04385e..06ea29662b5 100644 --- a/cabal-install/Distribution/Client/Targets.hs +++ b/cabal-install/Distribution/Client/Targets.hs @@ -754,15 +754,18 @@ instance Text UserConstraint where -- 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]) + 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)