Skip to content

Commit 3d1bb8f

Browse files
mergify[bot]mergify[bot]
authored
Merge of #11684 
2 parents ac2123d + 335c948 commit 3d1bb8f

4 files changed

Lines changed: 279 additions & 2 deletions

File tree

‎cabal-install/cabal-install.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -341,6 +341,7 @@ test-suite unit-tests
341341
UnitTests.Distribution.Client.Glob
342342
UnitTests.Distribution.Client.GZipUtils
343343
UnitTests.Distribution.Client.IndexUtils
344+
UnitTests.Distribution.Client.IndexUtils.ActiveRepos
344345
UnitTests.Distribution.Client.IndexUtils.Timestamp
345346
UnitTests.Distribution.Client.Init
346347
UnitTests.Distribution.Client.Init.Golden

‎cabal-install/tests/UnitTests.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import qualified UnitTests.Distribution.Client.GZipUtils
99
import qualified UnitTests.Distribution.Client.Get
1010
import qualified UnitTests.Distribution.Client.Glob
1111
import qualified UnitTests.Distribution.Client.IndexUtils
12+
import qualified UnitTests.Distribution.Client.IndexUtils.ActiveRepos
1213
import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp
1314
import qualified UnitTests.Distribution.Client.Init
1415
import qualified UnitTests.Distribution.Client.InstallPlan
@@ -52,6 +53,9 @@ main = do
5253
, testGroup
5354
"UnitTests.Distribution.Client.IndexUtils"
5455
UnitTests.Distribution.Client.IndexUtils.tests
56+
, testGroup
57+
"UnitTests.Distribution.Client.IndexUtils.ActiveRepos"
58+
UnitTests.Distribution.Client.IndexUtils.ActiveRepos.tests
5559
, testGroup
5660
"UnitTests.Distribution.Client.IndexUtils.Timestamp"
5761
UnitTests.Distribution.Client.IndexUtils.Timestamp.tests

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

Lines changed: 122 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,21 +1,29 @@
11
module UnitTests.Distribution.Client.IndexUtils where
22

33
import Distribution.Client.IndexUtils
4+
import Distribution.Client.IndexUtils.ActiveRepos
45
import qualified Distribution.Compat.NonEmptySet as NES
6+
import Distribution.Package
57
import Distribution.Simple.Utils (toUTF8LBS)
6-
import Distribution.Types.Dependency
8+
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
79
import Distribution.Types.LibraryName
8-
import Distribution.Types.PackageName
910
import Distribution.Version
1011

12+
import Data.List (sort)
13+
1114
import Test.Tasty
1215
import Test.Tasty.HUnit
1316

1417
tests :: [TestTree]
1518
tests =
1619
[ simpleVersionsParserTests
20+
, indexCombiningTests
1721
]
1822

