diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/hedgehog-classes.cabal b/hedgehog-classes.cabal --- a/hedgehog-classes.cabal +++ b/hedgehog-classes.cabal @@ -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 diff --git a/src/Hedgehog/Classes.hs b/src/Hedgehog/Classes.hs --- a/src/Hedgehog/Classes.hs +++ b/src/Hedgehog/Classes.hs @@ -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) diff --git a/src/Hedgehog/Classes/Common.hs b/src/Hedgehog/Classes/Common.hs --- a/src/Hedgehog/Classes/Common.hs +++ b/src/Hedgehog/Classes/Common.hs @@ -1,5 +1,5 @@ module Hedgehog.Classes.Common - ( module Common + ( module Common ) where import Hedgehog.Classes.Common.ApTrans as Common diff --git a/src/Hedgehog/Classes/Comonad.hs b/src/Hedgehog/Classes/Comonad.hs --- a/src/Hedgehog/Classes/Comonad.hs +++ b/src/Hedgehog/Classes/Comonad.hs @@ -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) diff --git a/src/Hedgehog/Classes/Prim.hs b/src/Hedgehog/Classes/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Classes/Prim.hs @@ -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' + diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Spec/Prim.hs b/test/Spec/Prim.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Prim.hs @@ -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)]) + ] +