quickcheck-classes (empty) → 0.1

raw patch · 6 files changed

+379/−0 lines, 6 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, prim-array, primitive, quickcheck-classes

Files

LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
quickcheck-classes.cabal +42/−0
src/Test/QuickCheck/Classes.hs +242/−0
test/Spec.hs +62/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Andrew Martin (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,1 @@+# quickcheck-classes

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ quickcheck-classes.cabal view

@@ -0,0 +1,42 @@+name: quickcheck-classes+version: 0.1+synopsis: QuickCheck common typeclasses+description: QuickCheck common typeclasses+homepage: https://github.com/andrewthad/quickcheck-classes#readme+license: BSD3+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2017 Andrew Martin+category: software+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+  hs-source-dirs: src+  exposed-modules:+    Test.QuickCheck.Classes+  build-depends:+      base >= 4.7 && < 5+    , QuickCheck+    , primitive+    , prim-array+    , aeson+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Spec.hs+  build-depends:+      base+    , quickcheck-classes+    , QuickCheck+    , primitive+    , aeson+  default-language: Haskell2010++source-repository head+  type: git+  location: https://github.com/andrewthad/quickcheck-classes

+ src/Test/QuickCheck/Classes.hs view

@@ -0,0 +1,242 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.QuickCheck.Classes+  ( primProps+  , storableProps+  , semigroupProps+  , monoidProps+  , showReadProps+  , jsonProps+  ) where++import Test.QuickCheck+import Data.Primitive hiding (sizeOf,newArray,copyArray)+import Data.Primitive.PrimArray+import Data.Proxy+import Control.Monad.ST+import GHC.Ptr (Ptr(..))+import Data.Primitive.Addr (Addr(..))+import Foreign.Marshal.Alloc+import System.IO.Unsafe+import Data.Semigroup (Semigroup)+import GHC.Exts (fromList,toList)+import Foreign.Marshal.Array+import Foreign.Storable+import Text.Read (readMaybe)+import Data.Aeson (FromJSON(..),ToJSON(..))+import qualified Data.Aeson as AE+import qualified Data.Primitive as P+import qualified Data.Semigroup as SG+import qualified GHC.OldList as L++jsonProps :: (ToJSON a, FromJSON a, Show a, Arbitrary a, Eq a) => Proxy a -> [(String,Property)]+jsonProps p =+  [ ("Encoding Equals Value", jsonEncodingEqualsValue p)+  , ("Partial Isomorphism", jsonEncodingPartialIsomorphism p)+  ]++showReadProps :: (Show a, Read a, Eq a, Arbitrary a) => Proxy a -> [(String,Property)]+showReadProps p =+  [ ("Partial Isomorphism", showReadPartialIsomorphism p)+  ]++semigroupProps :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> [(String,Property)]+semigroupProps p =+  [ ("Associative", semigroupAssociative p)+  ]++monoidProps :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> [(String,Property)]+monoidProps p =+  [ ("Associative", monoidAssociative p)+  , ("Left Identity", monoidLeftIdentity p)+  , ("Right Identity", monoidRightIdentity p)+  ]++primProps :: (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> [(String,Property)]+primProps p =+  [ ("ByteArray Set-Get (you get back what you put in)", primSetGetByteArray p)+  , ("ByteArray Get-Set (putting back what you got out has no effect)", primGetSetByteArray p)+  , ("ByteArray Set-Set (setting twice is same as setting once)", primSetSetByteArray p)+  , ("ByteArray List Conversion Roundtrips", primListByteArray p)+  , ("Addr Set-Get (you get back what you put in)", primSetGetAddr p)+  , ("Addr Get-Set (putting back what you got out has no effect)", primGetSetAddr p)+  , ("Addr List Conversion Roundtrips", primListAddr p)+  ]++storableProps :: (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> [(String,Property)]+storableProps p =+  [ ("Set-Get (you get back what you put in)", storableSetGet p)+  , ("Get-Set (putting back what you got out has no effect)", storableGetSet p)+  , ("List Conversion Roundtrips", storableList p)+  ]++showReadPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property+showReadPartialIsomorphism _ = property $ \(a :: a) ->+  readMaybe (show a) == Just a++-- TODO: improve the quality of the error message if+-- something does not pass this test.+jsonEncodingEqualsValue :: forall a. (ToJSON a, Show a, Arbitrary a) => Proxy a -> Property+jsonEncodingEqualsValue _ = property $ \(a :: a) ->+  case AE.decode (AE.encode a) of+    Nothing -> False+    Just (v :: AE.Value) -> v == toJSON a++jsonEncodingPartialIsomorphism :: forall a. (ToJSON a, FromJSON a, Show a, Eq a, Arbitrary a) => Proxy a -> Property+jsonEncodingPartialIsomorphism _ = property $ \(a :: a) ->+  AE.decode (AE.encode a) == Just a++semigroupAssociative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+semigroupAssociative _ = property $ \(a :: a) b c -> a SG.<> (b SG.<> c) == (a SG.<> b) SG.<> c++monoidAssociative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+monoidAssociative _ = property $ \(a :: a) b c -> mappend a (mappend b c) == mappend (mappend a b) c++monoidLeftIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+monoidLeftIdentity _ = property $ \(a :: a) -> mappend mempty a == a++monoidRightIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+monoidRightIdentity _ = property $ \(a :: a) -> mappend a mempty == a++primListByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primListByteArray _ = property $ \(as :: [a]) ->+  as == toList (fromList as :: PrimArray a)++primListAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primListAddr _ = property $ \(as :: [a]) -> unsafePerformIO $ do+  let len = L.length as+  ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+  let addr = Addr addr#+  let go :: Int -> [a] -> IO ()+      go !ix xs = case xs of+        [] -> return ()+        (x : xsNext) -> do+          writeOffAddr addr ix x+          go (ix + 1) xsNext+  go 0 as+  let rebuild :: Int -> IO [a]+      rebuild !ix = if ix < len+        then (:) <$> readOffAddr addr ix <*> rebuild (ix + 1)+        else return []+  asNew <- rebuild 0+  free ptr+  return (as == asNew)++primSetGetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primSetGetByteArray _ = property $ \(a :: a) len -> (len > 0) ==> do+  ix <- choose (0,len - 1)+  return $ runST $ do+    arr <- newPrimArray len+    writePrimArray arr ix a+    a' <- readPrimArray arr ix+    return (a == a')++primGetSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primGetSetByteArray _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do+  let arr1 = fromList as :: PrimArray a+      len = L.length as+  ix <- choose (0,len - 1)+  arr2 <- return $ runST $ do+    marr <- newPrimArray len+    copyPrimArray marr 0 arr1 0 len+    a <- readPrimArray marr ix+    writePrimArray marr ix a+    unsafeFreezePrimArray marr+  return (arr1 == arr2)++primSetSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primSetSetByteArray _ = property $ \(a :: a) (as :: [a]) -> (not (L.null as)) ==> do+  let arr1 = fromList as :: PrimArray a+      len = L.length as+  ix <- choose (0,len - 1)+  (arr2,arr3) <- return $ runST $ do+    marr2 <- newPrimArray len+    copyPrimArray marr2 0 arr1 0 len+    writePrimArray marr2 ix a+    marr3 <- newPrimArray len+    copyMutablePrimArray marr3 0 marr2 0 len+    arr2 <- unsafeFreezePrimArray marr2+    writePrimArray marr3 ix a+    arr3 <- unsafeFreezePrimArray marr3+    return (arr2,arr3)+  return (arr2 == arr3)++primSetGetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primSetGetAddr _ = property $ \(a :: a) len -> (len > 0) ==> do+  ix <- choose (0,len - 1)+  return $ unsafePerformIO $ do+    ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+    let addr = Addr addr#+    writeOffAddr addr ix a+    a' <- readOffAddr addr ix+    free ptr+    return (a == a')++primGetSetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+primGetSetAddr _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do+  let arr1 = fromList as :: PrimArray a+      len = L.length as+  ix <- choose (0,len - 1)+  arr2 <- return $ unsafePerformIO $ do+    ptr@(Ptr addr#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+    let addr = Addr addr#+    copyPrimArrayToPtr ptr arr1 0 len+    a :: a <- readOffAddr addr ix+    writeOffAddr addr ix a+    marr <- newPrimArray len+    copyPtrToMutablePrimArray marr 0 ptr len+    free ptr+    unsafeFreezePrimArray marr+  return (arr1 == arr2)++storableSetGet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+storableSetGet _ = property $ \(a :: a) len -> (len > 0) ==> do+  ix <- choose (0,len - 1)+  return $ unsafePerformIO $ do+    ptr :: Ptr a <- mallocArray len+    pokeElemOff ptr ix a+    a' <- peekElemOff ptr ix+    free ptr+    return (a == a')++storableGetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+storableGetSet _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do+  let len = L.length as+  ix <- choose (0,len - 1)+  return $ unsafePerformIO $ do+    ptrA <- newArray as+    ptrB <- mallocArray len+    copyArray ptrB ptrA len+    a <- peekElemOff ptrA ix+    pokeElemOff ptrA ix a+    res <- arrayEq ptrA ptrB len+    free ptrA+    free ptrB+    return res++storableList :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property+storableList _ = property $ \(as :: [a]) -> unsafePerformIO $ do+  let len = L.length as+  ptr <- newArray as+  let rebuild :: Int -> IO [a]+      rebuild !ix = if ix < len+        then (:) <$> peekElemOff ptr ix <*> rebuild (ix + 1)+        else return []+  asNew <- rebuild 0+  free ptr+  return (as == asNew)++arrayEq :: forall a. (Storable a, Eq a) => Ptr a -> Ptr a -> Int -> IO Bool+arrayEq ptrA ptrB len = go 0 where+  go !i = if i < len+    then do+      a <- peekElemOff ptrA i+      b <- peekElemOff ptrB i+      if a == b+        then go (i + 1)+        else return False+    else return True+

+ test/Spec.hs view

@@ -0,0 +1,62 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++import Test.QuickCheck+import Data.Proxy+import Data.Word+import Data.Int+import Control.Monad+import Data.Primitive+import Data.Foldable+import Data.Monoid (Sum)+import Foreign.Storable+import Data.Aeson (ToJSON,FromJSON)++import Test.QuickCheck.Classes++main :: IO ()+main = do+  putStrLn "Testing properties for common typeclasses"+  r <- flip foldlMapM allPropsApplied $ \(typeName,properties) -> do+    putStrLn $ "------------"+    putStrLn $ "-- " ++ typeName+    putStrLn $ "------------"+    flip foldlMapM properties $ \(name,p) -> do+      putStrLn name+      r <- quickCheckResult p+      return $ case r of+        Success _ _ _ -> Good+        _ -> Bad+  putStrLn ""+  case r of+    Good -> putStrLn "All tests succeeded"+    Bad -> putStrLn "One or more tests failed"++data Status = Bad | Good++instance Monoid Status where+  mempty = Good+  mappend Good x = x+  mappend Bad _ = Bad++allPropsApplied :: [(String,[(String,Property)])]+allPropsApplied = +  [ ("Word8",allProps (Proxy :: Proxy Word8))+  , ("Int16",allProps (Proxy :: Proxy Int16))+  , ("Int",allProps (Proxy :: Proxy Int))+  , ("Word",allProps (Proxy :: Proxy Word))+  , ("Int64",allProps (Proxy :: Proxy Int64))+  ]++allProps :: forall a. (Num a, Prim a, Storable a, Eq a, Arbitrary a, Show a, Read a, ToJSON a, FromJSON a) => Proxy a -> [(String,Property)]+allProps p = concat+  [ primProps p+  , storableProps p+  , monoidProps (Proxy :: Proxy (Sum a))+  , showReadProps p+  , jsonProps p+  ]++foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b+foldlMapM f = foldlM (\b a -> fmap (mappend b) (f a)) mempty+