From b713369134a9892c54bdee6a06074dd1f0162adc Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 4 Dec 2018 17:43:26 +0100 Subject: [PATCH] Semiautomatic checking of typeclass-laws --- package.yaml | 1 + test/Model/TypesSpec.hs | 4 +++ test/Test/QuickCheck/Classes/Hashable.hs | 13 +++++++ test/Test/QuickCheck/Classes/JSON.hs | 38 ++++++++++++++++++++ test/Test/QuickCheck/Classes/PathPiece.hs | 14 ++++++++ test/Test/QuickCheck/Classes/PersistField.hs | 14 ++++++++ test/TestImport.hs | 13 +++++++ 7 files changed, 97 insertions(+) create mode 100644 test/Test/QuickCheck/Classes/Hashable.hs create mode 100644 test/Test/QuickCheck/Classes/JSON.hs create mode 100644 test/Test/QuickCheck/Classes/PathPiece.hs create mode 100644 test/Test/QuickCheck/Classes/PersistField.hs diff --git a/package.yaml b/package.yaml index 4e09e10e4..03de34c0b 100644 --- a/package.yaml +++ b/package.yaml @@ -221,6 +221,7 @@ tests: - QuickCheck - yesod-test - conduit-extra + - quickcheck-classes - quickcheck-instances hlint: main: Hlint.hs diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 518bb7990..7e456118d 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -49,6 +49,10 @@ instance Arbitrary SheetType where spec :: Spec spec = do + describe "UUID" $ + lawsCheckHspec (Proxy :: Proxy UUID) + [ persistFieldLaws, pathPieceLaws, eqLaws, ordLaws, showReadLaws, hashableLaws, jsonLaws, storableLaws, jsonKeyLaws + ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ \term -> termFromText (termToText term) == Right term diff --git a/test/Test/QuickCheck/Classes/Hashable.hs b/test/Test/QuickCheck/Classes/Hashable.hs new file mode 100644 index 000000000..849511bd0 --- /dev/null +++ b/test/Test/QuickCheck/Classes/Hashable.hs @@ -0,0 +1,13 @@ +module Test.QuickCheck.Classes.Hashable + ( hashableLaws + ) where + +import ClassyPrelude +import Test.QuickCheck +import Test.QuickCheck.Classes +import Data.Proxy + +hashableLaws :: forall a. (Arbitrary a, Hashable a, Eq a, Show a) => Proxy a -> Laws +hashableLaws _ = Laws "Hashable" + [ ("Injectivity", property $ \(a :: a) (a' :: a) (s :: Int) -> hashWithSalt s a /= hashWithSalt s a' ==> a /= a') + ] diff --git a/test/Test/QuickCheck/Classes/JSON.hs b/test/Test/QuickCheck/Classes/JSON.hs new file mode 100644 index 000000000..78d586ec3 --- /dev/null +++ b/test/Test/QuickCheck/Classes/JSON.hs @@ -0,0 +1,38 @@ +module Test.QuickCheck.Classes.JSON + ( jsonKeyLaws + ) where + +import ClassyPrelude +import Test.QuickCheck +import Test.QuickCheck.Property (failed) +import Test.QuickCheck.Classes +import Data.Aeson +import Data.Aeson.Encoding.Internal +import Data.Aeson.Types (parseMaybe) +import Data.Proxy +import Unsafe.Coerce -- DON'T PANIC, it's aeson's fault + +jsonKeyLaws :: forall a. (Arbitrary a, FromJSONKey a, ToJSONKey a, Eq a, Show a, FromJSON a, ToJSON a) => Proxy a -> Laws +jsonKeyLaws _ = Laws "ToJSONKey/FromJSONKey" + [ ("Partial Isomorphism", property $ \(a :: a) -> partialIsomorphism a) + , ("Partial Isomorphism (List)", property $ \(as :: [a]) -> partialIsomorphism as) + , ("Encoding Equals Value", property $ \(a :: a) + -> let (toVal, toEnc) = case toJSONKey of + ToJSONKeyText toVal' toEnc' -> (String . toVal', retagEncoding . toEnc') + ToJSONKeyValue toVal' toEnc' -> (toVal', toEnc') + in decode (encodingToLazyByteString $ toEnc a) == Just (toVal a) + ) + ] + where + partialIsomorphism :: forall a'. (Arbitrary a', FromJSONKey a', ToJSONKey a', Eq a', Show a') => a' -> Property + partialIsomorphism a = case (toJSONKey, fromJSONKey) of + (ToJSONKeyText toVal _, FromJSONKeyCoerce _) + -> property $ unsafeCoerce (toVal a) == a + (ToJSONKeyText toVal _, FromJSONKeyText fromVal) + -> property $ fromVal (toVal a) == a + (ToJSONKeyText toVal _, FromJSONKeyTextParser parser) + -> property $ parseMaybe parser (toVal a) == Just a + (ToJSONKeyValue toVal _, FromJSONKeyValue parser) + -> property $ parseMaybe parser (toVal a) == Just a + (_, _) + -> property failed diff --git a/test/Test/QuickCheck/Classes/PathPiece.hs b/test/Test/QuickCheck/Classes/PathPiece.hs new file mode 100644 index 000000000..e7f62722a --- /dev/null +++ b/test/Test/QuickCheck/Classes/PathPiece.hs @@ -0,0 +1,14 @@ +module Test.QuickCheck.Classes.PathPiece + ( pathPieceLaws + ) where + +import ClassyPrelude +import Test.QuickCheck +import Test.QuickCheck.Classes +import Web.PathPieces +import Data.Proxy + +pathPieceLaws :: forall a. (Arbitrary a, PathPiece a, Eq a, Show a) => Proxy a -> Laws +pathPieceLaws _ = Laws "PathPiece" + [ ("Partial Isomorphism", property $ \(a :: a) -> fromPathPiece (toPathPiece a) == Just a) + ] diff --git a/test/Test/QuickCheck/Classes/PersistField.hs b/test/Test/QuickCheck/Classes/PersistField.hs new file mode 100644 index 000000000..53b6419d7 --- /dev/null +++ b/test/Test/QuickCheck/Classes/PersistField.hs @@ -0,0 +1,14 @@ +module Test.QuickCheck.Classes.PersistField + ( persistFieldLaws + ) where + +import ClassyPrelude +import Test.QuickCheck +import Test.QuickCheck.Classes +import Database.Persist +import Data.Proxy + +persistFieldLaws :: forall a. (Arbitrary a, PersistField a, Eq a, Show a) => Proxy a -> Laws +persistFieldLaws _ = Laws "PersistField" + [ ("Partial Isomorphism", property $ \(a :: a) -> fromPersistValue (toPersistValue a) == Right a) + ] diff --git a/test/TestImport.hs b/test/TestImport.hs index 207a563fe..565a8c314 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -18,6 +18,13 @@ import Test.QuickCheck as X import Test.QuickCheck.Gen as X import Data.Default as X import Test.QuickCheck.Instances as X () +import Test.QuickCheck.Classes as X +import Test.QuickCheck.Classes.PathPiece as X +import Test.QuickCheck.Classes.PersistField as X +import Test.QuickCheck.Classes.Hashable as X +import Test.QuickCheck.Classes.JSON as X +import Data.Proxy as X +import Data.UUID as X (UUID) import System.IO as X (hPrint, hPutStrLn, stderr) import Jobs (handleJobs, stopJobCtl) @@ -105,3 +112,9 @@ createUser userIdent = do userMailLanguages = def userNotificationSettings = def runDB $ insertEntity User{..} + +lawsCheckHspec :: Proxy a -> [Proxy a -> Laws] -> Spec +lawsCheckHspec p = mapM_ (checkHspec . ($ p)) + where + checkHspec (Laws className properties) = describe className $ + forM_ properties $ \(name, prop) -> it name $ property prop