Skip to content

Commit 84d2a5e

Browse files
phadejphadej
committed
Add OptionalStanzaSet and OptionalStanzaMap
1 parent 929be84 commit 84d2a5e

File tree

17 files changed

+222
-81
lines changed

17 files changed

+222
-81
lines changed

‎Makefile

Lines changed: 9 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -115,7 +115,7 @@ doctest :
115115

116116
# This is not run as part of validate.sh (we need hackage-security, which is tricky to get).
117117
doctest-cli :
118-
doctest -D__DOCTEST__ --fast cabal-install/src
118+
doctest -D__DOCTEST__ --fast cabal-install/src cabal-install/cabal-install-solver/src cabal-install/cabal-install-solver/src-assertion
119119

120120
# tests
121121

@@ -143,6 +143,14 @@ cabal-install-test:
143143
rm -rf .ghc.environment.*
144144
cd cabal-testsuite && `cabal-plan list-bin cabal-tests` --with-cabal=`cabal-plan list-bin cabal` --hide-successes -j3 ${TEST}
145145

146+
# hackage-benchmarks (solver)
147+
148+
hackage-benchmarks-run:
149+
$(CABALBUILD) -j3 hackage-benchmark cabal
150+
rm -rf .ghc.environment.*
151+
$$(cabal-plan list-bin hackage-benchmark) --cabal1=cabal --cabal2=$$(cabal-plan list-bin cabal) --packages="hakyll servant-auth-server" --print-trials --concurrently
152+
153+
146154
# This doesn't run build, as you first need to test with cabal-install-test :)
147155
cabal-install-test-accept:
148156
@which cabal-plan

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

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -72,11 +72,10 @@ toCPs (A pa fa sa) rdm =
7272
M.toList $
7373
fa
7474
-- Stanzas per package.
75-
sapp :: Map QPN [OptionalStanza]
76-
sapp = M.fromListWith (++) $
77-
L.map (\ ((SN qpn sn), b) -> (qpn, if b then [sn] else [])) $
78-
M.toList $
79-
sa
75+
sapp :: Map QPN OptionalStanzaSet
76+
sapp = M.fromListWith mappend
77+
$ L.map (\ ((SN qpn sn), b) -> (qpn, if b then optStanzaSetSingleton sn else mempty))
78+
$ M.toList sa
8079
-- Dependencies per package.
8180
depp :: QPN -> [(Component, PI QPN)]
8281
depp qpn = let v :: Vertex

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,4 +10,4 @@ import Distribution.Solver.Types.OptionalStanza
1010

1111
-- | A configured package is a package instance together with
1212
-- a flag assignment and complete dependencies.
13-
data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn])
13+
data CP qpn = CP (PI qpn) FlagAssignment OptionalStanzaSet (ComponentDeps [PI qpn])

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