23+
-- ---------------------------------------------------------------------------
24+
-- Preferred-versions parser tests
25+
-- ---------------------------------------------------------------------------
26+
1927
simpleVersionsParserTests :: TestTree
2028
simpleVersionsParserTests =
2129
testGroup
@@ -80,3 +88,115 @@ simpleVersionsParserTests =
8088
]
8189
, preferredVersionsOriginalDependency = "binary 0.9.0.0 || > 0.9.0.0"
8290
}
91+
92+
-- ---------------------------------------------------------------------------
93+
-- Index-combining tests
94+
--
95+
-- These test the addIndex / foldl' logic inside getSourcePackagesAtIndexState,
96+
-- which applies CombineStrategy to a sequence of PackageIndex values:
97+
--
98+
-- addIndex acc (_, Skip) = acc
99+
-- addIndex acc (idx, Merge) = PackageIndex.merge acc idx
100+
-- addIndex acc (idx, Override) = PackageIndex.override acc idx
101+
-- pkgs = foldl' addIndex mempty pkgss'
102+
-- ---------------------------------------------------------------------------
103+
104+
indexCombiningTests :: TestTree
105+
indexCombiningTests =
106+
testGroup
107+
"Index combining (CombineStrategy)"
108+
[ testCase "Skip: repo contributes nothing" $
109+
pkgs [(repoFoo1, CombineStrategySkip)]
110+
@?= []
111+
, testCase "Merge: single repo makes all its packages visible" $
112+
pkgs [(repoFoo1, CombineStrategyMerge)]
113+
@?= [foo1]
114+
, testCase "Override: single repo makes all its packages visible" $
115+
pkgs [(repoFoo1, CombineStrategyOverride)]
116+
@?= [foo1]
117+
, testCase "Merge+Merge: non-overlapping packages are both visible" $
118+
pkgs [(repoFoo1, CombineStrategyMerge), (repoBar1, CombineStrategyMerge)]
119+
@?= sort [foo1, bar1]
120+
, testCase "Merge+Merge: different versions of same package are both visible" $
121+
pkgs [(repoFoo1, CombineStrategyMerge), (repoFoo2, CombineStrategyMerge)]
122+
@?= sort [foo1, foo2]
123+
, testCase "Merge+Override: packages only in first repo remain visible" $
124+
pkgs [(repoFoo1, CombineStrategyMerge), (repoBar1, CombineStrategyOverride)]
125+
@?= sort [foo1, bar1]
126+
, testCase "Merge+Override: override repo replaces all versions of overlapping package" $
127+
-- repoFoo12 has foo-1.0 and foo-1.1; repoFoo2 has only foo-2.0.
128+
-- Override means repoFoo2 wins the entire 'foo' bucket.
129+
pkgs [(repoFoo12, CombineStrategyMerge), (repoFoo2, CombineStrategyOverride)]
130+
@?= [foo2]
131+
, testCase "Merge+Override: override does not affect packages absent from override repo" $
132+
pkgs [(repoFoo1bar1, CombineStrategyMerge), (repoFoo2, CombineStrategyOverride)]
133+
@?= sort [foo2, bar1]
134+
, testCase "Skip in middle: skipped repo is ignored" $
135+
pkgs
136+
[ (repoFoo1, CombineStrategyMerge)
137+
, (repoFoo2, CombineStrategySkip)
138+
, (repoBar1, CombineStrategyMerge)
139+
]
140+
@?= sort [foo1, bar1]
141+
, testCase "Skip+Merge: later merge after skip still contributes" $
142+
pkgs [(repoFoo1, CombineStrategySkip), (repoFoo2, CombineStrategyMerge)]
143+
@?= [foo2]
144+
, testCase "Override+Override: last override wins the package bucket" $
145+
pkgs
146+
[ (repoFoo1, CombineStrategyMerge)
147+
, (repoFoo2, CombineStrategyOverride)
148+
, (repoFoo3, CombineStrategyOverride)
149+
]
150+
@?= [foo3]
151+
, testCase "Override+Merge: merge after override combines both buckets" $
152+
-- foo bucket starts as {foo-2.0} after override, then merges {foo-3.0}
153+
-- giving {foo-2.0, foo-3.0}
154+
pkgs
155+
[ (repoFoo1, CombineStrategyMerge)
156+
, (repoFoo2, CombineStrategyOverride)
157+
, (repoFoo3, CombineStrategyMerge)
158+
]
159+
@?= sort [foo2, foo3]
160+
, testCase "All skip: result is empty" $
161+
pkgs
162+
[ (repoFoo1, CombineStrategySkip)
163+
, (repoFoo2, CombineStrategySkip)
164+
]
165+
@?= []
166+
, testCase "Empty repos list: result is empty" $
167+
pkgs [] @?= []
168+
]
169+
170+
-- Mirrors the addIndex / foldl' in getSourcePackagesAtIndexState.
171+
combineIndex
172+
:: PackageIndex.PackageIndex PackageIdentifier
173+
-> (PackageIndex.PackageIndex PackageIdentifier, CombineStrategy)
174+
-> PackageIndex.PackageIndex PackageIdentifier
175+
combineIndex acc (_, CombineStrategySkip) = acc
176+
combineIndex acc (idx, CombineStrategyMerge) = PackageIndex.merge acc idx
177+
combineIndex acc (idx, CombineStrategyOverride) = PackageIndex.override acc idx
178+
179+
-- Run the combining fold and return the result as a sorted list of PackageIds.
180+
pkgs
181+
:: [(PackageIndex.PackageIndex PackageIdentifier, CombineStrategy)]
182+
-> [PackageIdentifier]
183+
pkgs = sort . PackageIndex.allPackages . foldl combineIndex mempty
184+
185+
-- Test packages
186+
foo1, foo2, foo3, bar1 :: PackageIdentifier
187+
foo1 = PackageIdentifier (mkPackageName "foo") (mkVersion [1, 0])
188+
foo2 = PackageIdentifier (mkPackageName "foo") (mkVersion [2, 0])
189+
foo3 = PackageIdentifier (mkPackageName "foo") (mkVersion [3, 0])
190+
bar1 = PackageIdentifier (mkPackageName "bar") (mkVersion [1, 0])
191+
192+
-- Single-package indices
193+
repoFoo1, repoFoo2, repoFoo3, repoBar1 :: PackageIndex.PackageIndex PackageIdentifier
194+
repoFoo1 = PackageIndex.fromList [foo1]
195+
repoFoo2 = PackageIndex.fromList [foo2]
196+
repoFoo3 = PackageIndex.fromList [foo3]
197+
repoBar1 = PackageIndex.fromList [bar1]
198+
199+
-- Multi-package indices
200+
repoFoo12, repoFoo1bar1 :: PackageIndex.PackageIndex PackageIdentifier
201+
repoFoo12 = PackageIndex.fromList [foo1, foo2]
202+
repoFoo1bar1 = PackageIndex.fromList [foo1, bar1]

