diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs
index b169acd5a29bff574e138bc59c698df4cae89eea..fad2e042ebe3ae6dde7cfca16bd19f2a57de696f 100644
--- a/cabal-install/Distribution/Client/Targets.hs
+++ b/cabal-install/Distribution/Client/Targets.hs
@@ -67,6 +67,7 @@ import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.PackageIndex (PackageIndex)
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
+import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.SourcePackage
import qualified Distribution.Client.World as World
@@ -203,8 +204,9 @@ pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints
pkgSpecifierConstraints (SpecificSourcePackage pkg) =
[LabeledPackageConstraint pc ConstraintSourceUserTarget]
where
- pc = PackageConstraintVersion (packageName pkg)
- (thisVersion (packageVersion pkg))
+ pc = PackageConstraint (Q (PackagePath DefaultNamespace Unqualified)
+ (packageName pkg)) $
+ PackagePropertyVersion (thisVersion (packageVersion pkg))
-- ------------------------------------------------------------
-- * Parsing and checking user targets
@@ -414,6 +416,12 @@ data PackageTarget pkg =
-- * Converting user targets to package targets
-- ------------------------------------------------------------
+dependencyToConstraints :: Dependency -> [PackageConstraint]
+dependencyToConstraints (Dependency name vrange) =
+ [ PackageConstraint (Q defaultPackagePath name) $
+ PackagePropertyVersion vrange
+ | not (isAnyVersion vrange) ]
+
-- | Given a user-specified target, expand it to a bunch of package targets
-- (each of which refers to only one package).
--
@@ -422,19 +430,17 @@ expandUserTarget :: FilePath
-> IO [PackageTarget (PackageLocation ())]
expandUserTarget worldFile userTarget = case userTarget of
- UserTargetNamed (Dependency name vrange) ->
- let constraints = [ PackageConstraintVersion name vrange
- | not (isAnyVersion vrange) ]
- in return [PackageTargetNamedFuzzy name constraints userTarget]
+ UserTargetNamed dep@(Dependency name _) ->
+ return [PackageTargetNamedFuzzy name (dependencyToConstraints dep) userTarget]
UserTargetWorld -> do
worldPkgs <- World.getContents worldFile
--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
- | not (isAnyVersion vrange) ]
- ++ [ PackageConstraintFlags name flags
+ | World.WorldPkgInfo dep@(Dependency name _) flags <- worldPkgs
+ , let constraints = dependencyToConstraints dep
+ ++ [ PackageConstraint (Q defaultPackagePath name) $
+ PackagePropertyFlags flags
| not (null flags) ] ]
UserTargetLocalDir dir ->
@@ -701,40 +707,75 @@ extraPackageNameEnv names = PackageNameEnv pkgNameLookup
-- * Package constraints
-- ------------------------------------------------------------
-data UserConstraint =
- UserConstraintVersion PackageName VersionRange
- | UserConstraintInstalled PackageName
- | UserConstraintSource PackageName
- | UserConstraintFlags PackageName FlagAssignment
- | UserConstraintStanzas PackageName [OptionalStanza]
- deriving (Eq, Show, Generic)
+-- | Restricted 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
+
+fromUserQualifier :: UserQualifier -> Qualifier
+fromUserQualifier UserUnqualified = Unqualified
+fromUserQualifier (UserSetup name) = Setup name
+fromUserQualifier (UserExe name1 name2) = Exe name1 name2
+
+-- | A version of 'PackageProperty' that a user may specify on the command
+-- line (currently, it has identical representation to 'PackageProperty').
+newtype UserProperty = UserProperty PackageProperty
+
+-- | 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).
+--
+instance Text UserProperty where
+ disp (PackagePropertyVersion verrange) = disp verrange
+ disp PackagePropertyInstalled = Disp.text "installed"
+ disp PackagePropertySource = Disp.text "source"
+ disp (PackagePropertyFlags flags) = dispFlagAssignment flags
+ disp (PackagePropertyStanzas stanzas) = dispStanzas stanzas
+ where
+ dispStanzas = Disp.hsep . map dispStanza
+ dispStanza TestStanzas = Disp.text "test"
+ dispStanza BenchStanzas = Disp.text "bench"
+
+ parse =
+ ((parse >>= return . PackagePropertyVersion)
+ +++ (do skipSpaces1
+ _ <- Parse.string "installed"
+ return (PackagePropertyInstalled))
+ +++ (do skipSpaces1
+ _ <- Parse.string "source"
+ return (PackagePropertySource))
+ +++ (do skipSpaces1
+ _ <- Parse.string "test"
+ return (PackagePropertyStanzas [TestStanzas]))
+ +++ (do skipSpaces1
+ _ <- Parse.string "bench"
+ return (PackagePropertyStanzas [BenchStanzas])))
+ <++ (do skipSpaces1
+ flags <- parseFlagAssignment
+ return (PackagePropertyFlags flags))
-instance Binary UserConstraint
+-- | A restricted version of PackageConstraint that the user can specify on the
+-- command line.
+newtype UserConstraint = UserConstraint UserQualifier PackageName PackageProperty
+ deriving (Eq, Show)
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
--- 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
+userToPackageConstraint (UserConstraint qual name pp) =
+ PackageConstraint (Q (fromUserQualifier qual) name) pp
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 (Q path _) pp) =
+ PackageConstraint (Q path name) pp
readUserConstraint :: String -> Either String UserConstraint
readUserConstraint str =
diff --git a/cabal-install/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install/Distribution/Solver/Types/PackageConstraint.hs
index 5b0f29d8a9196fda2fca767859ec25ae309199a4..5cea491d769382aafd88d50a597ab61c566dcfec 100644
--- a/cabal-install/Distribution/Solver/Types/PackageConstraint.hs
+++ b/cabal-install/Distribution/Solver/Types/PackageConstraint.hs
@@ -1,35 +1,54 @@
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Solver.Types.PackageConstraint (
+ PackageProperty(..),
PackageConstraint(..),
- showPackageConstraint,
+-- showPackageConstraint,
) where
import Distribution.Compat.Binary (Binary(..))
import Distribution.PackageDescription (FlagAssignment, FlagName(..))
import Distribution.Package (PackageName)
import Distribution.Solver.Types.OptionalStanza
-import Distribution.Text (display)
+import Distribution.Solver.Types.PackagePath (Qualified)
+import Distribution.Text (Text(..), display)
import Distribution.Version (VersionRange, simplifyVersionRange)
import GHC.Generics (Generic)
--- | 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 PackageProperty
+ = PackagePropertyVersion VersionRange
+ | PackagePropertyInstalled
+ | PackagePropertySource
+ | PackagePropertyFlags FlagAssignment
+ | PackagePropertyStanzas [OptionalStanza]
+ deriving (Eq, Show, Generic)
+
+instance Binary PackageProperty
+
data PackageConstraint
- = PackageConstraintVersion PackageName VersionRange
- | PackageConstraintInstalled PackageName
- | PackageConstraintSource PackageName
- | PackageConstraintFlags PackageName FlagAssignment
- | PackageConstraintStanzas PackageName [OptionalStanza]
+ = PackageConstraint (Qualified PackageName) PackageProperty
deriving (Eq, Show, Generic)
instance Binary PackageConstraint
+dispPackageProperty :: PackageProperty -> Disp.Doc
+ disp (PackagePropertyVersion verrange) = disp verrange
+ disp PackagePropertyInstalled = Disp.text "installed"
+ disp PackagePropertySource = Disp.text "source"
+ disp (PackagePropertyFlags flags) = dispFlagAssignment flags
+ disp (PackagePropertyStanzas stanzas) = dispStanzas stanzas
+ where
+ dispStanzas = Disp.hsep . map dispStanza
+ dispStanza TestStanzas = Disp.text "test"
+ dispStanza BenchStanzas = Disp.text "bench"
+
+dispPackageConstraint :: PackageConstraint -> Disp.Doc
+dispPackageConstraint (PackageConstraint (Q path name) pp) =
+
+
-- | Provide a textual representation of a package constraint
-- for debugging purposes.
---
+
showPackageConstraint :: PackageConstraint -> String
showPackageConstraint (PackageConstraintVersion pn vr) =
display pn ++ " " ++ display (simplifyVersionRange vr)
diff --git a/cabal-install/Distribution/Solver/Types/PackagePath.hs b/cabal-install/Distribution/Solver/Types/PackagePath.hs
index 5ba2ecac4e53e85376853a81228ff26261fd7404..9c11bc3a1dd41d0f5355ff7d5646c24f6d549df7 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(..)
@@ -5,15 +6,20 @@ module Distribution.Solver.Types.PackagePath
, QPN
, Qualified(..)
, showQPN
+ , defaultPackagePath
) where
+import Distribution.Compat.Binary (Binary(..))
import Distribution.Package
-import Distribution.Text
+import GHC.Generics (Generic)
+import qualified Text.PrettyPrint as Disp
-- | 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
--
@@ -27,7 +33,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
-- | Qualifier of a package within a namespace (see 'PackagePath')
data Qualifier =
@@ -59,17 +67,15 @@ 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, Generic, Ord, Show)
--- | String representation of a package path.
---
--- 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) =
+instance Binary Qualifier
+
+dispPP :: PackagePath -> Disp.Doc
+dispPP (PackagePath ns q) =
case ns of
DefaultNamespace -> go q
- Independent i -> show i ++ "." ++ go q
+ Independent i -> Disp.int i <> Disp.char '.' <> go q
where
-- Print the qualifier
--
@@ -78,14 +84,23 @@ showPP (PackagePath ns q) =
-- 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 ++ "."
+ go Unqualified = empty
+ go (Setup pn) = disp pn <> Disp.text ":setup."
+ go (Exe pn pn2) = disp pn <> Disp.char ':' <> disp pn2 <> Disp.text ":exe."
+ go (Base pn) = display pn <> Disp.char '.'
+
+-- | String representation of a package path.
+--
+-- 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 = display . dispPP
-- | 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)
-- | Standard string representation of a qualified entity.
showQ :: (a -> String) -> (Qualified a -> String)
@@ -97,3 +112,6 @@ type QPN = Qualified PackageName
-- | String representation of a qualified package path.
showQPN :: QPN -> String
showQPN = showQ display
+
+defaultPackagePath :: PackagePath
+defaultPackagePath = PackagePath DefaultNamespace Unqualified