hedgehog-classes 0.2.3 → 0.2.4
raw patch · 9 files changed
+336/−7 lines, 9 filesdep +primitivedep ~semiringsPVP ok
version bump matches the API change (PVP)
Dependencies added: primitive
Dependency ranges changed: semirings
API changes (from Hackage documentation)
+ Hedgehog.Classes: primLaws :: (Prim a, Eq a, Show a) => Gen a -> Laws
Files
- CHANGELOG.md +7/−0
- README.md +3/−1
- hedgehog-classes.cabal +20/−5
- src/Hedgehog/Classes.hs +6/−0
- src/Hedgehog/Classes/Common.hs +1/−1
- src/Hedgehog/Classes/Comonad.hs +15/−0
- src/Hedgehog/Classes/Prim.hs +259/−0
- test/Spec.hs +2/−0
- test/Spec/Prim.hs +23/−0
CHANGELOG.md view
@@ -3,6 +3,13 @@ `hedgehog-classes` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +0.2.4+=====+* Semirings upper bound increased to 0.6. [0.2, 0.5) -> [0.2, 0.6)+* Add `primLaws`.+* Remove GHC 8.8.1 from cabal's tested-with field.+* Add documentation to `comonadLaws`.+ 0.2.3 ===== * Semirings upper bound increased to 0.5. Lower bound not touched.
README.md view
@@ -86,7 +86,7 @@ is test properties of higher-kinded typeclass laws where the construction of the type requires constraints on its type arguments (e.g. `Ord` for something like `Data.Set.Set`)- + - [hedgehog-laws](https://github.com/qfpl/hedgehog-laws): - All of the things that apply to `hedgehog-checkers`, but even more incomplete. @@ -124,6 +124,8 @@ - `semirings` - Semiring - Ring+ - `primitive`+ - Prim Some typeclasses can have additional laws, which are not part of their sufficient definition. A common example is commutativity of a monoid. In such cases where this is sensible, `hedgehog-classes` provides functions such `commutativeMonoidLaws`, `commutativeSemigroupLaws`, etc. `hedgehog-classes` also tests that `foldl'`/`foldr'` actually accumulate strictly. There are other such cases that are documented on Hackage.
hedgehog-classes.cabal view
@@ -2,7 +2,7 @@ name: hedgehog-classes version:- 0.2.3+ 0.2.4 synopsis: Hedgehog will eat your typeclass bugs description:@@ -36,11 +36,13 @@ extra-doc-files: README.md , CHANGELOG.md-tested-with: GHC == 8.6.5, GHC == 8.8.1+tested-with: GHC == 8.6.5 source-repository head- type: git- location: https://github.com/chessai/hedgehog-classes.git+ type:+ git+ location:+ https://github.com/chessai/hedgehog-classes.git flag aeson description:@@ -74,6 +76,14 @@ default: True manual: True +flag primitive+ description:+ You can disable the use of the `primitive` package using `-f-primitive`.+ .+ This may be useful for accelerating builds in sandboxes for expert users.+ default: True+ manual: True+ library hs-source-dirs: src@@ -117,6 +127,7 @@ Hedgehog.Classes.MonadZip Hedgehog.Classes.Monoid Hedgehog.Classes.Ord+ Hedgehog.Classes.Prim Hedgehog.Classes.Semigroup Hedgehog.Classes.Semiring Hedgehog.Classes.Show@@ -143,7 +154,7 @@ -- build-depends: semigroupoids >= 0.5.3.0 && < 0.6.0.0 -- cpp-options: -DHAVE_SEMIGROUPOIDS if flag(semirings)- build-depends: semirings >= 0.2 && < 0.5+ build-depends: semirings >= 0.2 && < 0.6 cpp-options: -DHAVE_SEMIRINGS if flag(comonad) build-depends: comonad >= 5.0 && < 5.1@@ -151,6 +162,9 @@ -- if flag(vector) -- build-depends: vector >= 0.12.0.0 && < 0.13.0.0 -- cpp-options: -DHAVE_VECTOR+ if flag(primitive)+ build-depends: primitive >= 0.6.4 && < 0.8+ cpp-options: -DHAVE_PRIMITIVE test-suite spec type:@@ -182,6 +196,7 @@ Spec.Monad Spec.Monoid Spec.Ord+ Spec.Prim Spec.Semigroup Spec.Semiring Spec.Show
src/Hedgehog/Classes.hs view
@@ -34,6 +34,9 @@ , jsonLaws #endif , genericLaws+#if HAVE_PRIMITIVE+ , primLaws+#endif #if HAVE_SEMIRINGS , semiringLaws , ringLaws@@ -112,6 +115,9 @@ import Hedgehog.Classes.MonadZip (monadZipLaws) import Hedgehog.Classes.Monoid (monoidLaws, commutativeMonoidLaws) import Hedgehog.Classes.Ord (ordLaws)+#if HAVE_PRIMITIVE+import Hedgehog.Classes.Prim (primLaws)+#endif import Hedgehog.Classes.Semigroup (semigroupLaws, commutativeSemigroupLaws, exponentialSemigroupLaws, idempotentSemigroupLaws, rectangularBandSemigroupLaws) #if HAVE_SEMIRINGS import Hedgehog.Classes.Semiring (semiringLaws, ringLaws, starLaws)
src/Hedgehog/Classes/Common.hs view
@@ -1,5 +1,5 @@ module Hedgehog.Classes.Common- ( module Common + ( module Common ) where import Hedgehog.Classes.Common.ApTrans as Common
src/Hedgehog/Classes/Comonad.hs view
@@ -16,6 +16,21 @@ import Hedgehog import Hedgehog.Classes.Common +-- | Tests the following 'Comonad' laws:+--+-- [__Extend/Extract Identity__]: @'extend' 'extract' ≡ 'id'@+-- [__Extract/Extend__]: @'extract' '.' 'extend' f ≡ f@+-- [__Extend/Extend__]: @'extend' f '.' 'extend' g ≡ 'extend' (f '.' 'extend' g)@+-- [__Extract Right Identity__]: @f '=>=' 'extract' ≡ f@+-- [__Extract Left Identity__]: @'extract' '=>=' f ≡ f@+-- [__Cokleisli Associativity__]: @(f '=>=' g) '=>=' h ≡ f '=>=' (g '=>=' h)@+-- [__Extract/Duplicate Identity__]: @'extract' '.' 'duplicate' ≡ 'id'@+-- [__Fmap Extract/Duplicate Identity__]: @'fmap' 'extract' '.' 'duplicate' ≡ 'id'@+-- [__Double Duplication__]: @'duplicate' '.' 'duplicate' ≡ 'fmap' 'duplicate' '.' 'duplicate'@+-- [__Extend/Fmap . Duplicate Identity__]: @'extend' f ≡ 'fmap' f '.' 'duplicate'@+-- [__Duplicate/Extend id Identity__]: @'duplicate' ≡ 'extend' 'id'@+-- [__Fmap/Extend Extract__]: @'fmap' f ≡ 'extend' (f '.' 'extract')@+-- [__Fmap/LiftW Isomorphism__]: @'fmap' ≡ 'liftW'@ comonadLaws :: ( Comonad f , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)
+ src/Hedgehog/Classes/Prim.hs view
@@ -0,0 +1,259 @@+{-# language LambdaCase #-}+{-# language UnboxedTuples #-}+{-# language TypeApplications #-}+{-# language MagicHash #-}+{-# language BangPatterns #-}+{-# language ScopedTypeVariables #-}++module Hedgehog.Classes.Prim (primLaws) where++import Control.Monad (when)+import Foreign.Marshal.Alloc+import GHC.Exts hiding (setByteArray#)++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Primitive+import Data.Primitive+import Data.Primitive.Ptr++import Hedgehog+import Hedgehog.Classes.Common+import Hedgehog.Internal.Gen (sample)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++-- | Tests the following 'Prim' laws:+--+-- [__ByteArray Set-Get__]: @'primitive_' ('writeByteArray#' ba# ix# x) '*>' 'primitive' ('readByteArray#' ba# ix#)@ ≡ @'pure' x@+-- [__ByteArray Get-Set__]: @'primitive' ('readByteArray#' ba# ix#) '>>=' \x -> 'primitive_' ('writeByteArray#' ba# ix# x)@ ≡ @'pure' ()@+-- [__ByteArray Set-Set__]: @'primitive_' ('writeByteArray#' ba# ix# x) *> 'primitive_' ('writeByteArray#' ba# ix# x)@ ≡ @'primitive_' ('writeByteArray#' ba# ix# x)@+-- [__ByteArray Set Range__]: The behavior of 'setByteArray#' matches the default implementation+-- [__ByteArray List Conversion Roundtrips__]: Turning a list into a 'PrimArray' and back gives you the same list+-- [__Addr Set-Get__]: @'primitive_' ('writeOffAddr#' addr# ix# x) '*>' 'primitive' ('readOffAddr#' addr# ix#)@ ≡ @'pure' x@+-- [__Addr Get-Set__]: @'primitive' ('readOffAddr#' addr# ix#) '>>=' \x -> 'primitive_' ('writeOffAddr#' addr# ix# x)@ ≡ @'pure' ()@+-- [__Addr Set-Set__]: @'primitive_' ('writeOffAddr#' addr# ix# x) '*>' 'primitive_' ('writeOffAddr#' addr# ix# x)@ ≡ @'primitive_' ('writeOffAddr#' addr# ix# x)@+-- [__Addr Set Range__]: The behavior of 'setOffAddr#' matches the default implementation+-- [__Addr List Conversion Roundtrips__]: Mallocing a list and then reconstructing it gives you the same list+primLaws :: (Prim a, Eq a, Show a) => Gen a -> Laws+primLaws gen = Laws "Prim"+ [ ("ByteArray Set-Get (you get back what you put in)", primSetGetByteArray gen)+ , ("ByteArray Get-Set (putting back what you got out has no effect)", primGetSetByteArray gen)+ , ("ByteArray Set-Set (putting twice is the same as putting once)", primSetSetByteArray gen)+ , ("ByteArray Set Range", primSetByteArray gen)+ , ("ByteArray List Conversion Roundtrips", primListRoundtripByteArray gen)+ , ("Addr Set-Get (you get back what you put in)", primSetGetAddr gen)+ , ("Addr Get-Set (putting back what you got out has no effect)", primGetSetAddr gen)+ , ("Addr Set-Set (putting twice is the same as putting once)", primSetSetAddr gen)+ , ("Addr Set Range", primSetRangeAddr gen)+ , ("Addr List Conversion Roundtrips", primListRoundtripAddr gen)+ ]++genSmallArrayLen :: Gen Int+genSmallArrayLen = Gen.integral (Range.linear 1 10)++genMutPrimArray :: Prim a => Gen a -> Int -> IO (MutablePrimArray (PrimState IO) a)+genMutPrimArray gen len = do+ marr <- newPrimArray len+ let go :: Int -> IO ()+ go !ix = when (ix < len) $ do+ writePrimArray marr ix =<< sample gen+ go (ix + 1)+ go 0+ pure marr++genPrimArray :: forall a. Prim a => Gen a -> Int -> IO (PrimArray a)+genPrimArray gen len = unsafeFreezePrimArray =<< genMutPrimArray gen len++-- | Setting an element and getting it back should give back the same element+primSetGetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property+primSetGetByteArray gen = property $ do+ len <- forAll genSmallArrayLen+ ix <- forAll $ Gen.int (Range.linear 0 (len - 1))+ el <- forAll gen+ el' <- liftIO $ do+ marr <- genMutPrimArray gen len+ writePrimArray marr ix el+ readPrimArray marr ix+ el === el'++-- | Getting an element and putting it back should not change the array+primGetSetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property+primGetSetByteArray gen = property $ do+ len <- forAll genSmallArrayLen+ ix <- forAll $ Gen.int (Range.linear 0 (len - 1))+ (arr1, arr2) <- liftIO $ do+ arr1 <- genPrimArray gen len+ marr2 <- newPrimArray len+ copyPrimArray marr2 0 arr1 0 len+ writePrimArray marr2 ix =<< readPrimArray marr2 ix+ arr2 <- unsafeFreezePrimArray marr2+ pure (arr1, arr2)+ arr1 === arr2++-- | Setting and element once and twice should result in the same array (setting+-- should be idempotent)+primSetSetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property+primSetSetByteArray gen = property $ do+ len <- forAll genSmallArrayLen+ ix <- forAll $ Gen.int (Range.linear 0 (len - 1))+ el <- forAll gen+ (arr1, arr2) <- liftIO $ do+ marr1 <- genMutPrimArray gen len+ writePrimArray marr1 ix el+ marr2 <- newPrimArray len+ copyMutablePrimArray marr2 0 marr1 0 len+ arr1 <- unsafeFreezePrimArray marr1+ writePrimArray marr2 ix el+ arr2 <- unsafeFreezePrimArray marr2+ pure (arr1, arr2)+ arr1 === arr2++-- | Setting a range should match the default implementation+primSetByteArray :: (Eq a, Show a, Prim a) => Gen a -> Property+primSetByteArray gen = property $ do+ len <- forAll genSmallArrayLen+ (low, high) <- fmap order $ (,)+ <$> forAll (Gen.int (Range.linear 0 (len - 1)))+ <*> forAll (Gen.int (Range.linear 0 (len - 1)))+ el <- forAll gen+ (arr2, arr3) <- liftIO $ do+ arr1 <- genPrimArray gen len+ marr2 <- newPrimArray len+ copyPrimArray marr2 0 arr1 0 len+ marr3 <- newPrimArray len+ copyPrimArray marr3 0 arr1 0 len+ setPrimArray marr2 low (high - low) el+ arr2 <- unsafeFreezePrimArray marr2+ defaultSetPrimArray marr3 low (high - low) el+ arr3 <- unsafeFreezePrimArray marr3+ pure (arr2, arr3)+ arr2 === arr3+ where+ order (x, y) = if x < y then (x, y) else (y, x)++defaultSetPrimArray :: (Prim a, PrimMonad m)+ => MutablePrimArray (PrimState m) a -> Int -> Int -> a -> m ()+defaultSetPrimArray (MutablePrimArray marr#) (I# off#) (I# len#) x = primitive_ (go off#)+ where+ end# = off# +# len#+ go !ix# s# = if isTrue# (ix# >=# end#)+ then s#+ else case writeByteArray# marr# ix# x s# of+ s2# -> go (ix# +# 1#) s2#++-- | @'toList' . 'fromList'@ should result in the same list+primListRoundtripByteArray :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property+primListRoundtripByteArray gen = property $ do+ xs <- forAll $ genSmallNonEmptyList gen+ xs === toList (fromList xs :: PrimArray a)++withBytes :: forall a b. Prim a => Int -> (Ptr a -> IO b) -> IO b+withBytes len h = do+ p <- mallocBytes (len * sizeOf (undefined :: a))+ h p <* free p++ptrToPrimArray :: forall a. Prim a => Ptr a -> Int -> IO (PrimArray a)+ptrToPrimArray p len = do+ marr <- newPrimArray len+ copyPtrToMutablePrimArray marr 0 p len+ unsafeFreezePrimArray marr++-- | Setting an element and getting it back should give back the same element+primSetGetAddr :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property+primSetGetAddr gen = property $ do+ len <- forAll genSmallArrayLen+ ix <- forAll $ Gen.int (Range.linear 0 (len - 1))+ el <- forAll gen+ el' <- liftIO $ withBytes len $ \p -> do+ writeOffPtr p ix el+ readOffPtr p ix+ el === el'++-- | Getting an element and putting it back should not change the array+primGetSetAddr :: (Eq a, Show a, Prim a) => Gen a -> Property+primGetSetAddr gen = property $ do+ len <- forAll genSmallArrayLen+ ix <- forAll $ Gen.int (Range.linear 0 (len - 1))+ (arr1, arr2) <- liftIO $ do+ arr1 <- genPrimArray gen len+ arr2 <- withBytes len $ \p -> do+ copyPrimArrayToPtr p arr1 0 len+ writeOffPtr p ix =<< readOffPtr p ix+ ptrToPrimArray p len+ pure (arr1, arr2)+ arr1 === arr2++-- | Setting and element once and twice should result in the same array (setting+-- should be idempotent)+primSetSetAddr :: (Eq a, Show a, Prim a) => Gen a -> Property+primSetSetAddr gen = property $ do+ len <- forAll genSmallArrayLen+ ix <- forAll $ Gen.int (Range.linear 0 (len - 1))+ el <- forAll gen+ (arr2, arr3) <- liftIO $ do+ arr1 <- genPrimArray gen len+ withBytes len $ \p1 -> do+ copyPrimArrayToPtr p1 arr1 0 len+ writeOffPtr p1 ix el+ arr2 <- ptrToPrimArray p1 len+ withBytes len $ \p2 -> do+ copyPrimArrayToPtr p2 arr2 0 len+ writeOffPtr p2 ix el+ arr3 <- ptrToPrimArray p2 len+ pure (arr2, arr3)+ arr2 === arr3++-- | Setting a range should match the default implementation+primSetRangeAddr :: (Eq a, Show a, Prim a) => Gen a -> Property+primSetRangeAddr gen = property $ do+ len <- forAll genSmallArrayLen+ (low, high) <- fmap order $ (,)+ <$> forAll (Gen.int (Range.linear 0 (len - 1)))+ <*> forAll (Gen.int (Range.linear 0 (len - 1)))+ el <- forAll gen+ (arr2, arr3) <- liftIO $ do+ withBytes len $ \p1 -> do+ withBytes len $ \p2 -> do+ arr1 <- genPrimArray gen len+ copyPrimArrayToPtr p1 arr1 0 len+ copyPrimArrayToPtr p2 arr1 0 len+ setOffPtr p1 low (high - low) el+ arr2 <- ptrToPrimArray p1 len+ defaultSetOffAddr p2 low (high - low) el+ arr3 <- ptrToPrimArray p2 len+ pure (arr2, arr3)+ arr2 === arr3+ where+ order (x, y) = if x < y then (x, y) else (y, x)+ setOffPtr (Ptr addr#) (I# off#) (I# len#) x =+ primitive_ (setOffAddr# addr# off# len# x)++defaultSetOffAddr :: (Prim a, PrimMonad m) => Ptr a -> Int -> Int -> a -> m ()+defaultSetOffAddr (Ptr addr#) (I# off#) (I# len#) x = primitive_ (go off#)+ where+ end# = off# +# len#+ go !ix# s# = if isTrue# (ix# >=# end#)+ then s#+ else case writeOffAddr# addr# ix# x s# of+ s2# -> go (ix# +# 1#) s2#++-- | Mallocing an array, emptying a list into the array, and then rebuilding the+-- list from that array should produce the original list.+primListRoundtripAddr :: forall a. (Eq a, Show a, Prim a) => Gen a -> Property+primListRoundtripAddr gen = property $ do+ xs <- forAll $ genSmallList gen+ let len = length xs+ xs' <- liftIO $ withBytes len $ \p -> do+ let listToPtr :: Int -> [a] -> IO ()+ listToPtr !ix = \case+ [] -> pure ()+ (y:ys) -> writeOffPtr p ix y *> listToPtr (ix + 1) ys+ let ptrToList :: Int -> IO [a]+ ptrToList !ix =+ if ix >= len+ then pure []+ else (:) <$> readOffPtr p ix <*> ptrToList (ix + 1)+ listToPtr 0 xs+ ptrToList 0+ xs === xs'+
test/Spec.hs view
@@ -24,6 +24,7 @@ import Spec.Monad import Spec.Monoid import Spec.Ord+import Spec.Prim import Spec.Semigroup import Spec.Semiring import Spec.Show@@ -46,6 +47,7 @@ ++ testMonoid ++ testCommutativeMonoid ++ testOrd+ ++ testPrim ++ testSemigroup ++ testCommutativeSemigroup ++ testExponentialSemigroup
+ test/Spec/Prim.hs view
@@ -0,0 +1,23 @@+{-# language TypeApplications #-}++module Spec.Prim (testPrim) where++import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Hedgehog.Classes (Laws, primLaws)++testPrim :: [(String, [Laws])]+testPrim =+ [ ("Int", [primLaws (Gen.int Range.constantBounded)])+ , ("Int8", [primLaws (Gen.int8 Range.constantBounded)])+ , ("Int16", [primLaws (Gen.int16 Range.constantBounded)])+ , ("Int32", [primLaws (Gen.int32 Range.constantBounded)])+ , ("Int64", [primLaws (Gen.int64 Range.constantBounded)])+ , ("Word", [primLaws (Gen.word Range.constantBounded)])+ , ("Word8", [primLaws (Gen.word8 Range.constantBounded)])+ , ("Word16", [primLaws (Gen.word16 Range.constantBounded)])+ , ("Word32", [primLaws (Gen.word32 Range.constantBounded)])+ , ("Word64", [primLaws (Gen.word64 Range.constantBounded)])+ ]+