Lines changed: 119 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,39 @@
1-
{-# LANGUAGE DeriveGeneric #-}
21
{-# LANGUAGE DeriveDataTypeable #-}
3-
module Distribution.Solver.Types.OptionalStanza
4-
( OptionalStanza(..)
5-
, showStanza
6-
, enableStanzas
7-
) where
2+
{-# LANGUAGE DeriveGeneric #-}
3+
module Distribution.Solver.Types.OptionalStanza (
4+
-- * OptionalStanza
5+
OptionalStanza(..),
6+
showStanza,
7+
showStanzas,
8+
enableStanzas,
9+
-- * Set of stanzas
10+
OptionalStanzaSet,
11+
optStanzaSetFromList,
12+
optStanzaSetToList,
13+
optStanzaSetMember,
14+
optStanzaSetInsert,
15+
optStanzaSetSingleton,
16+
optStanzaSetIntersection,
17+
optStanzaSetNull,
18+
optStanzaSetIsSubset,
19+
-- * Map indexed by stanzas
20+
OptionalStanzaMap,
21+
optStanzaTabulate,
22+
optStanzaIndex,
23+
optStanzaLookup,
24+
optStanzaKeysFilteredByValue,
25+
) where
826

927
import Distribution.Solver.Compat.Prelude
1028
import Prelude ()
11-
import Distribution.Types.ComponentRequestedSpec
12-
(ComponentRequestedSpec(..))
29+
30+
import Data.Bits (testBit, (.|.), (.&.))
31+
import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec (..))
32+
import Distribution.Utils.Structured (Structured (..), nominalStructure)
33+
34+
-------------------------------------------------------------------------------
35+
-- OptionalStanza
36+
-------------------------------------------------------------------------------
1337

1438
data OptionalStanza
1539
= TestStanzas
@@ -21,16 +45,94 @@ showStanza :: OptionalStanza -> String
2145
showStanza TestStanzas = "test"
2246
showStanza BenchStanzas = "bench"
2347

24-
-- | Convert a list of 'OptionalStanza' into the corresponding
25-
-- 'ComponentRequestedSpec' which records what components are enabled.
48+
showStanzas :: OptionalStanzaSet -> String
49+
showStanzas = unwords . map (("*" ++) . showStanza) . optStanzaSetToList
2650

27-
-- Note: [OptionalStanza] could become PerOptionalStanza Bool.
28-
-- See https://github.com/haskell/cabal/issues/6918
29-
enableStanzas :: [OptionalStanza] -> ComponentRequestedSpec
30-
enableStanzas optionalStanzas = ComponentRequestedSpec {
31-
testsRequested = any (== TestStanzas) optionalStanzas
32-
, benchmarksRequested = any (== BenchStanzas) optionalStanzas
33-
}
51+
-- | Convert a list of 'OptionalStanza' into the corresponding
52+
-- Cabal's 'ComponentRequestedSpec' which records what components are enabled.
53+
--
54+
enableStanzas :: OptionalStanzaSet -> ComponentRequestedSpec
55+
enableStanzas optionalStanzas = ComponentRequestedSpec
56+
{ testsRequested = optStanzaSetMember TestStanzas optionalStanzas
57+
, benchmarksRequested = optStanzaSetMember BenchStanzas optionalStanzas
58+
}
3459

3560
instance Binary OptionalStanza
3661
instance Structured OptionalStanza
62+
63+
-------------------------------------------------------------------------------
64+
-- OptionalStanzaSet
65+
-------------------------------------------------------------------------------
66+
67+
newtype OptionalStanzaSet = OptionalStanzaSet Word
68+
deriving (Eq, Ord, Show)
69+
70+
instance Binary OptionalStanzaSet where
71+
put (OptionalStanzaSet w) = put w
72+
get = fmap (OptionalStanzaSet . (.&. 0x03)) get
73+
74+
instance Structured OptionalStanzaSet where
75+
structure = nominalStructure
76+
77+
optStanzaSetFromList :: [OptionalStanza] -> OptionalStanzaSet
78+
optStanzaSetFromList = foldl' (flip optStanzaSetInsert) mempty
79+
80+
optStanzaSetToList :: OptionalStanzaSet -> [OptionalStanza]
81+
optStanzaSetToList (OptionalStanzaSet 0) = []
82+
optStanzaSetToList (OptionalStanzaSet 1) = [TestStanzas]
83+
optStanzaSetToList (OptionalStanzaSet 2) = [BenchStanzas]
84+
optStanzaSetToList (OptionalStanzaSet 3) = [TestStanzas, BenchStanzas]
85+
optStanzaSetToList (OptionalStanzaSet _) = []
86+
87+
optStanzaSetInsert :: OptionalStanza -> OptionalStanzaSet -> OptionalStanzaSet
88+
optStanzaSetInsert x s = optStanzaSetSingleton x <> s
89+
90+
optStanzaSetMember :: OptionalStanza -> OptionalStanzaSet -> Bool
91+
optStanzaSetMember TestStanzas (OptionalStanzaSet w) = testBit w 0
92+
optStanzaSetMember BenchStanzas (OptionalStanzaSet w) = testBit w 1
93+
94+
optStanzaSetSingleton :: OptionalStanza -> OptionalStanzaSet
95+
optStanzaSetSingleton TestStanzas = OptionalStanzaSet 1
96+
optStanzaSetSingleton BenchStanzas = OptionalStanzaSet 2
97+
98+
optStanzaSetIntersection :: OptionalStanzaSet -> OptionalStanzaSet -> OptionalStanzaSet
99+
optStanzaSetIntersection (OptionalStanzaSet a) (OptionalStanzaSet b) = OptionalStanzaSet (a .&. b)
100+
101+
optStanzaSetNull :: OptionalStanzaSet -> Bool
102+
optStanzaSetNull (OptionalStanzaSet w) = w == 0
103+
104+
optStanzaSetIsSubset :: OptionalStanzaSet -> OptionalStanzaSet -> Bool
105+
optStanzaSetIsSubset (OptionalStanzaSet a) (OptionalStanzaSet b) = (a .|. b) == b
106+
107+
instance Semigroup OptionalStanzaSet where
108+
OptionalStanzaSet a <> OptionalStanzaSet b = OptionalStanzaSet (a .|. b)
109+
110+
instance Monoid OptionalStanzaSet where
111+
mempty = OptionalStanzaSet 0
112+
mappend = (<>)
113+
114+
-------------------------------------------------------------------------------
115+
-- OptionalStanzaMap
116+
-------------------------------------------------------------------------------
117+
118+
-- | Note: this is total map.
119+
data OptionalStanzaMap a = OptionalStanzaMap a a
120+
deriving (Eq, Ord, Show, Generic)
121+
122+
instance Binary a => Binary (OptionalStanzaMap a)
123+
instance Structured a => Structured (OptionalStanzaMap a)
124+
125+
optStanzaTabulate :: (OptionalStanza -> a) -> OptionalStanzaMap a
126+
optStanzaTabulate f = OptionalStanzaMap (f TestStanzas) (f BenchStanzas)
127+
128+
optStanzaIndex :: OptionalStanzaMap a -> OptionalStanza -> a
129+
optStanzaIndex (OptionalStanzaMap x _) TestStanzas = x
130+
optStanzaIndex (OptionalStanzaMap _ x) BenchStanzas = x
131+
132+
optStanzaLookup :: OptionalStanza -> OptionalStanzaMap a -> a
133+
optStanzaLookup = flip optStanzaIndex
134+
135+
optStanzaKeysFilteredByValue :: (a -> Bool) -> OptionalStanzaMap a -> OptionalStanzaSet
136+
optStanzaKeysFilteredByValue p (OptionalStanzaMap x y)
137+
| p x = if p y then OptionalStanzaSet 3 else OptionalStanzaSet 1
138+
| otherwise = if p y then OptionalStanzaSet 2 else OptionalStanzaSet 0

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ import Distribution.Solver.Types.SourcePackage
2323
data SolverPackage loc = SolverPackage {
2424
solverPkgSource :: SourcePackage loc,
2525
solverPkgFlags :: FlagAssignment,
26-
solverPkgStanzas :: [OptionalStanza],
26+
solverPkgStanzas :: OptionalStanzaSet,
2727
solverPkgLibDeps :: ComponentDeps [SolverId],
2828
solverPkgExeDeps :: ComponentDeps [SolverId]
2929
}

‎cabal-install/cabal-install.cabal.dev

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -368,6 +368,7 @@ Test-Suite unit-tests
368368
UnitTests.Distribution.Solver.Modular.Solver
369369
UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
370370
UnitTests.Distribution.Solver.Modular.WeightedPSQ
371+
UnitTests.Distribution.Solver.Types.OptionalStanza
371372
UnitTests.Options
372373
UnitTests.TempTestDir
373374
build-depends:

‎cabal-install/cabal-install.cabal.zinza

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -437,6 +437,7 @@ Test-Suite unit-tests
437437
UnitTests.Distribution.Solver.Modular.Solver
438438
UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
439439
UnitTests.Distribution.Solver.Modular.WeightedPSQ
440+
UnitTests.Distribution.Solver.Types.OptionalStanza
440441
UnitTests.Options
441442
UnitTests.TempTestDir
442443
build-depends:

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -414,9 +414,9 @@ configurePackage verbosity platform comp scriptOptions configFlags
414414
-- NB: if the user explicitly specified
415415
-- --enable-tests/--enable-benchmarks, always respect it.
416416
-- (But if they didn't, let solver decide.)
417-
configBenchmarks = toFlag (BenchStanzas `elem` stanzas)
417+
configBenchmarks = toFlag (BenchStanzas `optStanzaSetMember` stanzas)
418418
`mappend` configBenchmarks configFlags,
419-
configTests = toFlag (TestStanzas `elem` stanzas)
419+
configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas)
420420
`mappend` configTests configFlags
421421
}
422422

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

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -696,9 +696,6 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
696696
confPkgSource cpkg))
697697
in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment
698698