‎cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/ActiveRepos.hs‎

Lines changed: 152 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,152 @@
1+
module UnitTests.Distribution.Client.IndexUtils.ActiveRepos (tests) where
2+
3+
import Distribution.Client.IndexUtils.ActiveRepos
4+
import Distribution.Client.Types.RepoName (RepoName (..))
5+
import Distribution.Parsec (simpleParsec)
6+
import Distribution.Pretty (prettyShow)
7+
8+
import UnitTests.Distribution.Client.ArbitraryInstances ()
9+
10+
import Test.Tasty
11+
import Test.Tasty.HUnit
12+
import Test.Tasty.QuickCheck
13+
14+
tests :: [TestTree]
15+
tests =
16+
[ testGroup "organizeByRepos" organizeByReposTests
17+
, testGroup "filterSkippedActiveRepos" filterSkippedTests
18+
, testGroup
19+
"parse/pretty roundtrip"
20+
[ testProperty "ActiveRepos roundtrips" prop_activeReposRoundtrip
21+
]
22+
]
23+
24+
-------------------------------------------------------------------------------
25+
-- organizeByRepos
26+
-------------------------------------------------------------------------------
27+
28+
-- Convenience: run organizeByRepos over a fixed three-element repo list.
29+
organize :: ActiveRepos -> Either String [(RepoName, CombineStrategy)]
30+
organize ar = organizeByRepos ar id [RepoName "a", RepoName "b", RepoName "c"]
31+
32+
organizeByReposTests :: [TestTree]
33+
organizeByReposTests =
34+
[ testCase ":rest assigns strategy to all repos in order" $
35+
organize (ActiveRepos [ActiveRepoRest CombineStrategyMerge])
36+
@?= Right
37+
[ (RepoName "a", CombineStrategyMerge)
38+
, (RepoName "b", CombineStrategyMerge)
39+
, (RepoName "c", CombineStrategyMerge)
40+
]
41+
, testCase ":none yields empty result" $
42+
organize (ActiveRepos [])
43+
@?= Right []
44+
, testCase "named repo before :rest is placed first" $
45+
organize
46+
( ActiveRepos
47+
[ ActiveRepo (RepoName "b") CombineStrategyOverride
48+
, ActiveRepoRest CombineStrategyMerge
49+
]
50+
)
51+
@?= Right
52+
[ (RepoName "b", CombineStrategyOverride)
53+
, (RepoName "a", CombineStrategyMerge)
54+
, (RepoName "c", CombineStrategyMerge)
55+
]
56+
, testCase "named repo after :rest is placed last" $
57+
organize
58+
( ActiveRepos
59+
[ ActiveRepoRest CombineStrategyMerge
60+
, ActiveRepo (RepoName "b") CombineStrategyOverride
61+
]
62+
)
63+
@?= Right
64+
[ (RepoName "a", CombineStrategyMerge)
65+
, (RepoName "c", CombineStrategyMerge)
66+
, (RepoName "b", CombineStrategyOverride)
67+
]
68+
, testCase "named repo absent from provided list gives Left" $
69+
organize
70+
( ActiveRepos
71+
[ ActiveRepoRest CombineStrategyMerge
72+
, ActiveRepo (RepoName "d") CombineStrategyOverride
73+
]
74+
)
75+
@?= Left "no repository provided d"
76+
, testCase "named repo against empty list gives Left" $
77+
organizeByRepos
78+
(ActiveRepos [ActiveRepo (RepoName "a") CombineStrategyMerge])
79+
id
80+
([] :: [RepoName])
81+
@?= Left "no repository provided a"
82+
, testCase "skip strategy is preserved in output" $
83+
organize
84+
( ActiveRepos
85+
[ ActiveRepo (RepoName "a") CombineStrategySkip
86+
, ActiveRepoRest CombineStrategyMerge
87+
]
88+
)
89+
@?= Right
90+
[ (RepoName "a", CombineStrategySkip)
91+
, (RepoName "b", CombineStrategyMerge)
92+
, (RepoName "c", CombineStrategyMerge)
93+
]
94+
, testCase ":rest with skip strategy skips all remaining repos" $
95+
organize (ActiveRepos [ActiveRepoRest CombineStrategySkip])
96+
@?= Right
97+
[ (RepoName "a", CombineStrategySkip)
98+
, (RepoName "b", CombineStrategySkip)
99+
, (RepoName "c", CombineStrategySkip)
100+
]
101+
]
102+
103+
-------------------------------------------------------------------------------
104+
-- filterSkippedActiveRepos
105+
-------------------------------------------------------------------------------
106+
107+
filterSkippedTests :: [TestTree]
108+
filterSkippedTests =
109+
[ testCase "skipped entries are removed when no :rest is present" $
110+
filterSkippedActiveRepos
111+
( ActiveRepos
112+
[ ActiveRepo (RepoName "a") CombineStrategyMerge
113+
, ActiveRepo (RepoName "b") CombineStrategySkip
114+
]
115+
)
116+
@?= ActiveRepos [ActiveRepo (RepoName "a") CombineStrategyMerge]
117+
, testCase "all-skipped list with no :rest yields empty" $
118+
filterSkippedActiveRepos
119+
( ActiveRepos
120+
[ ActiveRepo (RepoName "a") CombineStrategySkip
121+
, ActiveRepo (RepoName "b") CombineStrategySkip
122+
]
123+
)
124+
@?= ActiveRepos []
125+
, testCase "list without any skipped entries is unchanged" $
126+
let ar =
127+
ActiveRepos
128+
[ ActiveRepo (RepoName "a") CombineStrategyMerge
129+
, ActiveRepo (RepoName "b") CombineStrategyOverride
130+
]
131+
in filterSkippedActiveRepos ar @?= ar
132+
, testCase "skipped entries are kept when :rest is present" $
133+
-- filterSkippedActiveRepos is a no-op when ActiveRepoRest appears
134+
let ar =
135+
ActiveRepos
136+
[ ActiveRepoRest CombineStrategyMerge
137+
, ActiveRepo (RepoName "b") CombineStrategySkip
138+
]
139+
in filterSkippedActiveRepos ar @?= ar
140+
, testCase ":rest with skip strategy is kept unchanged" $
141+
let ar = ActiveRepos [ActiveRepoRest CombineStrategySkip]
142+
in filterSkippedActiveRepos ar @?= ar
143+
]
144+
145+
-------------------------------------------------------------------------------
146+
-- Parse/pretty roundtrip
147+
-------------------------------------------------------------------------------
148+
149+
prop_activeReposRoundtrip :: ActiveRepos -> Property
150+
prop_activeReposRoundtrip ar =
151+
counterexample ("prettyShow: " ++ prettyShow ar) $
152+
simpleParsec (prettyShow ar) === Just ar

0 commit comments

Comments
 (0)