Skip to content

Commit e36c0e7

Browse files
dcouttsdcoutts
committed
Add project config round trip QC tests
Two kinds of round-trip test: * type conversion ProjectConfig -> LegcyProjectConfig and back * ProjectConfig -> print -> parse The latter goes out to the config file format and back. These tests uncovered a number of issues in our general config code.
1 parent 324b324 commit e36c0e7

File tree

4 files changed

+786
-0
lines changed

4 files changed

+786
-0
lines changed

‎cabal-install/cabal-install.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -271,6 +271,7 @@ Test-Suite unit-tests
271271
hs-source-dirs: tests, .
272272
ghc-options: -Wall -fwarn-tabs
273273
other-modules:
274+
UnitTests.Distribution.Client.ArbitraryInstances
274275
UnitTests.Distribution.Client.Targets
275276
UnitTests.Distribution.Client.Compat.Time
276277
UnitTests.Distribution.Client.Dependency.Modular.PSQ
@@ -282,6 +283,7 @@ Test-Suite unit-tests
282283
UnitTests.Distribution.Client.Sandbox.Timestamp
283284
UnitTests.Distribution.Client.Tar
284285
UnitTests.Distribution.Client.UserConfig
286+
UnitTests.Distribution.Client.ProjectConfig
285287
UnitTests.Options
286288
build-depends:
287289
base,

‎cabal-install/tests/UnitTests.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,7 @@ import qualified UnitTests.Distribution.Client.Sandbox.Timestamp
2424
import qualified UnitTests.Distribution.Client.Tar
2525
import qualified UnitTests.Distribution.Client.Targets
2626
import qualified UnitTests.Distribution.Client.UserConfig
27+
import qualified UnitTests.Distribution.Client.ProjectConfig
2728

2829
import UnitTests.Options
2930

@@ -56,6 +57,8 @@ tests mtimeChangeCalibrated =
5657
UnitTests.Distribution.Client.Targets.tests
5758
, testGroup "UnitTests.Distribution.Client.UserConfig"
5859
UnitTests.Distribution.Client.UserConfig.tests
60+
, testGroup "UnitTests.Distribution.Client.ProjectConfig"
61+
UnitTests.Distribution.Client.ProjectConfig.tests
5962
]
6063

6164
main :: IO ()

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

