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