diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,15 @@ +0.2.0 + +Author: Antoine Latter + +* Add support for older versions of QuickCheck. + +Author: PHO + +* Provide 'CoArbitrary' instances for types. + +* Provide 'shrink' for more instances of 'Arbitrary'. + +0.1.0 + +* Initial release diff --git a/quickcheck-instances.cabal b/quickcheck-instances.cabal --- a/quickcheck-instances.cabal +++ b/quickcheck-instances.cabal @@ -1,5 +1,5 @@ Name: quickcheck-instances -Version: 0.1.0 +Version: 0.2.0 Synopsis: Common quickcheck instances Description: QuickCheck instances. . @@ -24,7 +24,7 @@ Copyright: Copyright Antoine Latter, 2012 Category: Testing Build-type: Simple --- Extra-source-files: +Extra-source-files: CHANGES Cabal-version: >=1.6 Source-repository head @@ -46,6 +46,6 @@ time >= 1.1 && < 1.5 Ghc-options: -Wall - -- Other-modules: + Other-modules: Test.QuickCheck.Instances.LegacyNumeric -- Build-tools: diff --git a/src/Test/QuickCheck/Instances.hs b/src/Test/QuickCheck/Instances.hs --- a/src/Test/QuickCheck/Instances.hs +++ b/src/Test/QuickCheck/Instances.hs @@ -1,10 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Instances are provided for the types in the packages: - * array - We only provide instances for arrays inexed by - Integral types. + * array * bytestring @@ -47,24 +47,46 @@ import qualified Data.Tree as Tree import qualified System.Time as OldTime +import Test.QuickCheck.Instances.LegacyNumeric() + -- Array -instance (Array.Ix i, Integral i, Arbitrary e) => Arbitrary (Array.Array i e) where +instance (Array.Ix i, Arbitrary i, Arbitrary e) => Arbitrary (Array.Array i e) where arbitrary = arbitraryArray + shrink = shrinkArray -instance (Array.IArray Array.UArray e, Array.Ix i, Integral i, Arbitrary e) +instance (Array.IArray Array.UArray e, Array.Ix i, Arbitrary i, Arbitrary e) => Arbitrary (Array.UArray i e) where arbitrary = arbitraryArray + shrink = shrinkArray -arbitraryArray :: (Array.IArray a e, Array.Ix i, Integral i, Arbitrary e) => Gen (a i e) +instance (Array.Ix i, CoArbitrary i, CoArbitrary e) => CoArbitrary (Array.Array i e) where + coarbitrary = coarbitraryArray + +instance (Array.IArray Array.UArray e, Array.Ix i, CoArbitrary i, CoArbitrary e) + => CoArbitrary (Array.UArray i e) where + coarbitrary = coarbitraryArray + +arbitraryArray :: (Array.IArray a e, Array.Ix i, Arbitrary i, Arbitrary e) => Gen (a i e) arbitraryArray = do - b1 <- arbitrarySizedIntegral - b2 <- arbitrarySizedIntegral + b1 <- arbitrary + b2 <- arbitrary let bounds = if b1 < b2 then (b1,b2) else (b2,b1) elms <- vector (Array.rangeSize bounds) return $ Array.listArray bounds elms +shrinkArray :: (Array.IArray a e, Array.Ix i, Arbitrary i, Arbitrary e) => a i e -> [a i e] +shrinkArray a = + -- Shrink each elements but don't change the size of array. + let bounds = Array.bounds a + elmss = shrink <$> Array.elems a + in Array.listArray bounds <$> elmss + +coarbitraryArray :: (Array.IArray a e, Array.Ix i, CoArbitrary i, CoArbitrary e) + => a i e -> Gen c -> Gen c +coarbitraryArray = coarbitrary . Array.assocs + -- ByteString instance Arbitrary BS.ByteString where arbitrary = BS.pack <$> arbitrary @@ -74,6 +96,12 @@ arbitrary = BL.pack <$> arbitrary shrink xs = BL.pack <$> shrink (BL.unpack xs) +instance CoArbitrary BS.ByteString where + coarbitrary = coarbitrary . BS.unpack + +instance CoArbitrary BL.ByteString where + coarbitrary = coarbitrary . BL.unpack + -- Text instance Arbitrary TS.Text where arbitrary = TS.pack <$> arbitrary @@ -83,28 +111,48 @@ arbitrary = TL.pack <$> arbitrary shrink xs = TL.pack <$> shrink (TL.unpack xs) --- Containers +instance CoArbitrary TS.Text where + coarbitrary = coarbitrary . TS.unpack +instance CoArbitrary TL.Text where + coarbitrary = coarbitrary . TL.unpack + +-- Containers instance Arbitrary a => Arbitrary (IntMap.IntMap a) where arbitrary = IntMap.fromList <$> arbitrary shrink m = IntMap.fromList <$> shrink (IntMap.toList m) +instance CoArbitrary a => CoArbitrary (IntMap.IntMap a) where + coarbitrary = coarbitrary . IntMap.toList + instance Arbitrary IntSet.IntSet where arbitrary = IntSet.fromList <$> arbitrary shrink set = IntSet.fromList <$> shrink (IntSet.toList set) +instance CoArbitrary IntSet.IntSet where + coarbitrary = coarbitrary . IntSet.toList + instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where arbitrary = Map.fromList <$> arbitrary shrink m = Map.fromList <$> shrink (Map.toList m) +instance (CoArbitrary k, CoArbitrary v) => CoArbitrary (Map.Map k v) where + coarbitrary = coarbitrary . Map.toList + instance Arbitrary a => Arbitrary (Seq.Seq a) where arbitrary = Seq.fromList <$> arbitrary shrink xs = Seq.fromList <$> shrink (toList xs) +instance CoArbitrary a => CoArbitrary (Seq.Seq a) where + coarbitrary = coarbitrary . toList + instance (Ord a, Arbitrary a) => Arbitrary (Set.Set a) where arbitrary = Set.fromList <$> arbitrary shrink set = Set.fromList <$> shrink (Set.toList set) +instance CoArbitrary a => CoArbitrary (Set.Set a) where + coarbitrary = coarbitrary . Set.toList + instance Arbitrary a => Arbitrary (Tree.Tree a) where arbitrary = sized $ \n -> do val <- arbitrary @@ -118,96 +166,208 @@ return $ Tree.Node val nodes shrink (Tree.Node val forest) = Tree.Node <$> shrink val <*> shrink forest - --- old-time +instance CoArbitrary a => CoArbitrary (Tree.Tree a) where + coarbitrary (Tree.Node val forest) = + coarbitrary val >< coarbitrary forest + +-- old-time instance Arbitrary OldTime.Month where arbitrary = arbitraryBoundedEnum +instance CoArbitrary OldTime.Month where + coarbitrary = coarbitraryEnum + instance Arbitrary OldTime.Day where arbitrary = arbitraryBoundedEnum +instance CoArbitrary OldTime.Day where + coarbitrary = coarbitraryEnum + instance Arbitrary OldTime.ClockTime where arbitrary = OldTime.TOD <$> choose (0, fromIntegral (maxBound :: Int32)) <*> choose (0, 1000000000000 - 1) + shrink (OldTime.TOD s p) = + [ OldTime.TOD s' p | s' <- shrink s ] ++ + [ OldTime.TOD s p' | p' <- shrink p ] +instance CoArbitrary OldTime.ClockTime where + coarbitrary (OldTime.TOD s p) = + coarbitrary s >< coarbitrary p + instance Arbitrary OldTime.TimeDiff where -- a bit of a cheat ... arbitrary = OldTime.normalizeTimeDiff <$> (OldTime.diffClockTimes <$> arbitrary <*> arbitrary) + shrink td@(OldTime.TimeDiff year month day hour minute second picosec) = + [ td { OldTime.tdYear = y' } | y' <- shrink year ] ++ + [ td { OldTime.tdMonth = m' } | m' <- shrink month ] ++ + [ td { OldTime.tdDay = d' } | d' <- shrink day ] ++ + [ td { OldTime.tdHour = h' } | h' <- shrink hour ] ++ + [ td { OldTime.tdMin = m' } | m' <- shrink minute ] ++ + [ td { OldTime.tdSec = s' } | s' <- shrink second ] ++ + [ td { OldTime.tdPicosec = p' } | p' <- shrink picosec ] +instance CoArbitrary OldTime.TimeDiff where + coarbitrary (OldTime.TimeDiff year month day hour minute second picosec) = + coarbitrary year >< + coarbitrary month >< + coarbitrary day >< + coarbitrary hour >< + coarbitrary minute >< + coarbitrary second >< + coarbitrary picosec + -- UTC only instance Arbitrary OldTime.CalendarTime where arbitrary = OldTime.toUTCTime <$> arbitrary --- time +instance CoArbitrary OldTime.CalendarTime where + coarbitrary (OldTime.CalendarTime + year month day hour minute second picosec + wDay yDay tzName tz isDST) = + coarbitrary year >< + coarbitrary month >< + coarbitrary day >< + coarbitrary hour >< + coarbitrary minute >< + coarbitrary second >< + coarbitrary picosec >< + coarbitrary wDay >< + coarbitrary yDay >< + coarbitrary tzName >< + coarbitrary tz >< + coarbitrary isDST +-- time instance Arbitrary Time.Day where - arbitrary = - Time.ModifiedJulianDay - <$> choose (gregToNum 1200 1 1, gregToNum 2999 1 1) + arbitrary = Time.ModifiedJulianDay <$> (2000 +) <$> arbitrary + shrink = (Time.ModifiedJulianDay <$>) . shrink . Time.toModifiedJulianDay +instance CoArbitrary Time.Day where + coarbitrary = coarbitrary . Time.toModifiedJulianDay + instance Arbitrary Time.UniversalTime where - arbitrary = - Time.ModJulianDate - <$> toRational `fmap` choose (gregToNum 1200 1 1 :: Double, gregToNum 2999 1 1) + arbitrary = Time.ModJulianDate <$> (2000 +) <$> arbitrary + shrink = (Time.ModJulianDate <$>) . shrink . Time.getModJulianDate +instance CoArbitrary Time.UniversalTime where + coarbitrary = coarbitrary . Time.getModJulianDate + instance Arbitrary Time.DiffTime where arbitrary = arbitrarySizedFractional +#if MIN_VERSION_time(1,3,0) + shrink = shrinkRealFrac +#else + shrink = (fromRational <$>) . shrink . toRational +#endif +instance CoArbitrary Time.DiffTime where + coarbitrary = coarbitraryReal + instance Arbitrary Time.UTCTime where - arbitrary = Time.UTCTime <$> arbitrary <*> (fromRational . toRational <$> choose (0::Double, 86400)) + arbitrary = + Time.UTCTime + <$> arbitrary + <*> (fromRational . toRational <$> choose (0::Double, 86400)) + shrink ut@(Time.UTCTime day dayTime) = + [ ut { Time.utctDay = d' } | d' <- shrink day ] ++ + [ ut { Time.utctDayTime = t' } | t' <- shrink dayTime ] +instance CoArbitrary Time.UTCTime where + coarbitrary (Time.UTCTime day dayTime) = + coarbitrary day >< coarbitrary dayTime + instance Arbitrary Time.NominalDiffTime where arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac +instance CoArbitrary Time.NominalDiffTime where + coarbitrary = coarbitraryReal + instance Arbitrary Time.TimeZone where arbitrary = Time.TimeZone <$> choose (-12*60*60,12*60*60) -- utc offset (s) <*> arbitrary -- is summer time <*> (sequence . replicate 4 $ choose ('A','Z')) + shrink tz@(Time.TimeZone minutes summerOnly name) = + [ tz { Time.timeZoneMinutes = m' } | m' <- shrink minutes ] ++ + [ tz { Time.timeZoneSummerOnly = s' } | s' <- shrink summerOnly ] ++ + [ tz { Time.timeZoneName = n' } | n' <- shrink name ] +instance CoArbitrary Time.TimeZone where + coarbitrary (Time.TimeZone minutes summerOnly name) = + coarbitrary minutes >< coarbitrary summerOnly >< coarbitrary name + instance Arbitrary Time.TimeOfDay where arbitrary = Time.TimeOfDay <$> choose (0, 23) -- hour <*> choose (0, 59) -- minute <*> (fromRational . toRational <$> choose (0::Double, 60)) -- picoseconds, via double + shrink tod@(Time.TimeOfDay hour minute second) = + [ tod { Time.todHour = h' } | h' <- shrink hour ] ++ + [ tod { Time.todMin = m' } | m' <- shrink minute ] ++ + [ tod { Time.todSec = s' } | s' <- shrink second ] +instance CoArbitrary Time.TimeOfDay where + coarbitrary (Time.TimeOfDay hour minute second) = + coarbitrary hour >< coarbitrary minute >< coarbitrary second + instance Arbitrary Time.LocalTime where arbitrary = Time.LocalTime <$> arbitrary <*> arbitrary + shrink lt@(Time.LocalTime day tod) = + [ lt { Time.localDay = d' } | d' <- shrink day ] ++ + [ lt { Time.localTimeOfDay = t' } | t' <- shrink tod ] +instance CoArbitrary Time.LocalTime where + coarbitrary (Time.LocalTime day tod) = + coarbitrary day >< coarbitrary tod + instance Arbitrary Time.ZonedTime where arbitrary = Time.ZonedTime <$> arbitrary <*> arbitrary + shrink zt@(Time.ZonedTime lt zone) = + [ zt { Time.zonedTimeToLocalTime = l' } | l' <- shrink lt ] ++ + [ zt { Time.zonedTimeZone = z' } | z' <- shrink zone ] +instance CoArbitrary Time.ZonedTime where + coarbitrary (Time.ZonedTime lt zone) = + coarbitrary lt >< coarbitrary zone + instance Arbitrary Time.AbsoluteTime where arbitrary = Time.addAbsoluteTime <$> arbitrary <*> return Time.taiEpoch + shrink at = + (`Time.addAbsoluteTime` at) <$> shrink (Time.diffAbsoluteTime at Time.taiEpoch) --- | Given a year, month, and day return a number suitable for --- use as a Day or UniversalTime -gregToNum :: Num a => Integer -> Int -> Int -> a -gregToNum year month day = - fromInteger . Time.toModifiedJulianDay $ Time.fromGregorian year month day +instance CoArbitrary Time.AbsoluteTime where + coarbitrary = coarbitrary . flip Time.diffAbsoluteTime Time.taiEpoch -- WARNING: from base, should be moved to QC library instance Arbitrary Ordering where arbitrary = arbitraryBoundedEnum +instance CoArbitrary Ordering where + coarbitrary = coarbitraryEnum + instance Fixed.HasResolution a => Arbitrary (Fixed.Fixed a) where arbitrary = arbitrarySizedFractional + shrink = shrinkRealFrac +instance Fixed.HasResolution a => CoArbitrary (Fixed.Fixed a) where + coarbitrary = coarbitraryReal + -- WARNING: should be moved to QC library arbitraryBoundedEnum :: (Bounded a, Enum a) => Gen a arbitraryBoundedEnum = @@ -215,3 +375,6 @@ mx = maxBound `asTypeOf` mn n <- choose (fromEnum mn, fromEnum mx) return (toEnum n `asTypeOf` mn) + +coarbitraryEnum :: Enum a => a -> Gen c -> Gen c +coarbitraryEnum = variant . fromEnum diff --git a/src/Test/QuickCheck/Instances/LegacyNumeric.hs b/src/Test/QuickCheck/Instances/LegacyNumeric.hs new file mode 100644 --- /dev/null +++ b/src/Test/QuickCheck/Instances/LegacyNumeric.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- + +Contents of this file copyright the QuickCheck team, 2010. +QuickCheck was available under the BSD3 license at that time. + +-} + +module Test.QuickCheck.Instances.LegacyNumeric() where + +#if !(MIN_VERSION_QuickCheck(2,1,2)) + +import Data.Int +import Data.Word +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen + +-- | Generates an integral number from a bounded domain. The number is +-- chosen from the entire range of the type, but small numbers are +-- generated more often than big numbers. Inspired by demands from +-- Phil Wadler. +arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a +arbitrarySizedBoundedIntegral = + sized $ \s -> + do let mn = minBound + mx = maxBound `asTypeOf` mn + bits n | n `quot` 2 == 0 = 0 + | otherwise = 1 + bits (n `quot` 2) + k = 2^(s*(bits mn `max` bits mx `max` 40) `div` 100) + n <- choose (toInteger mn `max` (-k), toInteger mx `min` k) + return (fromInteger n `asTypeOf` mn) + +instance Arbitrary Int8 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int16 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int32 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Int64 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word8 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word16 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word32 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance Arbitrary Word64 where + arbitrary = arbitrarySizedBoundedIntegral + shrink = shrinkIntegral + +instance CoArbitrary Int8 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int16 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int32 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Int64 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word8 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word16 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word32 where + coarbitrary = coarbitraryIntegral + +instance CoArbitrary Word64 where + coarbitrary = coarbitraryIntegral + +#endif