Merge pull request #4228 from robjhen/issue-3502-part3

Qualified constraints (issue #3502) part 2

Author: Rob Henderson

cabal-install/Distribution/Client/CmdFreeze.hs

@@ -150,7 +150,7 @@ projectFreezeConstraints plan =
     versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
     versionConstraints =
       Map.mapWithKey
-        (\p v -> [(UserConstraint UserUnqualified p (PackagePropertyVersion v),
+        (\p v -> [(UserConstraint UserToplevel p (PackagePropertyVersion v),
                    ConstraintSourceFreeze)])
         versionRanges
 
@@ -168,7 +168,7 @@ projectFreezeConstraints plan =
     flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
     flagConstraints =
       Map.mapWithKey
-        (\p f -> [(UserConstraint UserUnqualified p (PackagePropertyFlags f),
+        (\p f -> [(UserConstraint UserToplevel p (PackagePropertyFlags f),
                    ConstraintSourceFreeze)])
         flagAssignments
 

cabal-install/Distribution/Client/Configure.hs

@@ -336,15 +336,15 @@ planLocalPackage verbosity comp platform configFlags configExFlags
         . addConstraints
             -- package flags from the config file or command line
             [ let pc = PackageConstraint
-                       (unqualified $ packageName pkg)
+                       (scopeToplevel $ 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 = PackageConstraint (unqualified $ packageName pkg) .
+            [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) .
                        PackagePropertyStanzas $
                        [ TestStanzas  | testsEnabled ] ++
                        [ BenchStanzas | benchmarksEnabled ]

cabal-install/Distribution/Client/Dependency.hs

@@ -25,7 +25,7 @@ module Distribution.Client.Dependency (
     -- * Constructing resolver policies
     PackageProperty(..),
     PackageConstraint(..),
-    unqualified,
+    scopeToplevel,
     PackagesPreferenceDefault(..),
     PackagePreference(..),
 
@@ -361,7 +361,7 @@ dontUpgradeNonUpgradeablePackages params =
   where
     extraConstraints =
       [ LabeledPackageConstraint
-        (PackageConstraint (unqualified pkgname) PackagePropertyInstalled)
+        (PackageConstraint (scopeToplevel pkgname) PackagePropertyInstalled)
         ConstraintSourceNonUpgradeablePackage
       | Set.notMember (mkPackageName "base") (depResolverTargets params)
       -- If you change this enumeration, make sure to update the list in
@@ -492,7 +492,7 @@ addSetupCabalMinVersionConstraint :: Version
 addSetupCabalMinVersionConstraint minVersion =
     addConstraints
       [ LabeledPackageConstraint
-          (PackageConstraint (unqualified cabalPkgname)
+          (PackageConstraint (scopeToplevel cabalPkgname)
                              (PackagePropertyVersion $ orLaterVersion minVersion))
           ConstraintSetupCabalMinVersion
       ]
@@ -600,7 +600,7 @@ applySandboxInstallPolicy
 
   . addConstraints
       [ let pc = PackageConstraint
-                 (unqualified $ packageName pkg)
+                 (scopeToplevel $ packageName pkg)
                  (PackagePropertyVersion $ thisVersion (packageVersion pkg))
         in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep
       | pkg <- modifiedDeps ]
@@ -946,9 +946,9 @@ resolveWithoutDependencies (DepResolverParams targets constraints
       Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
     packageVersionConstraintMap =
       let pcs = map unlabelPackageConstraint constraints
-      in Map.fromList [ (name, range)
+      in Map.fromList [ (scopeToPackageName scope, range)
                       | PackageConstraint
-                          (Q _ name) (PackagePropertyVersion range) <- pcs ]
+                          scope (PackagePropertyVersion range) <- pcs ]
 
     packagePreferences :: PackageName -> PackagePreferences
     packagePreferences = interpretPackagesPreference targets defpref prefs

cabal-install/Distribution/Client/Freeze.hs

@@ -183,7 +183,7 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
 
       . addConstraints
           [ let pkg = pkgSpecifierTarget pkgSpecifier
-                pc = PackageConstraint (unqualified pkg)
+                pc = PackageConstraint (scopeToplevel pkg)
                                        (PackagePropertyStanzas stanzas)
             in LabeledPackageConstraint pc ConstraintSourceFreeze
           | pkgSpecifier <- pkgSpecifiers ]
@@ -251,7 +251,7 @@ freezePackages verbosity globalFlags pkgs = do
         (pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig userPackageEnvironmentFile)
       where
         pkgIdToConstraint pkgId =
-            UserConstraint UserUnqualified (packageName pkgId)
+            UserConstraint UserToplevel (packageName pkgId)
                            (PackagePropertyVersion $ thisVersion (packageVersion pkgId))
     createPkgEnv config = mempty { pkgEnvSavedConfig = config }
     showPkgEnv = BS.Char8.pack . showPackageEnvironment

cabal-install/Distribution/Client/Install.hs

@@ -410,7 +410,7 @@ planPackages comp platform mSandboxPkgInfo solver
           --FIXME: this just applies all flags to all targets which
           -- is silly. We should check if the flags are appropriate
           [ let pc = PackageConstraint
-                     (unqualified $ pkgSpecifierTarget pkgSpecifier)
+                     (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
                      (PackagePropertyFlags flags)
             in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
           | let flags = configConfigurationsFlags configFlags
@@ -419,7 +419,7 @@ planPackages comp platform mSandboxPkgInfo solver
 
       . addConstraints
           [ let pc = PackageConstraint
-                     (unqualified $ pkgSpecifierTarget pkgSpecifier)
+                     (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
                      (PackagePropertyStanzas stanzas)
             in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
           | pkgSpecifier <- pkgSpecifiers ]

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -985,7 +985,7 @@ planPackages comp platform solver SolverSettings{..}
       . addConstraints
           -- enable stanza constraints where the user asked to enable
           [ LabeledPackageConstraint
-              (PackageConstraint (unqualified pkgname)
+              (PackageConstraint (scopeToplevel pkgname)
                                  (PackagePropertyStanzas stanzas))
               ConstraintSourceConfigFlagOrTarget
           | pkg <- localPackages
@@ -1000,7 +1000,7 @@ 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
-              (PackageConstraint (unqualified pkgname)
+              (PackageConstraint (scopeToplevel pkgname)
                                  (PackagePropertyFlags flags))
               ConstraintSourceConfigFlagOrTarget
           | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ]
@@ -1011,7 +1011,7 @@ 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
-              (PackageConstraint (unqualified pkgname) 
+              (PackageConstraint (scopeToplevel pkgname) 
                                  (PackagePropertyFlags flags))
               ConstraintSourceConfigFlagOrTarget
           | let flags = solverSettingFlagAssignment

cabal-install/Distribution/Client/Targets.hs

@@ -201,13 +201,13 @@ pkgSpecifierConstraints :: Package pkg
 pkgSpecifierConstraints (NamedPackage name props) = map toLpc props
   where
     toLpc prop = LabeledPackageConstraint
-                 (PackageConstraint (unqualified name) prop)
+                 (PackageConstraint (scopeToplevel name) prop)
                  ConstraintSourceUserTarget
 pkgSpecifierConstraints (SpecificSourcePackage pkg)  =
     [LabeledPackageConstraint pc ConstraintSourceUserTarget]
   where
     pc = PackageConstraint
-         (unqualified $ packageName pkg)
+         (scopeToplevel $ packageName pkg)
          (PackagePropertyVersion $ thisVersion (packageVersion pkg))
 
 -- ------------------------------------------------------------
@@ -690,7 +690,7 @@ extraPackageNameEnv names = PackageNameEnv pkgNameLookup
 -- command line.
 data UserQualifier =
   -- | Top-level dependency.
-  UserUnqualified
+  UserToplevel
 
   -- | Setup dependency.
   | UserSetup PackageName
@@ -702,9 +702,9 @@ data UserQualifier =
 instance Binary UserQualifier
 
 fromUserQualifier :: UserQualifier -> Qualifier
-fromUserQualifier UserUnqualified = Unqualified
-fromUserQualifier (UserSetup name) = Setup name
-fromUserQualifier (UserExe name1 name2) = Exe name1 name2
+fromUserQualifier UserToplevel = QualToplevel
+fromUserQualifier (UserSetup name) = QualSetup name
+fromUserQualifier (UserExe name1 name2) = QualExe name1 name2
 
 -- | Version of 'PackageConstraint' that the user can specify on
 -- the command line.
@@ -718,7 +718,7 @@ userConstraintPackageName (UserConstraint _ name _) = name
 
 userToPackageConstraint :: UserConstraint -> PackageConstraint
 userToPackageConstraint (UserConstraint qual name prop) =
-  PackageConstraint (Q path name) prop
+  PackageConstraint (ScopeQualified $ Q path name) prop
   where
     path = PackagePath DefaultNamespace (fromUserQualifier qual)
 
@@ -729,8 +729,9 @@ readUserConstraint str =
       Just c  -> Right c
   where
     msgCannotParse =
-         "expected a package name followed by a constraint, which is "
-      ++ "either a version range, 'installed', 'source' or flags"
+         "expected a (possibly qualified) package name followed by a " ++
+         "constraint, which is either a version range, 'installed', " ++
+         "'source', 'test', 'bench', or flags"
 
 instance Text UserConstraint where
   disp (UserConstraint qual name prop) =
@@ -740,7 +741,7 @@ instance Text UserConstraint where
   parse = do
     -- Qualified name
     pn <- parse
-    (qual, name) <- return (UserUnqualified, pn)
+    (qual, name) <- return (UserToplevel, pn)
                     +++
                     do _ <- Parse.string ":setup."
                        pn2 <- parse

cabal-install/Distribution/Solver/Modular.hs

@@ -31,7 +31,6 @@ 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(..) )
@@ -60,4 +59,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 (PackageConstraint (Q _ pn) _) = pn
+      pcName (PackageConstraint scope _) = scopeToPackageName scope

cabal-install/Distribution/Solver/Modular/Builder.hs

@@ -272,4 +272,4 @@ buildTree idx (IndependentGoals ind) igs =
     topLevelGoal qpn = OpenGoal (Simple (Dep False {- not exe -} qpn (Constrained [])) ()) UserGoal
 
     qpns | ind       = makeIndependent igs
-         | otherwise = L.map (Q (PackagePath DefaultNamespace Unqualified)) igs
+         | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs

cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs

@@ -59,7 +59,7 @@ convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =
     case loc of
         Inst pi -> Left (PreExistingId sourceId pi)
         _otherwise
-          | Exe _ pn' <- q
+          | QualExe _ pn' <- q
           -- NB: the dependencies of the executable are also
           -- qualified.  So the way to tell if this is an executable
           -- dependency is to make sure the qualifier is pointing

cabal-install/Distribution/Solver/Modular/Dependency.hs

@@ -244,9 +244,9 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
     goD (Lang lang)   _    = Lang lang
     goD (Pkg pkn vr)  _    = Pkg pkn vr
     goD (Dep is_exe dep ci) comp
-      | is_exe      = Dep is_exe (Q (PackagePath ns (Exe pn dep)) dep) (fmap (Q pp) ci)
-      | qBase  dep  = Dep is_exe (Q (PackagePath ns (Base  pn)) dep) (fmap (Q pp) ci)
-      | qSetup comp = Dep is_exe (Q (PackagePath ns (Setup pn)) dep) (fmap (Q pp) ci)
+      | is_exe      = Dep is_exe (Q (PackagePath ns (QualExe pn dep)) dep) (fmap (Q pp) ci)
+      | qBase  dep  = Dep is_exe (Q (PackagePath ns (QualBase  pn)) dep) (fmap (Q pp) ci)
+      | qSetup comp = Dep is_exe (Q (PackagePath ns (QualSetup pn)) dep) (fmap (Q pp) ci)
       | otherwise   = Dep is_exe (Q (PackagePath ns inheritedQ) dep) (fmap (Q pp) ci)
 
     -- If P has a setup dependency on Q, and Q has a regular dependency on R, then
@@ -258,10 +258,10 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
     -- a detailed discussion.
     inheritedQ :: Qualifier
     inheritedQ = case q of
-                   Setup _     -> q
-                   Exe _ _     -> q
-                   Unqualified -> q
-                   Base _      -> Unqualified
+                   QualSetup _  -> q
+                   QualExe _ _  -> q
+                   QualToplevel -> q
+                   QualBase _   -> QualToplevel
 
     -- Should we qualify this goal with the 'Base' package path?
     qBase :: PN -> Bool

cabal-install/Distribution/Solver/Modular/Package.hs

@@ -88,22 +88,22 @@ instI _              = False
 primaryPP :: PackagePath -> Bool
 primaryPP (PackagePath _ns q) = go q
   where
-    go Unqualified = True
-    go (Base  _)   = True
-    go (Setup _)   = False
-    go (Exe _ _)   = False
+    go QualToplevel    = True
+    go (QualBase  _)   = True
+    go (QualSetup _)   = False
+    go (QualExe _ _)   = False
 
 -- | Is the package a dependency of a setup script.  This is used to
 -- establish whether or not certain constraints should apply to this
 -- dependency (grep 'setupPP' to see the use sites).
 --
 setupPP :: PackagePath -> Bool
-setupPP (PackagePath _ns (Setup _)) = True
+setupPP (PackagePath _ns (QualSetup _)) = True
 setupPP (PackagePath _ns _)         = False
 
 -- | Create artificial parents for each of the package names, making
 -- them all independent.
 makeIndependent :: [PN] -> [QPN]
 makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]
-                               , let pp = PackagePath (Independent i) Unqualified
+                               , let pp = PackagePath (Independent i) QualToplevel
                      ]

cabal-install/Distribution/Solver/Modular/Preference.hs

@@ -348,8 +348,8 @@ deferSetupChoices = trav go
     go x                    = x
 
     noSetup :: Goal QPN -> Bool
-    noSetup (Goal (P (Q (PackagePath _ns (Setup _)) _)) _) = False
-    noSetup _                                              = True
+    noSetup (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False
+    noSetup _                                                  = True
 
 -- | Transformation that tries to avoid making weak flag choices early.
 -- Weak flags are trivial flags (not influencing dependencies) or such

cabal-install/Distribution/Solver/Modular/Solver.hs

@@ -231,5 +231,5 @@ _removeGR = trav go
 
    dummy :: QGoalReason
    dummy = PDependency
-         $ PI (Q (PackagePath DefaultNamespace Unqualified) (mkPackageName "$"))
+         $ PI (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$"))
               (I (mkVersion [1]) InRepo)