699-
showStanzas :: [OptionalStanza] -> String
700-
showStanzas = unwords . map (("*" ++) . showStanza)
701-
702699
change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed"
703700
change (InBoth pkgid pkgid') = prettyShow pkgid ++ " -> "
704701
++ prettyShow (mungedVersion pkgid')
@@ -1212,7 +1209,7 @@ installReadyPackage platform cinfo configFlags
12121209
-- Use '--exact-configuration' if supported.
12131210
configExactConfiguration = toFlag True,
12141211
configBenchmarks = toFlag False,
1215-
configTests = toFlag (TestStanzas `elem` stanzas)
1212+
configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas)
12161213
} source pkg pkgoverride
12171214
where
12181215
pkg = case finalizePD flags (enableStanzas stanzas)

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

Lines changed: 1 addition & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -856,7 +856,7 @@ printPlan verbosity
856856
then prettyShow (installedUnitId elab)
857857
else prettyShow (packageId elab)
858858
, case elabPkgOrComp elab of
859-
ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg)
859+
ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg))
860860
ElabComponent comp ->
861861
"(" ++ showComp elab comp ++ ")"
862862
, showFlagAssignment (nonDefaultFlags elab)
@@ -879,12 +879,6 @@ printPlan verbosity
879879
nonDefaultFlags elab =
880880
elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab
881881

882-
showStanzas pkg = concat
883-
$ [ " *test"
884-
| TestStanzas `Set.member` pkgStanzasEnabled pkg ]
885-
++ [ " *bench"
886-
| BenchStanzas `Set.member` pkgStanzasEnabled pkg ]
887-
888882
showTargets elab
889883
| null (elabBuildTargets elab) = ""
890884
| otherwise

0 commit comments

Comments
 (0)