diff --git a/genvalidity.cabal b/genvalidity.cabal --- a/genvalidity.cabal +++ b/genvalidity.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: f4100c2ff93efc9358e859fdff17d5b68f1a71aed4f88e4bcf2dd2e57ae0a795 +-- hash: ba44fb99e6f91291452e903b6e2cb6d5b566b8e667c27442668d66fa1abff13f name: genvalidity -version: 0.9.0.1 +version: 0.9.1.0 synopsis: Testing utilities for the validity library description: Note: There are companion instance packages for this library: . diff --git a/src/Data/GenValidity.hs b/src/Data/GenValidity.hs --- a/src/Data/GenValidity.hs +++ b/src/Data/GenValidity.hs @@ -101,7 +101,6 @@ import Data.Fixed (Fixed(..), HasResolution) #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.List.NonEmpty as NE #endif #if MIN_VERSION_base(4,8,0) import Data.Word (Word8, Word16, Word32, Word64) @@ -515,27 +514,15 @@ #if MIN_VERSION_base(4,9,0) instance GenUnchecked a => GenUnchecked (NonEmpty a) where - genUnchecked = do - l <- genUnchecked - case NE.nonEmpty l of - Nothing -> scale (+1) genUnchecked - Just ne -> pure ne + genUnchecked = genNonEmptyOf genUnchecked shrinkUnchecked (v :| vs) = [ e :| es | (e, es) <- shrinkUnchecked (v, vs)] instance GenValid a => GenValid (NonEmpty a) where - genValid = do - l <- genValid - case NE.nonEmpty l of - Nothing -> scale (+1) genValid - Just ne -> pure ne + genValid = genNonEmptyOf genValid shrinkValid (v :| vs) = [ e :| es | (e, es) <- shrinkValid (v, vs)] instance (GenUnchecked a, GenInvalid a) => GenInvalid (NonEmpty a) where - genInvalid = do - l <- genInvalid - case NE.nonEmpty l of - Nothing -> scale (+1) genInvalid - Just ne -> pure ne + genInvalid = genNonEmptyOf genInvalid #endif instance GenUnchecked a => GenUnchecked [a] where diff --git a/src/Data/GenValidity/Utils.hs b/src/Data/GenValidity/Utils.hs --- a/src/Data/GenValidity/Utils.hs +++ b/src/Data/GenValidity/Utils.hs @@ -21,9 +21,15 @@ , genSplit3 , genSplit4 , genSplit5 + , genSplit6 + , genSplit7 + , genSplit8 , arbPartition , shuffle , genListOf +#if MIN_VERSION_base(4,9,0) + , genNonEmptyOf +#endif -- ** Helper functions for implementing shrinking functions , shrinkTuple , shrinkT2 @@ -36,12 +42,16 @@ import Data.List (sortBy) import Data.Ord (comparing) #endif +#if MIN_VERSION_base(4,9,0) +import Data.List.NonEmpty(NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +#endif #if MIN_VERSION_base(4,8,0) -import Control.Monad (forM) +import Control.Monad (forM, replicateM) #else import Control.Applicative ((<$>), (<*>), pure) -import Control.Monad (forM) +import Control.Monad (forM, replicateM) #endif -- | 'upTo' generates an integer between 0 (inclusive) and 'n'. upTo :: Int -> Gen Int @@ -87,16 +97,72 @@ (d, e) <- genSplit z return (a, b, c, d, e) --- | 'arbPartition n' generates a list 'ls' such that 'sum ls' equals 'n'. +-- | 'genSplit6 a' generates a sextuple '(b, c, d, e, f, g)' such that 'b + c + d + e + f + g' equals 'a'. +genSplit6 :: Int -> Gen (Int, Int, Int, Int, Int, Int) +genSplit6 n + | n < 0 = pure (0, 0, 0, 0, 0, 0) + | otherwise = do + (y, z) <- genSplit n + (a, b, c) <- genSplit3 y + (d, e, f) <- genSplit3 z + return (a, b, c, d, e, f) + +-- | 'genSplit7 a' generates a septtuple '(b, c, d, e, f, g)' such that 'b + c + d + e + f + g' equals 'a'. +genSplit7 :: Int -> Gen (Int, Int, Int, Int, Int, Int, Int) +genSplit7 n + | n < 0 = pure (0, 0, 0, 0, 0, 0, 0) + | otherwise = do + (y, z) <- genSplit n + (a, b, c) <- genSplit3 y + (d, e, f, g) <- genSplit4 z + return (a, b, c, d, e, f, g) + +-- | 'genSplit8 a' generates a octtuple '(b, c, d, e, f, g, h)' such that 'b + c + d + e + f + g + h' equals 'a'. +genSplit8 :: Int -> Gen (Int, Int, Int, Int, Int, Int, Int, Int) +genSplit8 n + | n < 0 = pure (0, 0, 0, 0, 0, 0, 0, 0) + | otherwise = do + (y, z) <- genSplit n + (a, b, c, d) <- genSplit4 y + (e, f, g, h) <- genSplit4 z + return (a, b, c, d, e, f, g, h) + + +-- | 'arbPartition n' generates a list 'ls' such that 'sum ls' equals 'n', approximately. arbPartition :: Int -> Gen [Int] -arbPartition i = go i >>= shuffle +arbPartition 0 = pure [] +arbPartition i = genLen i >>= go i where - go k - | k <= 0 = pure [] - | otherwise = do - first <- choose (1, k) - rest <- arbPartition $ k - first - return $ first : rest + genLen :: Int -> Gen Int + genLen maxLen = round . invT (fromIntegral maxLen) <$> choose (0, 1) + + -- Use a triangle distribution for generating the + -- length of the list + -- with minimum length '0', mode length '2' + -- and given max length. + invT :: Double -> Double -> Double + invT maxLen u = + let a = 0 + b = maxLen + c = 2 + fc = (c - a) / (b - a) + in if u < fc + then a + sqrt (u * (b - a) * (c - a) ) + else b - sqrt ((1 - u) * (b - a) * (b - c)) + + + go :: Int -> Int -> Gen [Int] + go size len = do + us <- replicateM len $ choose (0, 1) + let invs = map (invE 0.25) us + -- Rescale the sizes to (approximately) sum to the given size. + pure $ map (round . (* (fromIntegral size / sum invs))) invs + + -- Use an exponential distribution for generating the + -- sizes in the partition. + invE :: Double -> Double -> Double + invE lambda u = - log (1 - u) / lambda + #if !MIN_VERSION_QuickCheck(2,8,0) -- | Generates a random permutation of the given list. shuffle :: [a] -> Gen [a] @@ -104,6 +170,16 @@ ns <- vectorOf (length xs) (choose (minBound :: Int, maxBound)) return (map snd (sortBy (comparing fst) (zip ns xs))) #endif + +#if MIN_VERSION_base(4,9,0) +genNonEmptyOf :: Gen a -> Gen (NonEmpty a) +genNonEmptyOf gen = do + l <- genListOf gen + case NE.nonEmpty l of + Nothing -> scale (+1) $ genNonEmptyOf gen + Just ne -> pure ne +#endif + -- | A version of @listOf@ that takes size into account more accurately. -- -- This generator distributes the size that is is given among the values @@ -111,8 +187,7 @@ genListOf :: Gen a -> Gen [a] genListOf func = sized $ \n -> do - size <- upTo n - pars <- arbPartition size + pars <- arbPartition n forM pars $ \i -> resize i func shrinkTuple :: (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)] diff --git a/test/Data/GenValiditySpec.hs b/test/Data/GenValiditySpec.hs --- a/test/Data/GenValiditySpec.hs +++ b/test/Data/GenValiditySpec.hs @@ -1,6 +1,6 @@ module Data.GenValiditySpec - ( spec - ) where + ( spec + ) where import Test.Hspec import Test.QuickCheck @@ -9,59 +9,65 @@ spec :: Spec spec = do - describe "genUtf16SurrogateCodePoint" $ - it "generates Utf16 surrogate codepoints" $ - forAll genUtf16SurrogateCodePoint $ (`shouldSatisfy` isUtf16SurrogateCodePoint) - describe "upTo" $ do - it "returns only positive integers" $ - forAll arbitrary $ \n -> forAll (upTo n) (`shouldSatisfy` (>= 0)) - it "returns only integers smaller than or equal to the given number" $ - forAll arbitrary $ \n -> forAll (upTo n) (`shouldSatisfy` (<= (max n 0))) - describe "genSplit" $ do - it "returns positive integers" $ - forAll arbitrary $ \i -> - forAll (genSplit i) $ \(a, b) -> do - a `shouldSatisfy` (>= 0) - b `shouldSatisfy` (>= 0) - it "returns two integers such that the sum is the original integer" $ - forAll arbitrary $ \i -> forAll (genSplit i) $ \(a, b) -> a + b `shouldBe` max 0 i - describe "genSplit3" $ do - it "returns positive integers" $ - forAll arbitrary $ \i -> - forAll (genSplit3 i) $ \(a, b, c) -> do - a `shouldSatisfy` (>= 0) - b `shouldSatisfy` (>= 0) - c `shouldSatisfy` (>= 0) - it "returns three integers such that the sum is the original integer" $ - forAll arbitrary $ \i -> forAll (genSplit3 i) $ \(a, b, c) -> a + b + c `shouldBe` max 0 i - describe "genSplit4" $ do - it "returns positive integers" $ - forAll arbitrary $ \i -> - forAll (genSplit4 i) $ \(a, b, c, d) -> do - a `shouldSatisfy` (>= 0) - b `shouldSatisfy` (>= 0) - c `shouldSatisfy` (>= 0) - d `shouldSatisfy` (>= 0) - it "returns four integers such that the sum is the original integer" $ - forAll arbitrary $ \i -> - forAll (genSplit4 i) $ \(a, b, c, d) -> a + b + c + d `shouldBe` max 0 i - describe "genSplit5" $ do - it "returns positive integers" $ - forAll arbitrary $ \i -> - forAll (genSplit5 i) $ \(a, b, c, d, e) -> do - a `shouldSatisfy` (>= 0) - b `shouldSatisfy` (>= 0) - c `shouldSatisfy` (>= 0) - d `shouldSatisfy` (>= 0) - e `shouldSatisfy` (>= 0) - it "returns four integers such that the sum is the original integer" $ - forAll arbitrary $ \i -> - forAll (genSplit5 i) $ \(a, b, c, d, e) -> a + b + c + d + e `shouldBe` max 0 i - describe "arbPartition" $ do - it "returns an empty list upon strictly negative input" $ - forAll (arbitrary `suchThat` (< 0)) $ \n -> forAll (arbPartition n) (`shouldBe` []) - it "returns a list of strictly positive integers" $ - forAll arbitrary $ \n -> forAll (arbPartition n) $ \p -> p `shouldSatisfy` all (> 0) - it "returns a list of integers that sum to the original positive integer" $ - forAll (arbitrary `suchThat` (>= 0)) $ \n -> - forAll (arbPartition n) $ \p -> sum p `shouldBe` n + describe "genUtf16SurrogateCodePoint" $ + it "generates Utf16 surrogate codepoints" $ + forAll genUtf16SurrogateCodePoint $ (`shouldSatisfy` isUtf16SurrogateCodePoint) + + describe "upTo" $ do + it "returns only positive integers" $ + forAll arbitrary $ \n -> forAll (upTo n) (`shouldSatisfy` (>= 0)) + it "returns only integers smaller than or equal to the given number" $ + forAll arbitrary $ \n -> + forAll (upTo n) (`shouldSatisfy` (<= (max n 0))) + describe "genSplit" $ do + it "returns positive integers" $ + forAll arbitrary $ \i -> + forAll (genSplit i) $ \(a, b) -> do + a `shouldSatisfy` (>= 0) + b `shouldSatisfy` (>= 0) + it "returns two integers such that the sum is the original integer" $ + forAll arbitrary $ \i -> + forAll (genSplit i) $ \(a, b) -> a + b `shouldBe` max 0 i + describe "genSplit3" $ do + it "returns positive integers" $ + forAll arbitrary $ \i -> + forAll (genSplit3 i) $ \(a, b, c) -> do + a `shouldSatisfy` (>= 0) + b `shouldSatisfy` (>= 0) + c `shouldSatisfy` (>= 0) + it "returns three integers such that the sum is the original integer" $ + forAll arbitrary $ \i -> + forAll (genSplit3 i) $ \(a, b, c) -> + a + b + c `shouldBe` max 0 i + describe "genSplit4" $ do + it "returns positive integers" $ + forAll arbitrary $ \i -> + forAll (genSplit4 i) $ \(a, b, c, d) -> do + a `shouldSatisfy` (>= 0) + b `shouldSatisfy` (>= 0) + c `shouldSatisfy` (>= 0) + d `shouldSatisfy` (>= 0) + it "returns four integers such that the sum is the original integer" $ + forAll arbitrary $ \i -> + forAll (genSplit4 i) $ \(a, b, c, d) -> + a + b + c + d `shouldBe` max 0 i + describe "genSplit5" $ do + it "returns positive integers" $ + forAll arbitrary $ \i -> + forAll (genSplit5 i) $ \(a, b, c, d, e) -> do + a `shouldSatisfy` (>= 0) + b `shouldSatisfy` (>= 0) + c `shouldSatisfy` (>= 0) + d `shouldSatisfy` (>= 0) + e `shouldSatisfy` (>= 0) + it "returns four integers such that the sum is the original integer" $ + forAll arbitrary $ \i -> + forAll (genSplit5 i) $ \(a, b, c, d, e) -> + a + b + c + d + e `shouldBe` max 0 i + describe "arbPartition" $ do + it "returns an empty list upon strictly negative input" $ + forAll (arbitrary `suchThat` (< 0)) $ \n -> + forAll (arbPartition n) (`shouldBe` []) + it "returns a list of positive integers" $ + forAll arbitrary $ \n -> + forAll (arbPartition n) $ \p -> p `shouldSatisfy` all (>= 0)