Add tests for isomorphisms of monads

maciejpirog · Aug 24, 2023 · 5115699 · 5115699
1 parent c2a7fbb
commit 5115699
Showing 1 changed file with 30 additions and 1 deletion.
diff --git a/test/Control/Monad/List/ExoticSpec.hs b/test/Control/Monad/List/ExoticSpec.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -52,7 +53,27 @@ testMonad name _ =
       \xs -> toList (join (return xs))      == toList ((xs :: m Int))
     modifyMaxSuccess (const assocTests) $ it "associativity:" $ property $
       \xsss -> toList (join (join xsss))    == toList (join (fmap join xsss) :: m Int)
-
+
+testMonadIsomorphism :: forall m n. (Eq (Item (m Int)), ListMonad m, Arbitrary (m Int),
+                        Arbitrary (m (m Int)),
+                        IsList (m Int),
+                        Show (m Int), Show (m (m Int)),
+                        Eq (Item (n Int)), ListMonad n, Arbitrary (n Int),
+                        Arbitrary (n (n Int)),
+                        IsList (n Int),
+                        Show (n Int), Show (n (n Int)))
+          => String -> String -> Proxy m -> Proxy n -> (forall a. m a -> n a) -> (forall a. n a -> m a) -> SpecWith ()
+testMonadIsomorphism name name' _ _ f g =
+  describe (name ++ " and " ++ name' ++ " are isomorphic as monads") $ do
+    it "inverse:" $ property $
+      \xs -> toList (xs :: m Int) == toList (g (f xs))
+    it "other inverse:" $ property $
+      \xs -> toList (xs :: n Int) == toList (f (g xs))
+    it "homomorphism:" $ property $
+      \xs -> toList (join (xs :: m (m (Int)))) == toList (g (join (f (fmap f xs))))
+    it "other homomorphism:" $ property $
+      \xs -> toList (join (xs :: n (n (Int)))) == toList (f (join (g (fmap g xs))))
+
 spec :: Spec
 spec = do
   describe "palindromize" $ do
@@ -137,6 +158,8 @@ spec = do
   testMonad  "AtLeast 1"          (Proxy :: Proxy (AtLeast 1))
   testMonad  "AtLeast 0"          (Proxy :: Proxy (AtLeast 0))
 
+  testMonadIsomorphism "AtLeast 1" "GlobalFailure" (Proxy :: Proxy (AtLeast 1)) (Proxy :: Proxy GlobalFailure) (GlobalFailure . unAtLeast) (AtLeast . unGlobalFailure)
+
   testMonad  "NumericalMonoidMonad []" (Proxy :: Proxy (NumericalMonoidMonad '[]))
   testMonad  "NumericalMonoidMonad [0]" (Proxy :: Proxy (NumericalMonoidMonad '[0]))
   testMonad  "NumericalMonoidMonad [1]" (Proxy :: Proxy (NumericalMonoidMonad '[1]))
@@ -147,6 +170,12 @@ spec = do
   testMonad  "NumericalMonoidMonad [3,7]" (Proxy :: Proxy (NumericalMonoidMonad '[3,7]))
   testMonad  "NumericalMonoidMonad [2,4,11]" (Proxy :: Proxy (NumericalMonoidMonad '[2,4,11]))
 
+  testMonadIsomorphism "Mini" "NumericalMonoidMonad '[]" (Proxy :: Proxy Mini) (Proxy :: Proxy (NumericalMonoidMonad '[])) (NumericalMonoidMonad . unMini) (Mini . unNumericalMonoidMonad)
+  testMonadIsomorphism "Odd" "NumericalMonoidMonad '[2]" (Proxy :: Proxy Odd) (Proxy :: Proxy (NumericalMonoidMonad '[2])) (NumericalMonoidMonad . unOdd) (Odd . unNumericalMonoidMonad)
+  testMonadIsomorphism "AtLeast 3" "NumericalMonoidMonad '[2,3]" (Proxy :: Proxy (AtLeast 3)) (Proxy :: Proxy (NumericalMonoidMonad '[2,3])) (NumericalMonoidMonad . unAtLeast) (AtLeast . unNumericalMonoidMonad)
+  testMonadIsomorphism "AtLeast 4" "NumericalMonoidMonad '[3,4,5]" (Proxy :: Proxy (AtLeast 4)) (Proxy :: Proxy (NumericalMonoidMonad '[3,4,5])) (NumericalMonoidMonad . unAtLeast) (AtLeast . unNumericalMonoidMonad)
+  testMonadIsomorphism "AtLeast 5" "NumericalMonoidMonad '[4,5,6,7]" (Proxy :: Proxy (AtLeast 5)) (Proxy :: Proxy (NumericalMonoidMonad '[4,5,6,7])) (NumericalMonoidMonad . unAtLeast) (AtLeast . unNumericalMonoidMonad)
+
   testMonad  "ContinuumOfMonads Primes" (Proxy :: Proxy (ContinuumOfMonads "Primes"))
   testMonad  "ContinuumOfMonads Fib" (Proxy :: Proxy (ContinuumOfMonads "Fib"))