[#7] Add typeclasses law tests

Resolves #7
kowainik · Oct 10, 2020 · d33ba90 · d33ba90
1 parent 7b76696
commit d33ba90
Show file tree

Hide file tree

Showing 4 changed files with 84 additions and 5 deletions.
diff --git a/src/Prolens.hs b/src/Prolens.hs
@@ -40,25 +40,37 @@ import Control.Applicative (Const (..))
 import Data.Coerce (coerce)
 
 
+{- |
+
+Instances of 'Profunctor' should satisfy the following laws:
+
+* __Identity:__ @'dimap' 'id' 'id' ≡ 'id'@
+* __Composition:__ @'dimap' (ab . bc) (yz . xy) ≡ 'dimap' bc yz . 'dimap' ab xy@
+
+@since 0.0.0.0
+-}
 -- type Profunctor :: (Type -> Type -> Type) -> Constraint
 class (forall a . Functor (p a)) => Profunctor p where
     dimap :: (a -> b) -> (c -> d) -> p b c -> p a d
 
+-- | @since 0.0.0.0
 instance Profunctor (->) where
     dimap :: (a -> b) -> (c -> d) -> (b -> c) -> (a -> d)
     dimap ab cd bc = cd . bc . ab
     {-# INLINE dimap #-}
 
+-- | @since 0.0.0.0
 newtype Fun m a b = Fun
     { unFun :: a -> m b
     }
 
--- @since 0.0.0.0
+-- | @since 0.0.0.0
 instance Functor m => Functor (Fun m x) where
     fmap :: (a -> b) -> Fun m x a -> Fun m x b
     fmap f (Fun xma) = Fun (fmap f . xma)
     {-# INLINE fmap #-}
 
+-- | @since 0.0.0.0
 instance Functor m => Profunctor (Fun m) where
     dimap :: (a -> b) -> (c -> d) -> Fun m b c -> Fun m a d
     dimap ab cd (Fun bmc) = Fun (fmap cd . bmc . ab)

diff --git a/test/Spec.hs b/test/Spec.hs
@@ -4,11 +4,12 @@ import Test.Hspec (hspec)
 
 import Test.Prolens (unitSpecs)
 import Test.Prolens.Inspection (inspectionSpec)
-import Test.Prolens.Property (lensPropertySpecs)
+import Test.Prolens.Property (lensPropertySpecs, typeclassesPropertySpecs)
 
 
 main :: IO ()
 main = hspec $ do
     unitSpecs
     inspectionSpec
     lensPropertySpecs
+    typeclassesPropertySpecs
diff --git a/test/Test/Data.hs b/test/Test/Data.hs
@@ -9,14 +9,17 @@ module Test.Data
     , me
 
       -- * Generators
+    , genFun
+    , genFunction
     , genHaskeller
+    , genInt
     , genKnowledge
     , genName
     ) where
 
 import Test.Hspec.Hedgehog (MonadGen)
 
-import Prolens (Lens', lens)
+import Prolens (Fun (..), Lens', lens)
 
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
@@ -81,3 +84,23 @@ genHaskeller = do
 
 genName :: MonadGen m => m String
 genName = Gen.string (Range.linear 1 50) Gen.alphaNum
+
+genInt :: MonadGen m => m Int
+genInt = Gen.enumBounded
+
+genFunction :: MonadGen m => m (Int -> Int)
+genFunction = genInt >>= \n -> Gen.element
+    [ id
+    , const n
+    , (+ n)
+    , (* n)
+    , subtract n
+    , \x -> if x >= n then 1 else 0
+    ]
+
+genFun :: MonadGen m => m (Fun Maybe Int Int)
+genFun = genFunction >>= \f -> Gen.element $ map Fun
+    [ Just
+    , const Nothing
+    , Just . f
+    ]
diff --git a/test/Test/Prolens/Property.hs b/test/Test/Prolens/Property.hs
@@ -1,12 +1,13 @@
 module Test.Prolens.Property
     ( lensPropertySpecs
+    , typeclassesPropertySpecs
     ) where
 
 import Test.Hspec (Spec, describe, it)
-import Test.Hspec.Hedgehog (forAll, hedgehog, (===))
+import Test.Hspec.Hedgehog (PropertyT, forAll, forAllWith, hedgehog, (===))
 
 import Prolens
-import Test.Data (genHaskeller, genName, nameL)
+import Test.Data (genFun, genFunction, genHaskeller, genInt, genName, nameL)
 
 
 lensPropertySpecs :: Spec
@@ -23,3 +24,45 @@ lensPropertySpecs = describe "Lens Laws" $ do
         value <- forAll genName
         valueNew <- forAll genName
         set nameL valueNew (set nameL value source) === set nameL valueNew source
+
+typeclassesPropertySpecs :: Spec
+typeclassesPropertySpecs = describe "Class Laws" -- $ do
+    profunctorsSpec
+
+profunctorsSpec :: Spec
+profunctorsSpec = describe "Profunctor" $ do
+    describe "(->)" $ do
+        it "Identity: dimap id id ≡ id" $ hedgehog $ do
+            f <- forAllWith (const "f") genFunction
+            x <- forAll genInt
+            dimap id id f x === f x
+        it "Composition: dimap (ab . bc) (yz . xy) ≡ dimap bc yz . dimap ab xy" $ hedgehog $ do
+
+            f  <- forAllWith (const "f")  genFunction
+            ab <- forAllWith (const "ab") genFunction
+            bc <- forAllWith (const "bc") genFunction
+            xy <- forAllWith (const "xy") genFunction
+            yz <- forAllWith (const "xy") genFunction
+
+            n <- forAll genInt
+            dimap (ab . bc) (yz . xy) f n === (dimap bc yz . dimap ab xy) f n
+    describe "Fun" $ do
+        it "Identity: dimap id id ≡ id" $ hedgehog $ do
+            f <- forAllWith (const "f") genFun
+            eqFun (dimap id id f) f
+        it "Composition: dimap (ab . bc) (yz . xy) ≡ dimap bc yz . dimap ab xy" $ hedgehog $ do
+
+            f  <- forAllWith (const "f")  genFun
+            ab <- forAllWith (const "ab") genFunction
+            bc <- forAllWith (const "bc") genFunction
+            xy <- forAllWith (const "xy") genFunction
+            yz <- forAllWith (const "xy") genFunction
+
+            eqFun
+                (dimap (ab . bc) (yz . xy) f)
+                (dimap bc yz $ dimap ab xy f)
+
+eqFun :: Fun Maybe Int Int -> Fun Maybe Int Int -> PropertyT IO ()
+eqFun fun1 fun2 = do
+    x <- forAll genInt
+    unFun fun1 x === unFun fun2 x