genvalidity 1.0.0.1 → 1.1.0.0

raw patch · 5 files changed

+127/−57 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−0
• genvalidity.cabal +2/−2
• src/Data/GenValidity.hs +7/−15
• src/Data/GenValidity/Utils.hs +100/−40
• test/Data/InstanceSpec.hs +1/−0

@@ -1,5 +1,22 @@ # Changelog +## [1.1.0.0] - 2022-08-30++### Added++* `genListOf1`+* `genMaybe`+* `shrinkMaybe`+* `shrinkNonEmpty`+* `shrinkTriple`+* `shrinkQuadruple`++### Changed++* Sped up shrinking of `NonEmpty` lists by an order of magnitude.+* Changed shrinking of `Ratio`s to be 10x faster.+* Reimplemented `shrinkT2`, `shrinkT3` and `shrinkT4` in terms of `shrinkTuple`, `shrinkTriple` and `shrinkQuadruple`.+ ## [1.0.0.1] - 2021-11-20  ### Changed

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.5.+-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack  name:           genvalidity-version:        1.0.0.1+version:        1.1.0.0 synopsis:       Testing utilities for the validity library description:    Note: There are companion instance packages for this library:                 .

@@ -86,7 +86,7 @@ import Data.Fixed (Fixed (..), HasResolution) import Data.GenValidity.Utils import Data.Int (Int16, Int32, Int64, Int8)-import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.List.NonEmpty (NonEmpty) import Data.Ratio ((%)) import Data.Validity import Data.Word (Word16, Word32, Word64, Word8)@@ -174,10 +174,7 @@       b <- resize s genValid       c <- resize t genValid       return (a, b, c)-  shrinkValid (a, b, c) =-    [ (a', b', c')-      | (a', (b', c')) <- shrinkValid (a, (b, c))-    ]+  shrinkValid = shrinkTriple shrinkValid shrinkValid shrinkValid  instance   (GenValid a, GenValid b, GenValid c, GenValid d) =>@@ -191,10 +188,7 @@       c <- resize t genValid       d <- resize u genValid       return (a, b, c, d)-  shrinkValid (a, b, c, d) =-    [ (a', b', c', d')-      | (a', (b', (c', d'))) <- shrinkValid (a, (b, (c, d)))-    ]+  shrinkValid = shrinkQuadruple shrinkValid shrinkValid shrinkValid shrinkValid  instance   (GenValid a, GenValid b, GenValid c, GenValid d, GenValid e) =>@@ -215,13 +209,12 @@     ]  instance GenValid a => GenValid (Maybe a) where-  genValid = oneof [pure Nothing, Just <$> genValid]-  shrinkValid Nothing = []-  shrinkValid (Just a) = Nothing : (Just <$> shrinkValid a)+  genValid = genMaybe genValid+  shrinkValid = shrinkMaybe shrinkValid  instance GenValid a => GenValid (NonEmpty a) where   genValid = genNonEmptyOf genValid-  shrinkValid (v :| vs) = [e :| es | (e, es) <- shrinkValid (v, vs)]+  shrinkValid = shrinkNonEmpty shrinkValid  instance GenValid a => GenValid [a] where   genValid = genListOf genValid@@ -330,8 +323,7 @@     )       `suchThat` isValid   shrinkValid (n :% d) = do-    (n', d') <- shrinkValid (n, d)-    guard $ d' > 0+    (n', d') <- shrinkTuple shrinkValid (filter (> 0) . shrinkValid) (n, d)     let candidate = n' :% d'     guard $ isValid candidate     pure $ n' % d'

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} @@ -16,26 +17,36 @@     arbPartition,     shuffle,     genListLength,+    genStringBy,+    genStringBy1,     genListOf,+    genListOf1,+    genMaybe,     genNonEmptyOf,--    -- ** Helper functions for implementing shrinking functions-    shrinkTuple,-    shrinkT2,-    shrinkT3,-    shrinkT4,     genIntX,     genWordX,     genFloat,     genDouble,     genFloatX,     genInteger,++    -- ** Helper functions for implementing shrinking functions+    shrinkMaybe,+    shrinkTuple,+    shrinkTriple,+    shrinkQuadruple,+    shrinkT2,+    shrinkT3,+    shrinkT4,+    shrinkList,+    shrinkNonEmpty,   ) where  import Control.Monad (forM, replicateM) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE+import Data.Maybe import Data.Ratio import GHC.Float (castWord32ToFloat, castWord64ToDouble) import System.Random@@ -52,68 +63,68 @@ genSplit n   | n < 0 = pure (0, 0)   | otherwise = do-    i <- choose (0, n)-    let j = n - i-    pure (i, j)+      i <- choose (0, n)+      let j = n - i+      pure (i, j)  -- | 'genSplit3 a' generates a triple '(b, c, d)' such that 'b + c + d' equals 'a'. genSplit3 :: Int -> Gen (Int, Int, Int) genSplit3 n   | n < 0 = pure (0, 0, 0)   | otherwise = do-    (a, z) <- genSplit n-    (b, c) <- genSplit z-    return (a, b, c)+      (a, z) <- genSplit n+      (b, c) <- genSplit z+      return (a, b, c)  -- | 'genSplit4 a' generates a quadruple '(b, c, d, e)' such that 'b + c + d + e' equals 'a'. genSplit4 :: Int -> Gen (Int, Int, Int, Int) genSplit4 n   | n < 0 = pure (0, 0, 0, 0)   | otherwise = do-    (y, z) <- genSplit n-    (a, b) <- genSplit y-    (c, d) <- genSplit z-    return (a, b, c, d)+      (y, z) <- genSplit n+      (a, b) <- genSplit y+      (c, d) <- genSplit z+      return (a, b, c, d)  -- | 'genSplit5 a' generates a quintuple '(b, c, d, e, f)' such that 'b + c + d + e + f' equals 'a'. genSplit5 :: Int -> Gen (Int, Int, Int, Int, Int) genSplit5 n   | n < 0 = pure (0, 0, 0, 0, 0)   | otherwise = do-    (y, z) <- genSplit n-    (a, b, c) <- genSplit3 y-    (d, e) <- genSplit z-    return (a, b, c, d, e)+      (y, z) <- genSplit n+      (a, b, c) <- genSplit3 y+      (d, e) <- genSplit z+      return (a, b, c, d, e)  -- | '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)+      (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)+      (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)+      (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]@@ -130,8 +141,11 @@     -- Use an exponential distribution for generating the     -- sizes in the partition.     invE :: Double -> Double -> Double-    invE lambda u = (- log (1 - u)) / lambda+    invE lambda u = (-log (1 - u)) / lambda +genMaybe :: Gen a -> Gen (Maybe a)+genMaybe gen = oneof [pure Nothing, Just <$> gen]+ genNonEmptyOf :: Gen a -> Gen (NonEmpty a) genNonEmptyOf gen = do   l <- genListOf gen@@ -161,6 +175,14 @@             then a + sqrt (u * (b - a) * (c - a))             else b - sqrt ((1 - u) * (b - a) * (b - c)) +-- Generate a String using a generator of 'Char's+genStringBy :: Gen Char -> Gen String+genStringBy = genListOf++-- Generate a String using a generator of 'Char's+genStringBy1 :: Gen Char -> Gen String+genStringBy1 = genListOf1+ -- | A version of @listOf@ that takes size into account more accurately. -- -- This generator distributes the size that is is given among the values@@ -171,24 +193,62 @@     pars <- arbPartition n     forM pars $ \i -> resize i func +-- | A version of 'genNonEmptyOf' that returns a list instead of a 'NonEmpty'.+genListOf1 :: Gen a -> Gen [a]+genListOf1 gen = NE.toList <$> genNonEmptyOf gen++-- | Lift a shrinker function into a maybe+shrinkMaybe :: (a -> [a]) -> Maybe a -> [Maybe a]+shrinkMaybe shrinker = \case+  Nothing -> []+  Just a -> Nothing : (Just <$> shrinker a)++-- | Combine two shrinking functions to shrink a tuple. shrinkTuple :: (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)] shrinkTuple sa sb (a, b) =   ((,) <$> sa a <*> sb b)     ++ [(a', b) | a' <- sa a]     ++ [(a, b') | b' <- sb b] +-- | Like 'shrinkTuple', but for triples+shrinkTriple ::+  (a -> [a]) ->+  (b -> [b]) ->+  (c -> [c]) ->+  (a, b, c) ->+  [(a, b, c)]+shrinkTriple sa sb sc (a, b, c) = do+  (a', (b', c')) <- shrinkTuple sa (shrinkTuple sb sc) (a, (b, c))+  pure (a', b', c')++-- | Like 'shrinkTuple', but for quadruples+shrinkQuadruple ::+  (a -> [a]) ->+  (b -> [b]) ->+  (c -> [c]) ->+  (d -> [d]) ->+  (a, b, c, d) ->+  [(a, b, c, d)]+shrinkQuadruple sa sb sc sd (a, b, c, d) = do+  ((a', b'), (c', d')) <- shrinkTuple (shrinkTuple sa sb) (shrinkTuple sc sd) ((a, b), (c, d))+  pure (a', b', c', d')+ -- | Turn a shrinking function into a function that shrinks tuples. shrinkT2 :: (a -> [a]) -> (a, a) -> [(a, a)]-shrinkT2 s (a, b) = (,) <$> s a <*> s b+shrinkT2 s = shrinkTuple s s  -- | Turn a shrinking function into a function that shrinks triples. shrinkT3 :: (a -> [a]) -> (a, a, a) -> [(a, a, a)]-shrinkT3 s (a, b, c) = (,,) <$> s a <*> s b <*> s c+shrinkT3 s = shrinkTriple s s s  -- | Turn a shrinking function into a function that shrinks quadruples. shrinkT4 :: (a -> [a]) -> (a, a, a, a) -> [(a, a, a, a)]-shrinkT4 s (a, b, c, d) = (,,,) <$> s a <*> s b <*> s c <*> s d+shrinkT4 s = shrinkQuadruple s s s s +-- Shrink a nonempty list given a shrinker for values.+shrinkNonEmpty :: (a -> [a]) -> NonEmpty a -> [NonEmpty a]+shrinkNonEmpty shrinker = mapMaybe NE.nonEmpty . shrinkList shrinker . NE.toList+ -- | Generate Int, Int8, Int16, Int32 and Int64 values smartly. -- -- * Some at the border@@ -209,7 +269,7 @@           choose (minBound, minBound + fromIntegral s)         ]     small :: Gen a-    small = sized $ \s -> choose (- fromIntegral s, fromIntegral s)+    small = sized $ \s -> choose (-fromIntegral s, fromIntegral s)     uniformInt :: Gen a     uniformInt = choose (minBound, maxBound) @@ -282,12 +342,12 @@       let n' = toInteger n       let precision = 9999999999999 :: Integer       b <- choose (1, precision)-      a <- choose ((- n') * b, n' * b)+      a <- choose ((-n') * b, n' * b)       pure (fromRational (a % b))     upperSignificand :: Integer     upperSignificand = floatRadix (0.0 :: a) ^ floatDigits (0.0 :: a)     lowerSignificand :: Integer-    lowerSignificand = (- upperSignificand)+    lowerSignificand = (-upperSignificand)     (lowerExponent, upperExponent) = floatRange (0.0 :: a)     aroundBounds :: Gen a     aroundBounds = do@@ -319,7 +379,7 @@         small       ]   where-    small = sized $ \s -> choose (- toInteger s, toInteger s)+    small = sized $ \s -> choose (-toInteger s, toInteger s)     genIntSizedInteger = toInteger <$> (genIntX :: Gen Int)     genBiggerInteger = sized $ \s -> do       (a, b, c) <- genSplit3 s

@@ -1,3 +1,4 @@+{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE ScopedTypeVariables #-}  module Data.InstanceSpec