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