Lines changed: 172 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,172 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# OPTIONS_GHC -fno-warn-orphans #-}
3+
4+
module UnitTests.Distribution.Client.ArbitraryInstances (
5+
adjustSize,
6+
shortListOf,
7+
shortListOf1,
8+
arbitraryFlag,
9+
ShortToken(..),
10+
arbitraryShortToken,
11+
NonMEmpty(..),
12+
NoShrink(..),
13+
) where
14+
15+
import Data.Char
16+
import Data.List
17+
#if !MIN_VERSION_base(4,8,0)
18+
import Data.Monoid
19+
import Control.Applicative
20+
#endif
21+
import Control.Monad
22+
23+
import Distribution.Version
24+
import Distribution.Package
25+
import Distribution.System
26+
import Distribution.Verbosity
27+
28+
import Distribution.Simple.Setup
29+
import Distribution.Simple.InstallDirs
30+
31+
import Distribution.Utils.NubList
32+
33+
import Test.QuickCheck
34+
35+
36+
adjustSize :: (Int -> Int) -> Gen a -> Gen a
37+
adjustSize adjust gen = sized (\n -> resize (adjust n) gen)
38+
39+
shortListOf :: Int -> Gen a -> Gen [a]
40+
shortListOf bound gen =
41+
sized $ \n -> do
42+
k <- choose (0, (n `div` 2) `min` bound)
43+
vectorOf k gen
44+
45+
shortListOf1 :: Int -> Gen a -> Gen [a]
46+
shortListOf1 bound gen =
47+
sized $ \n -> do
48+
k <- choose (1, 1 `max` ((n `div` 2) `min` bound))
49+
vectorOf k gen
50+
51+
newtype ShortToken = ShortToken { getShortToken :: String }
52+
deriving Show
53+
54+
instance Arbitrary ShortToken where
55+
arbitrary =
56+
ShortToken <$>
57+
(shortListOf1 5 (choose ('#', '~'))
58+
`suchThat` (not . ("[]" `isPrefixOf`)))
59+
--TODO: [code cleanup] need to replace parseHaskellString impl to stop
60+
-- accepting Haskell list syntax [], ['a'] etc, just allow String syntax.
61+
-- Workaround, don't generate [] as this does not round trip.
62+
63+
64+
shrink (ShortToken cs) =
65+
[ ShortToken cs' | cs' <- shrink cs, not (null cs') ]
66+
67+
arbitraryShortToken :: Gen String
68+
arbitraryShortToken = getShortToken <$> arbitrary
69+
70+
instance Arbitrary Version where
71+
arbitrary = do
72+
branch <- shortListOf1 4 $
73+
frequency [(3, return 0)
74+
,(3, return 1)
75+
,(2, return 2)
76+
,(1, return 3)]
77+
return (Version branch []) -- deliberate []
78+
where
79+
80+
shrink (Version branch []) =
81+
[ Version branch' [] | branch' <- shrink branch, not (null branch') ]
82+
shrink (Version branch _tags) =
83+
[ Version branch [] ]
84+
85+
instance Arbitrary VersionRange where
86+
arbitrary = canonicaliseVersionRange <$> sized verRangeExp
87+
where
88+
verRangeExp n = frequency $
89+
[ (2, return anyVersion)
90+
, (1, liftM thisVersion arbitrary)
91+
, (1, liftM laterVersion arbitrary)
92+
, (1, liftM orLaterVersion arbitrary)
93+
, (1, liftM orLaterVersion' arbitrary)
94+
, (1, liftM earlierVersion arbitrary)
95+
, (1, liftM orEarlierVersion arbitrary)
96+
, (1, liftM orEarlierVersion' arbitrary)
97+
, (1, liftM withinVersion arbitrary)
98+
, (2, liftM VersionRangeParens arbitrary)
99+
] ++ if n == 0 then [] else
100+
[ (2, liftM2 unionVersionRanges verRangeExp2 verRangeExp2)
101+
, (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2)
102+
]
103+
where
104+
verRangeExp2 = verRangeExp (n `div` 2)
105+
106+
orLaterVersion' v =
107+
unionVersionRanges (laterVersion v) (thisVersion v)
108+
orEarlierVersion' v =
109+
unionVersionRanges (earlierVersion v) (thisVersion v)
110+
111+
canonicaliseVersionRange = fromVersionIntervals . toVersionIntervals
112+
113+
instance Arbitrary PackageName where
114+
arbitrary = PackageName . intercalate "-" <$> shortListOf1 2 nameComponent
115+
where
116+
nameComponent = shortListOf1 5 (elements packageChars)
117+
`suchThat` (not . all isDigit)
118+
packageChars = filter isAlphaNum ['\0'..'\127']
119+
120+
instance Arbitrary Dependency where
121+
arbitrary = Dependency <$> arbitrary <*> arbitrary
122+
123+
instance Arbitrary OS where
124+
arbitrary = elements knownOSs
125+
126+
instance Arbitrary Arch where
127+
arbitrary = elements knownArches
128+
129+
instance Arbitrary Platform where
130+
arbitrary = Platform <$> arbitrary <*> arbitrary
131+
132+
instance Arbitrary a => Arbitrary (Flag a) where
133+
arbitrary = arbitraryFlag arbitrary
134+
shrink NoFlag = []
135+
shrink (Flag x) = NoFlag : [ Flag x' | x' <- shrink x ]
136+
137+
arbitraryFlag :: Gen a -> Gen (Flag a)
138+
arbitraryFlag genA =
139+
sized $ \sz ->
140+
case sz of
141+
0 -> pure NoFlag
142+
_ -> frequency [ (1, pure NoFlag)
143+
, (3, Flag <$> genA) ]
144+
145+
146+
instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where
147+
arbitrary = toNubList <$> arbitrary
148+
shrink xs = [ toNubList [] | (not . null) (fromNubList xs) ]
149+
-- try empty, otherwise don't shrink as it can loop
150+
151+
instance Arbitrary Verbosity where
152+
arbitrary = elements [minBound..maxBound]
153+
154+
instance Arbitrary PathTemplate where
155+
arbitrary = toPathTemplate <$> arbitraryShortToken
156+
shrink t = [ toPathTemplate s | s <- shrink (show t), not (null s) ]
157+
158+
159+
newtype NonMEmpty a = NonMEmpty { getNonMEmpty :: a }
160+
deriving (Eq, Ord, Show)
161+
162+
instance (Arbitrary a, Monoid a, Eq a) => Arbitrary (NonMEmpty a) where
163+
arbitrary = NonMEmpty <$> (arbitrary `suchThat` (/= mempty))
164+
shrink (NonMEmpty x) = [ NonMEmpty x' | x' <- shrink x, x' /= mempty ]
165+
166+
newtype NoShrink a = NoShrink { getNoShrink :: a }
167+
deriving (Eq, Ord, Show)
168+
169+
instance Arbitrary a => Arbitrary (NoShrink a) where
170+
arbitrary = NoShrink <$> arbitrary
171+
shrink _ = []
172+

0 commit comments

Comments
 (0)