Skip to content

Commit 059f001

Browse files
andreabediniandreabedini
committed
feat(cabal-install): add stage to ConstraintScope and UserConstraint
1 parent 4b55c76 commit 059f001

File tree

13 files changed

+133
-66
lines changed

13 files changed

+133
-66
lines changed

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

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -275,17 +275,19 @@ testConditionForComponent :: Stage
275275
-> (a -> Bool)
276276
-> CondTree ConfVar [Dependency] a
277277
-> Maybe Bool
278-
testConditionForComponent _stage os arch cinfo constraints p tree =
278+
testConditionForComponent stage os arch cinfo constraints p tree =
279279
case go $ extractCondition p tree of
280280
Lit True -> Just True
281281
Lit False -> Just False
282282
_ -> Nothing
283283
where
284+
-- TODO: fix for stage
284285
flagAssignment :: [(FlagName, Bool)]
285286
flagAssignment =
286287
mconcat [ unFlagAssignment fa
287-
| PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa)
288-
<- L.map unlabelPackageConstraint constraints]
288+
| PackageConstraint (ConstraintScope stage' (ScopeAnyQualifier _)) (PackagePropertyFlags fa)
289+
<- L.map unlabelPackageConstraint constraints
290+
, maybe True (== stage) stage']
289291

290292
-- Simplify the condition, using the current environment. Most of this
291293
-- function was copied from convBranch and

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

Lines changed: 33 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@
77
--
88
module Distribution.Solver.Types.PackageConstraint (
99
ConstraintScope(..),
10+
ConstraintQualifier(..),
1011
scopeToplevel,
1112
scopeToPackageName,
1213
constraintScopeMatches,
@@ -29,11 +30,21 @@ import Distribution.Solver.Types.OptionalStanza
2930
import Distribution.Solver.Types.PackagePath
3031

3132
import qualified Text.PrettyPrint as Disp
33+
import Distribution.Solver.Types.Toolchain (Stage (..))
3234

3335

3436
-- | Determines to what packages and in what contexts a
3537
-- constraint applies.
36-
data ConstraintScope
38+
data ConstraintScope =
39+
ConstraintScope
40+
-- | The stage at which the constraint applies, if any.
41+
-- If Nothing, the constraint applies to all stages.
42+
(Maybe Stage)
43+
-- | The qualifier that determines the scope of the constraint.
44+
ConstraintQualifier
45+
deriving (Eq, Show)
46+
47+
data ConstraintQualifier
3748
-- | A scope that applies when the given package is used as a build target.
3849
-- In other words, the scope applies iff a goal has a top-level qualifier
3950
-- and its namespace matches the given package name. A namespace is
@@ -56,29 +67,37 @@ data ConstraintScope
5667

5768
-- | Constructor for a common use case: the constraint applies to
5869
-- the package with the specified name when that package is a
59-
-- top-level dependency in the default namespace.
70+
-- top-level dependency in the host stage.
6071
scopeToplevel :: PackageName -> ConstraintScope
61-
scopeToplevel = ScopeQualified QualToplevel
72+
scopeToplevel = ConstraintScope (Just Host) . ScopeQualified QualToplevel
6273

6374
-- | Returns the package name associated with a constraint scope.
6475
scopeToPackageName :: ConstraintScope -> PackageName
65-
scopeToPackageName (ScopeTarget pn) = pn
66-
scopeToPackageName (ScopeQualified _ pn) = pn
67-
scopeToPackageName (ScopeAnySetupQualifier pn) = pn
68-
scopeToPackageName (ScopeAnyQualifier pn) = pn
76+
scopeToPackageName (ConstraintScope _stage (ScopeTarget pn)) = pn
77+
scopeToPackageName (ConstraintScope _stage (ScopeQualified _ pn)) = pn
78+
scopeToPackageName (ConstraintScope _stage (ScopeAnySetupQualifier pn)) = pn
79+
scopeToPackageName (ConstraintScope _stage (ScopeAnyQualifier pn)) = pn
6980

7081
constraintScopeMatches :: ConstraintScope -> QPN -> Bool
71-
constraintScopeMatches (ScopeTarget pn) (Q (PackagePath _ q) pn') =
82+
constraintScopeMatches (ConstraintScope mstage qualifier) (Q (PackagePath stage' q) pn') =
83+
maybe True (== stage') mstage && constraintQualifierMatches qualifier q pn'
84+
85+
constraintQualifierMatches :: ConstraintQualifier -> Qualifier -> PackageName -> Bool
86+
constraintQualifierMatches (ScopeTarget pn) q pn' =
7287
q == QualToplevel && pn == pn'
73-
constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') =
88+
constraintQualifierMatches (ScopeQualified q pn) q' pn' =
7489
q == q' && pn == pn'
75-
constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') =
76-
let setup (PackagePath _ (QualSetup _)) = True
77-
setup _ = False
78-
in setup pp && pn == pn'
79-
constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn'
90+
constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' =
91+
pn == pn'
92+
constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' =
93+
pn == pn'
94+
constraintQualifierMatches _ _ _ = False
8095

8196
instance Pretty ConstraintScope where
97+
pretty (ConstraintScope mstage qualifier) =
98+
maybe mempty pretty mstage <+> pretty qualifier
99+
100+
instance Pretty ConstraintQualifier where
82101
pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn
83102
pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn
84103
pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ import Distribution.Client.ProjectOrchestration
3030
import Distribution.Client.ProjectPlanning
3131
import Distribution.Client.Targets
3232
( UserConstraint (..)
33-
, UserConstraintScope (..)
33+
, UserConstraintQualifier (..)
3434
, UserQualifier (..)
3535
)
3636
import Distribution.Solver.Types.ConstraintSource

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -80,7 +80,7 @@ import Distribution.Client.TargetProblem
8080
)
8181
import Distribution.Client.Targets
8282
( UserConstraint (..)
83-
, UserConstraintScope (..)
83+
, UserConstraintQualifier (..)
8484
)
8585
import Distribution.Client.Types
8686
( PackageSpecifier (..)

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -440,7 +440,7 @@ dontInstallNonReinstallablePackages params =
440440
where
441441
extraConstraints =
442442
[ LabeledPackageConstraint
443-
(PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled)
443+
(PackageConstraint (ConstraintScope Nothing (ScopeAnyQualifier pkgname)) PackagePropertyInstalled)
444444
ConstraintSourceNonReinstallablePackage
445445
| pkgname <- nonReinstallablePackages
446446
]
@@ -642,7 +642,7 @@ addSetupCabalMinVersionConstraint minVersion =
642642
addConstraints
643643
[ LabeledPackageConstraint
644644
( PackageConstraint
645-
(ScopeAnySetupQualifier cabalPkgname)
645+
(ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname))
646646
(PackagePropertyVersion $ orLaterVersion minVersion)
647647
)
648648
ConstraintSetupCabalMinVersion
@@ -660,7 +660,7 @@ addSetupCabalMaxVersionConstraint maxVersion =
660660
addConstraints
661661
[ LabeledPackageConstraint
662662
( PackageConstraint
663-
(ScopeAnySetupQualifier cabalPkgname)
663+
(ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname))
664664
(PackagePropertyVersion $ earlierVersion maxVersion)
665665
)
666666
ConstraintSetupCabalMaxVersion
@@ -676,7 +676,7 @@ addSetupCabalProfiledDynamic =
676676
addConstraints
677677
[ LabeledPackageConstraint
678678
( PackageConstraint
679-
(ScopeAnySetupQualifier cabalPkgname)
679+
(ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname))
680680
(PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0]))
681681
)
682682
ConstraintSourceProfiledDynamic

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

Lines changed: 61 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE DeriveGeneric #-}
22
{-# LANGUAGE DeriveTraversable #-}
3+
{-# LANGUAGE PatternSynonyms #-}
34
{-# LANGUAGE ScopedTypeVariables #-}
45

56
-- |
@@ -34,7 +35,8 @@ module Distribution.Client.Targets
3435
-- * User constraints
3536
, UserQualifier (..)
3637
, UserConstraintScope (..)
37-
, UserConstraint (..)
38+
, UserConstraintQualifier (..)
39+
, UserConstraint (UserConstraint, UserConstraintStaged)
3840
, userConstraintPackageName
3941
, readUserConstraint
4042
, userToPackageConstraint
@@ -99,6 +101,7 @@ import qualified Data.Map as Map
99101
import Distribution.Client.Errors
100102
import qualified Distribution.Client.GZipUtils as GZipUtils
101103
import qualified Distribution.Compat.CharParsing as P
104+
import Distribution.Solver.Types.Stage (Stage)
102105
import Distribution.Utils.Path (makeSymbolicPath)
103106
import Network.URI
104107
( URI (..)
@@ -613,7 +616,13 @@ instance Structured UserQualifier
613616

614617
-- | Version of 'ConstraintScope' that a user may specify on the
615618
-- command line.
616-
data UserConstraintScope
619+
data UserConstraintScope = UserConstraintScope (Maybe Stage) UserConstraintQualifier
620+
deriving (Eq, Show, Generic)
621+
622+
instance Binary UserConstraintScope
623+
instance Structured UserConstraintScope
624+
625+
data UserConstraintQualifier
617626
= -- | Scope that applies to the package when it has the specified qualifier.
618627
UserQualified UserQualifier PackageName
619628
| -- | Scope that applies to the package when it has a setup qualifier.
@@ -622,38 +631,46 @@ data UserConstraintScope
622631
UserAnyQualifier PackageName
623632
deriving (Eq, Show, Generic)
624633

625-
instance Binary UserConstraintScope
626-
instance Structured UserConstraintScope
634+
instance Binary UserConstraintQualifier
635+
instance Structured UserConstraintQualifier
627636

628637
fromUserQualifier :: UserQualifier -> Qualifier
629638
fromUserQualifier UserQualToplevel = QualToplevel
630639
fromUserQualifier (UserQualSetup name) = QualSetup name
631640
fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2
632641

633642
fromUserConstraintScope :: UserConstraintScope -> ConstraintScope
634-
fromUserConstraintScope (UserQualified q pn) =
635-
ScopeQualified (fromUserQualifier q) pn
636-
fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn
637-
fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn
643+
fromUserConstraintScope (UserConstraintScope mstage (UserQualified q pn)) =
644+
ConstraintScope mstage (ScopeQualified (fromUserQualifier q) pn)
645+
fromUserConstraintScope (UserConstraintScope mstage (UserAnySetupQualifier pn)) =
646+
ConstraintScope mstage (ScopeAnySetupQualifier pn)
647+
fromUserConstraintScope (UserConstraintScope mstage (UserAnyQualifier pn)) =
648+
ConstraintScope mstage (ScopeAnyQualifier pn)
638649

639650
-- | Version of 'PackageConstraint' that the user can specify on
640651
-- the command line.
641652
data UserConstraint
642-
= UserConstraint UserConstraintScope PackageProperty
653+
= UserConstraintX UserConstraintScope PackageProperty
643654
deriving (Eq, Show, Generic)
644655

645656
instance Binary UserConstraint
646657
instance Structured UserConstraint
647658

659+
pattern UserConstraint :: UserConstraintQualifier -> PackageProperty -> UserConstraint
660+
pattern UserConstraint qualifier prop = UserConstraintX (UserConstraintScope Nothing qualifier) prop
661+
662+
pattern UserConstraintStaged :: Stage -> UserConstraintQualifier -> PackageProperty -> UserConstraint
663+
pattern UserConstraintStaged stage qualifier prop = UserConstraintX (UserConstraintScope (Just stage) qualifier) prop
664+
648665
userConstraintPackageName :: UserConstraint -> PackageName
649-
userConstraintPackageName (UserConstraint scope _) = scopePN scope
666+
userConstraintPackageName (UserConstraintX (UserConstraintScope _stage qualifier) _) = scopePN qualifier
650667
where
651668
scopePN (UserQualified _ pn) = pn
652669
scopePN (UserAnyQualifier pn) = pn
653670
scopePN (UserAnySetupQualifier pn) = pn
654671

655672
userToPackageConstraint :: UserConstraint -> PackageConstraint
656-
userToPackageConstraint (UserConstraint scope prop) =
673+
userToPackageConstraint (UserConstraintX scope prop) =
657674
PackageConstraint (fromUserConstraintScope scope) prop
658675

659676
readUserConstraint :: String -> Either String UserConstraint
@@ -668,7 +685,7 @@ readUserConstraint str =
668685
++ "'source', 'test', 'bench', or flags. "
669686

670687
instance Pretty UserConstraint where
671-
pretty (UserConstraint scope prop) =
688+
pretty (UserConstraintX scope prop) =
672689
pretty $ PackageConstraint (fromUserConstraintScope scope) prop
673690

674691
instance Parsec UserConstraint where
@@ -684,25 +701,49 @@ instance Parsec UserConstraint where
684701
, PackagePropertyStanzas [TestStanzas] <$ P.string "test"
685702
, PackagePropertyStanzas [BenchStanzas] <$ P.string "bench"
686703
]
687-
return (UserConstraint scope prop)
704+
return (UserConstraintX scope prop)
688705
where
689706
parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope
690707
parseConstraintScope = do
708+
mstage <- P.optional (P.try (parsec <* P.char ':'))
691709
pn <- parsec
692-
P.choice
693-
[ P.char '.' *> withDot pn
694-
, P.char ':' *> withColon pn
695-
, return (UserQualified UserQualToplevel pn)
696-
]
710+
c <-
711+
P.choice
712+
[ P.char '.' *> withDot pn
713+
, P.char ':' *> withColon pn
714+
, return (UserQualified UserQualToplevel pn)
715+
]
716+
return $ UserConstraintScope mstage c
697717
where
698-
withDot :: PackageName -> m UserConstraintScope
718+
withDot :: PackageName -> m UserConstraintQualifier
699719
withDot pn
700720
| pn == mkPackageName "any" = UserAnyQualifier <$> parsec
701721
| pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec
702722
| otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn
703723

704-
withColon :: PackageName -> m UserConstraintScope
724+
withColon :: PackageName -> m UserConstraintQualifier
705725
withColon pn =
706726
UserQualified (UserQualSetup pn)
707727
<$ P.string "setup."
708728
<*> parsec
729+
730+
-- >>> eitherParsec "foo > 1.2.3.4" :: Either String UserConstraint
731+
-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
732+
--
733+
-- >>> eitherParsec "foo ^>= 1.2.3.4" :: Either String UserConstraint
734+
-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (MajorBoundVersion (mkVersion [1,2,3,4]))))
735+
--
736+
-- >>> eitherParsec "foo:setup.bar > 1.2.3.4" :: Either String UserConstraint
737+
-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualSetup (PackageName "foo")) (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4]))))
738+
--
739+
-- >>> eitherParsec "setup.any source" :: Either String UserConstraint
740+
-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertySource)
741+
--
742+
-- >>> eitherParsec "build:rts source" :: Either String UserConstraint
743+
-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "rts"))) PackagePropertySource)
744+
--
745+
-- >>> eitherParsec "setup.any installed" :: Either String UserConstraint
746+
-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertyInstalled)
747+
--
748+
-- >>> eitherParsec "build:ghc-internal installed" :: Either String UserConstraint
749+
-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "ghc-internal"))) PackagePropertyInstalled)

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -52,7 +52,7 @@ pkgSpecifierConstraints (SpecificSourcePackage pkg) =
5252
where
5353
pc =
5454
PackageConstraint
55-
(ScopeTarget $ packageName pkg)
55+
(scopeToplevel (packageName pkg))
5656
(PackagePropertyVersion $ thisVersion (packageVersion pkg))
5757

