feat: add stage to ConstraintScope and UserConstraint

Author: andreabedini

cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs

@@ -286,10 +286,11 @@ testConditionForComponent os arch cinfo constraints p tree =
       Lit False -> Just False
       _         -> Nothing
   where
+    -- TODO: fix for stage
     flagAssignment :: [(FlagName, Bool)]
     flagAssignment =
         mconcat [ unFlagAssignment fa
-                | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa)
+                | PackageConstraint (ConstraintScope _stage (ScopeAnyQualifier _)) (PackagePropertyFlags fa)
                     <- L.map unlabelPackageConstraint constraints]
 
     -- Simplify the condition, using the current environment. Most of this

cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs

@@ -7,6 +7,7 @@
 --
 module Distribution.Solver.Types.PackageConstraint (
     ConstraintScope(..),
+    ConstraintQualifier(..),
     scopeToplevel,
     scopeToPackageName,
     constraintScopeMatches,
@@ -29,11 +30,15 @@ import Distribution.Solver.Types.OptionalStanza
 import Distribution.Solver.Types.PackagePath
 
 import qualified Text.PrettyPrint as Disp
+import Distribution.Solver.Types.Toolchain (Stage)
 
 
 -- | Determines to what packages and in what contexts a
 -- constraint applies.
-data ConstraintScope
+data ConstraintScope = ConstraintScope (Maybe Stage) ConstraintQualifier
+  deriving (Eq, Show)
+
+data ConstraintQualifier
      -- | A scope that applies when the given package is used as a build target.
      -- In other words, the scope applies iff a goal has a top-level qualifier
      -- and its namespace matches the given package name. A namespace is
@@ -58,27 +63,35 @@ data ConstraintScope
 -- the package with the specified name when that package is a
 -- top-level dependency in the default namespace.
 scopeToplevel :: PackageName -> ConstraintScope
-scopeToplevel = ScopeQualified QualToplevel
+scopeToplevel = ConstraintScope Nothing . ScopeQualified QualToplevel
 
 -- | Returns the package name associated with a constraint scope.
 scopeToPackageName :: ConstraintScope -> PackageName
-scopeToPackageName (ScopeTarget pn) = pn
-scopeToPackageName (ScopeQualified _ pn) = pn
-scopeToPackageName (ScopeAnySetupQualifier pn) = pn
-scopeToPackageName (ScopeAnyQualifier pn) = pn
+scopeToPackageName (ConstraintScope _stage (ScopeTarget pn)) = pn
+scopeToPackageName (ConstraintScope _stage (ScopeQualified _ pn)) = pn
+scopeToPackageName (ConstraintScope _stage (ScopeAnySetupQualifier pn)) = pn
+scopeToPackageName (ConstraintScope _stage (ScopeAnyQualifier pn)) = pn
 
 constraintScopeMatches :: ConstraintScope -> QPN -> Bool
-constraintScopeMatches (ScopeTarget pn) (Q (PackagePath _ q) pn') =
+constraintScopeMatches (ConstraintScope mstage qualifier) (Q (PackagePath stage' q) pn') =
+  maybe True (== stage') mstage && constraintQualifierMatches qualifier q pn'
+
+constraintQualifierMatches :: ConstraintQualifier -> Qualifier -> PackageName -> Bool
+constraintQualifierMatches (ScopeTarget pn) q pn' =
     q == QualToplevel && pn == pn'
-constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') =
+constraintQualifierMatches (ScopeQualified q pn) q' pn' =
     q == q' && pn == pn'
-constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') =
-  let setup (PackagePath _ (QualSetup _)) = True
-      setup _                           = False
-  in setup pp && pn == pn'
-constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn'
+constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' =
+  pn == pn'
+constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' =
+    pn == pn'
+constraintQualifierMatches _ _ _ = False
 
 instance Pretty ConstraintScope where
+  pretty (ConstraintScope mstage qualifier) =
+    maybe mempty pretty mstage <+> pretty qualifier
+
+instance Pretty ConstraintQualifier where
   pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn
   pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn
   pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn

cabal-install-solver/src/Distribution/Solver/Types/Stage.hs

@@ -16,10 +16,12 @@ module Distribution.Solver.Types.Stage
 
 import Prelude (Enum (..))
 import Distribution.Compat.Prelude
+import qualified Distribution.Compat.CharParsing as P
 
 import Data.Maybe (fromJust)
 import GHC.Stack
 
+import Distribution.Parsec (Parsec (..))
 import Distribution.Pretty (Pretty (..))
 import Distribution.Utils.Structured (Structured (..))
 import qualified Text.PrettyPrint as Disp
@@ -42,6 +44,12 @@ showStage :: Stage -> String
 showStage Build = "build"
 showStage Host = "host"
 
+instance Parsec Stage where
+  parsec = P.choice [
+      Build <$ P.string "build",
+      Host <$ P.string "host"
+    ]
+
 -- TOOD: I think there is similar code for stanzas, compare.
 
 newtype Staged a = Staged

cabal-install/src/Distribution/Client/CmdFreeze.hs

@@ -29,8 +29,8 @@ import Distribution.Client.ProjectOrchestration
 import Distribution.Client.ProjectPlanning
 import Distribution.Client.Targets
   ( UserConstraint (..)
-  , UserConstraintScope (..)
   , UserQualifier (..)
+  , UserConstraintQualifier (..)
   )
 import Distribution.Solver.Types.ConstraintSource
   ( ConstraintSource (..)
@@ -209,9 +209,11 @@ projectFreezeConstraints plan =
   -- constraint would apply to both instances). We do however keep flag
   -- constraints of local packages.
   --
+  -- TODO: this is even worse with stages
   deleteLocalPackagesVersionConstraints
     (Map.unionWith (++) versionConstraints flagConstraints)
   where
+    
     versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
     versionConstraints =
       Map.mapWithKey

cabal-install/src/Distribution/Client/CmdRepl.hs

@@ -77,8 +77,7 @@ import Distribution.Client.TargetProblem
   ( TargetProblem (..)
   )
 import Distribution.Client.Targets
-  ( UserConstraint (..)
-  , UserConstraintScope (..)
+  ( UserConstraint (..), UserConstraintQualifier (..)
   )
 import Distribution.Client.Types
   ( PackageSpecifier (..)

cabal-install/src/Distribution/Client/Dependency.hs

@@ -432,7 +432,7 @@ dontInstallNonReinstallablePackages params =
   where
     extraConstraints =
       [ LabeledPackageConstraint
-        (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled)
+        (PackageConstraint (ConstraintScope Nothing (ScopeAnyQualifier pkgname)) PackagePropertyInstalled)
         ConstraintSourceNonReinstallablePackage
       | pkgname <- nonReinstallablePackages
       ]
@@ -634,7 +634,7 @@ addSetupCabalMinVersionConstraint minVersion =
   addConstraints
     [ LabeledPackageConstraint
         ( PackageConstraint
-            (ScopeAnySetupQualifier cabalPkgname)
+            (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname))
             (PackagePropertyVersion $ orLaterVersion minVersion)
         )
         ConstraintSetupCabalMinVersion
@@ -652,7 +652,7 @@ addSetupCabalMaxVersionConstraint maxVersion =
   addConstraints
     [ LabeledPackageConstraint
         ( PackageConstraint
-            (ScopeAnySetupQualifier cabalPkgname)
+            (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname))
             (PackagePropertyVersion $ earlierVersion maxVersion)
         )
         ConstraintSetupCabalMaxVersion
@@ -668,7 +668,7 @@ addSetupCabalProfiledDynamic =
   addConstraints
     [ LabeledPackageConstraint
         ( PackageConstraint
-            (ScopeAnySetupQualifier cabalPkgname)
+            (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname))
             (PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0]))
         )
         ConstraintSourceProfiledDynamic

cabal-install/src/Distribution/Client/Targets.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 -- |
 -- Module      :  Distribution.Client.Targets
@@ -34,7 +35,8 @@ module Distribution.Client.Targets
     -- * User constraints
   , UserQualifier (..)
   , UserConstraintScope (..)
-  , UserConstraint (..)
+  , UserConstraintQualifier (..)
+  , UserConstraint (UserConstraint, UserConstraintStaged)
   , userConstraintPackageName
   , readUserConstraint
   , userToPackageConstraint
@@ -115,6 +117,7 @@ import System.FilePath
   , takeDirectory
   , takeExtension
   )
+import Distribution.Solver.Types.Stage (Stage)
 
 -- ------------------------------------------------------------
 
@@ -613,7 +616,13 @@ instance Structured UserQualifier
 
 -- | Version of 'ConstraintScope' that a user may specify on the
 -- command line.
-data UserConstraintScope
+data UserConstraintScope = UserConstraintScope (Maybe Stage) UserConstraintQualifier
+  deriving (Eq, Show, Generic)
+
+instance Binary UserConstraintScope
+instance Structured UserConstraintScope
+
+data UserConstraintQualifier
   = -- | Scope that applies to the package when it has the specified qualifier.
     UserQualified UserQualifier PackageName
   | -- | Scope that applies to the package when it has a setup qualifier.
@@ -622,38 +631,46 @@ data UserConstraintScope
     UserAnyQualifier PackageName
   deriving (Eq, Show, Generic)
 
-instance Binary UserConstraintScope
-instance Structured UserConstraintScope
+instance Binary UserConstraintQualifier
+instance Structured UserConstraintQualifier
 
 fromUserQualifier :: UserQualifier -> Qualifier
 fromUserQualifier UserQualToplevel = QualToplevel
 fromUserQualifier (UserQualSetup name) = QualSetup name
 fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2
 
 fromUserConstraintScope :: UserConstraintScope -> ConstraintScope
-fromUserConstraintScope (UserQualified q pn) =
-  ScopeQualified (fromUserQualifier q) pn
-fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn
-fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn
+fromUserConstraintScope (UserConstraintScope mstage (UserQualified q pn)) =
+  ConstraintScope mstage (ScopeQualified (fromUserQualifier q) pn)
+fromUserConstraintScope (UserConstraintScope mstage (UserAnySetupQualifier pn)) =
+  ConstraintScope mstage (ScopeAnySetupQualifier pn)
+fromUserConstraintScope (UserConstraintScope mstage (UserAnyQualifier pn)) =
+  ConstraintScope mstage (ScopeAnyQualifier pn)
 
 -- | Version of 'PackageConstraint' that the user can specify on
 -- the command line.
 data UserConstraint
-  = UserConstraint UserConstraintScope PackageProperty
+  = UserConstraintX UserConstraintScope PackageProperty
   deriving (Eq, Show, Generic)
 
 instance Binary UserConstraint
 instance Structured UserConstraint
 
+pattern UserConstraint :: UserConstraintQualifier -> PackageProperty -> UserConstraint
+pattern UserConstraint qualifier prop = UserConstraintX (UserConstraintScope Nothing qualifier) prop
+
+pattern UserConstraintStaged :: Stage -> UserConstraintQualifier -> PackageProperty -> UserConstraint
+pattern UserConstraintStaged stage qualifier prop = UserConstraintX (UserConstraintScope (Just stage) qualifier) prop
+
 userConstraintPackageName :: UserConstraint -> PackageName
-userConstraintPackageName (UserConstraint scope _) = scopePN scope
+userConstraintPackageName (UserConstraintX (UserConstraintScope _stage qualifier) _) = scopePN qualifier
   where
     scopePN (UserQualified _ pn) = pn
     scopePN (UserAnyQualifier pn) = pn
     scopePN (UserAnySetupQualifier pn) = pn
 
 userToPackageConstraint :: UserConstraint -> PackageConstraint
-userToPackageConstraint (UserConstraint scope prop) =
+userToPackageConstraint (UserConstraintX scope prop) =
   PackageConstraint (fromUserConstraintScope scope) prop
 
 readUserConstraint :: String -> Either String UserConstraint
@@ -668,7 +685,7 @@ readUserConstraint str =
         ++ "'source', 'test', 'bench', or flags. "
 
 instance Pretty UserConstraint where
-  pretty (UserConstraint scope prop) =
+  pretty (UserConstraintX scope prop) =
     pretty $ PackageConstraint (fromUserConstraintScope scope) prop
 
 instance Parsec UserConstraint where
@@ -684,24 +701,26 @@ instance Parsec UserConstraint where
         , PackagePropertyStanzas [TestStanzas] <$ P.string "test"
         , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench"
         ]
-    return (UserConstraint scope prop)
+    return (UserConstraintX scope prop)
     where
       parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope
       parseConstraintScope = do
+        mstage <- P.optional (parsec <* P.char ':')
         pn <- parsec
-        P.choice
+        c <- P.choice
           [ P.char '.' *> withDot pn
           , P.char ':' *> withColon pn
           , return (UserQualified UserQualToplevel pn)
           ]
+        return $ UserConstraintScope mstage c
         where
-          withDot :: PackageName -> m UserConstraintScope
+          withDot :: PackageName -> m UserConstraintQualifier
           withDot pn
             | pn == mkPackageName "any" = UserAnyQualifier <$> parsec
             | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec
             | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn
 
-          withColon :: PackageName -> m UserConstraintScope
+          withColon :: PackageName -> m UserConstraintQualifier
           withColon pn =
             UserQualified (UserQualSetup pn)
               <$ P.string "setup."

cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs

@@ -52,8 +52,8 @@ pkgSpecifierConstraints (SpecificSourcePackage pkg) =
   where
     pc =
       PackageConstraint
-        (ScopeTarget $ packageName pkg)
-        (PackagePropertyVersion $ thisVersion (packageVersion pkg))
+        (ConstraintScope Nothing (ScopeTarget $ packageName pkg))
+        PackagePropertySource
 
 mkNamedPackage :: PackageIdentifier -> PackageSpecifier pkg
 mkNamedPackage pkgId =

cabal-install/tests/IntegrationTests2.hs

@@ -30,7 +30,7 @@ import Distribution.Client.TargetSelector hiding (DirActions (..))
 import qualified Distribution.Client.TargetSelector as TS (DirActions (..))
 import Distribution.Client.Targets
   ( UserConstraint (..)
-  , UserConstraintScope (UserAnyQualifier)
+  , UserConstraintQualifier (UserAnyQualifier)
   )
 import Distribution.Client.Types
   ( PackageLocation (..)

cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs

@@ -287,6 +287,10 @@ instance Arbitrary UserConstraintScope where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
+instance Arbitrary UserConstraintQualifier where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
 instance Arbitrary UserQualifier where
   arbitrary =
     oneof