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.

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 ()

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
 

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)

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]
 

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]