5858
mkNamedPackage :: PackageIdentifier -> PackageSpecifier pkg

‎cabal-install/tests/IntegrationTests2.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -31,7 +31,7 @@ import Distribution.Client.TargetSelector hiding (DirActions (..))
3131
import qualified Distribution.Client.TargetSelector as TS (DirActions (..))
3232
import Distribution.Client.Targets
3333
( UserConstraint (..)
34-
, UserConstraintScope (UserAnyQualifier)
34+
, UserConstraintQualifier (UserAnyQualifier)
3535
)
3636
import Distribution.Client.Types
3737
( PackageLocation (..)

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -288,6 +288,10 @@ instance Arbitrary UserConstraintScope where
288288
arbitrary = genericArbitrary
289289
shrink = genericShrink
290290

291+
instance Arbitrary UserConstraintQualifier where
292+
arbitrary = genericArbitrary
293+
shrink = genericShrink
294+
291295
instance Arbitrary UserQualifier where
292296
arbitrary =
293297
oneof

‎cabal-install/tests/UnitTests/Distribution/Client/Targets.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ module UnitTests.Distribution.Client.Targets
44

55
import Distribution.Client.Targets
66
( UserConstraint (..)
7-
, UserConstraintScope (..)
7+
, UserConstraintQualifier (..)
88
, UserQualifier (..)
99
, readUserConstraint
1010
)

0 commit comments

Comments
 (0)