Semiautomatic checking of typeclass-laws

package.yaml

@@ -221,6 +221,7 @@ tests:
       - QuickCheck
       - yesod-test
       - conduit-extra
+      - quickcheck-classes
       - quickcheck-instances
   hlint:
     main: Hlint.hs

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

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')
+  ]

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

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)
+  ]

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)
+  ]

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