From 79c237f34bde766dab2b81c857880297104bf2a2 Mon Sep 17 00:00:00 2001
From: chessai <chessai1996@gmail.com>
Date: Sun, 6 Jan 2019 18:09:55 -0500
Subject: [PATCH] add monadIOLaws

---
 quickcheck-classes.cabal               |  1 +
 src/Test/QuickCheck/Classes.hs         |  2 +
 src/Test/QuickCheck/Classes/MonadIO.hs | 85 ++++++++++++++++++++++++++
 3 files changed, 88 insertions(+)
 create mode 100644 src/Test/QuickCheck/Classes/MonadIO.hs

diff --git a/quickcheck-classes.cabal b/quickcheck-classes.cabal
index 3ed24ed..8f8e334 100644
--- a/quickcheck-classes.cabal
+++ b/quickcheck-classes.cabal
@@ -90,6 +90,7 @@ library
     Test.QuickCheck.Classes.Json
     Test.QuickCheck.Classes.Monad
     Test.QuickCheck.Classes.MonadFail
+    Test.QuickCheck.Classes.MonadIO
     Test.QuickCheck.Classes.MonadPlus
     Test.QuickCheck.Classes.MonadZip
     Test.QuickCheck.Classes.Monoid
diff --git a/src/Test/QuickCheck/Classes.hs b/src/Test/QuickCheck/Classes.hs
index 9d79a9f..92ca01d 100644
--- a/src/Test/QuickCheck/Classes.hs
+++ b/src/Test/QuickCheck/Classes.hs
@@ -58,6 +58,7 @@ module Test.QuickCheck.Classes
   , foldableLaws
   , functorLaws
   , monadLaws
+  , monadIOLaws
   , monadPlusLaws
   , monadZipLaws
 #if HAVE_SEMIGROUPOIDS
@@ -120,6 +121,7 @@ import Test.QuickCheck.Classes.Applicative
 import Test.QuickCheck.Classes.Foldable
 import Test.QuickCheck.Classes.Functor
 import Test.QuickCheck.Classes.Monad
+import Test.QuickCheck.Classes.MonadIO
 import Test.QuickCheck.Classes.MonadPlus
 import Test.QuickCheck.Classes.MonadZip
 #if HAVE_SEMIGROUPOIDS
diff --git a/src/Test/QuickCheck/Classes/MonadIO.hs b/src/Test/QuickCheck/Classes/MonadIO.hs
new file mode 100644
index 0000000..eeac335
--- /dev/null
+++ b/src/Test/QuickCheck/Classes/MonadIO.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+
+#if HAVE_QUANTIFIED_CONSTRAINTS
+{-# LANGUAGE QuantifiedConstraints #-}
+#endif
+
+{-# OPTIONS_GHC -Wall #-}
+
+module Test.QuickCheck.Classes.MonadIO
+  (
+#if HAVE_UNARY_LAWS
+    monadIOLaws
+#endif
+  ) where
+
+import System.IO.Unsafe (unsafePerformIO)
+import Control.Applicative
+import Test.QuickCheck hiding ((.&.))
+import Control.Monad.IO.Class (MonadIO(..))
+#if HAVE_UNARY_LAWS
+import Test.QuickCheck.Arbitrary (Arbitrary1(..))
+import Data.Functor.Classes (Eq1,Show1)
+#endif
+import Test.QuickCheck.Property (Property)
+
+import Test.QuickCheck.Classes.Common
+#if HAVE_UNARY_LAWS
+import Test.QuickCheck.Classes.Compat (eq1)
+#endif
+
+#if HAVE_UNARY_LAWS
+
+-- | Tests the following 'MonadIO' properties:
+--
+-- [/Return/]
+--   @'liftIO' '.' 'return' ≡ 'return'@
+-- [/LiftIO Transforms/]
+--   @'liftIO' (m '>>=' f) ≡ 'liftIO' m '>>=' ('liftIO' '.' f)@
+monadIOLaws ::
+#if HAVE_QUANTIFIED_CONSTRAINTS
+  (MonadIO f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))
+#else
+  (MonadIO f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f)
+#endif
+  => proxy f -> Laws
+monadIOLaws p = Laws "Monad"
+  [ ("Return", monadIOReturn p)
+  , ("LiftIO Transform", monadIOTransform p)
+  ]
+
+type MonadIOProp proxy f =
+  ( MonadIO f
+#if HAVE_QUANTIFIED_CONSTRAINTS
+  , forall x. Eq x => Eq (f x)
+  , forall x. Show x => Show (f x)
+  , forall x. Arbitrary x => Arbitrary (f x)
+#else
+  , Eq1 f
+  , Show1 f
+  , Arbitrary1 f
+#endif
+  ) => proxy f -> Property
+
+monadIOReturn :: forall proxy f. MonadIOProp proxy f
+monadIOReturn _ = property $ \(x :: Integer) -> liftIO (pure x) == (pure x :: f Integer)
+
+monadIOTransform :: forall proxy f. MonadIOProp proxy f
+monadIOTransform _ = property $ \(m' :: ShowIO Integer) (f' :: LinearEquation) ->
+  let m = getShowIO m'
+      f = pure . runLinearEquation f'
+      x = liftIO (m >>= f) :: f Integer
+      y = liftIO m >>= (liftIO . f) :: f Integer 
+  in x == y
+
+newtype ShowIO a = ShowIO { getShowIO :: IO a }
+
+instance Show a => Show (ShowIO a) where
+  show = unsafePerformIO . fmap (\x -> "IO <val: " ++ show x ++ ">") . getShowIO
+
+instance Arbitrary a => Arbitrary (ShowIO a) where
+  arbitrary = fmap (ShowIO . pure) arbitrary
+
+#endif