使用 QuickCheck 测试一元法则

是否有用于测试的库或工具laws https://wiki.haskell.org/Monad_laws自定义 monad 的？我目前的黑客尝试是这样的：

• Define Arbitrary1， 如同Eq1, Show1 etc.
• 定义一个包装的辅助类型Arbitrary1 as Arbitrary.
• 定义一元法则的测试（例如）。

这些是否已经在某处实施？

{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
import Data.Functor.Classes
import Data.Proxy
import Test.QuickCheck
import Test.QuickCheck.Function
import Test.QuickCheck.Poly

Define Arbitrary1 for * -> * types:

class Arbitrary1 m where
    arbitrary1 :: (Arbitrary a) => Gen (m a)
    shrink1 :: (Arbitrary a) => m a -> [m a]
    shrink1 _ = []

和一个辅助包装器，以便我们可以使用与Arbitrary:

newtype Action m a = Action { getAction :: m a }

instance (Arbitrary a, Arbitrary1 m) => Arbitrary (Action m a) where
    arbitrary = Action <$> arbitrary1
    shrink = map Action . shrink1 . getAction

instance (Show a, Show1 m) => Show (Action m a) where
    showsPrec p = showsPrec1 p . getAction

现在我们可以编写这样的测试：

-- (m >>= f) >>= g  ≡   m >>= (\x -> f x >>= g)
testBindAssoc :: forall m . (Monad m, Arbitrary1 m, Show1 m, Eq1 m) => Proxy m -> Property
testBindAssoc _ =
    forAllShrink (arbitrary :: Gen (Action m A)) shrink $ \m' ->
    forAllShrink (arbitrary :: Gen (Fun A (Action m B))) shrink $ \f' ->
    forAllShrink (arbitrary :: Gen (Fun B (Action m C))) shrink $ \g' ->
    let m = getAction m'
        f = getAction <$> apply f'
        g = getAction <$> apply g'
        k = (m >>= f) >>= g
        l = m >>= (\x -> f x >>= g)
    in counterexample (showsPrec1 0 k . showString " != " . showsPrec1 0 l $ "")
        $ k `eq1` l

让我们写一个破碎的Writer monad:

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Control.Monad.Writer

newtype MyMonad w a = MyMonad { runMyMonad :: Writer w a }
  deriving (Functor, Applicative)

instance (Monoid w) => Monad (MyMonad w) where
    return = pure
    k >>= f = let (a, w) = runWriter . runMyMonad $ k
              in MyMonad $ writer (a, w <> w) >>= (runMyMonad . f)
--                                    ^ broken here

getMyMonad :: MyMonad w a -> (a, w)
getMyMonad = runWriter . runMyMonad

instance (Eq w) => Eq1 (MyMonad w) where
    eq1 k l = getMyMonad k == getMyMonad l

instance (Show w) => Show1 (MyMonad w) where
    showsPrec1 p k = showsPrec p (getMyMonad k)

instance (Monoid w, Arbitrary w) => Arbitrary1 (MyMonad w) where
    arbitrary1 = MyMonad . writer <$> arbitrary
    shrink1 = map (MyMonad . writer) . shrink . getMyMonad

main :: IO ()
main = quickCheck (testBindAssoc (Proxy :: Proxy (MyMonad (Sum Int))))

失败：

*** Failed! Falsifiable (after 2 tests and 13 shrinks):   
(1,Sum {getSum = 1})
{_->(1,Sum {getSum = 0})}
{_->(1,Sum {getSum = 0})}
(1,Sum {getSum = 4}) != (1,Sum {getSum = 2})

有什么改进的想法吗？