Doesn't catch unlawful monad

[masaeedu]

Hello. I was trying to find out when a map with a monoid key is a monad, so I defined this:

newtype Mapnad k v = Mapnad { runMapnad :: Map k v }
  deriving newtype (Show, Eq, Arbitrary, Functor)

fromList' :: Ord k => [(k, v)] -> Mapnad k v
fromList' = Mapnad . fromList

toList' :: Mapnad k v -> [(k,  v)]
toList' = toList . runMapnad

instance (Ord k, Monoid k) => Applicative (Mapnad k)
  where
  pure = return
  (<*>) = ap

joinMapnad :: (Ord k, Monoid k) => Mapnad k (Mapnad k v) -> Mapnad k v
joinMapnad = fromList' . fmap join . (>>= sequenceA) . toList' . fmap toList'

instance (Ord k, Monoid k) => Monad (Mapnad k)
  where
  return = Mapnad . singleton mempty
  ma >>= amb = joinMapnad $ fmap amb ma

I tested this against the tests for monad laws exported from both quickcheck-classes and hedgehog-classes.

Here is what I did for quickcheck-classes:

main :: IO ()
main = do
  lawsCheck $ monadLaws $ Proxy @(Mapnad String)
  lawsCheck $ monadLaws $ Proxy @(Mapnad (Sum Int))

And here is what I did for hedgehog-classes:

aGoodSize :: Range Int
aGoodSize = R.linear 0 10

genMap :: (Ord k, Monoid k) => Gen k -> Gen a -> Gen (Mapnad k a)
genMap k g = Mapnad <$> G.map aGoodSize ((,) <$> k <*> g)

sumgen :: Gen (Sum Int)
sumgen = Sum <$> G.int (R.linear (-100) 100)

strgen :: Gen String
strgen = G.string aGoodSize G.alpha

main :: IO Bool
main = do
  lawsCheck $ monadLaws $ genMap strgen
  lawsCheck $ monadLaws $ genMap sumgen

For a key type of String, both libraries detect no problems (I suspect the monad is lawful for this monoid). For a key type of Sum Int however, quickcheck-classes finds a counterexample to the following associativity law:

m >>= (\x -> k x >>= h) == m >>= k >>= h

with the following inputs:

m :: { 0 -> 0, 3 -> 7 }
k :: \x -> if (odd x) then { -3 -> 1 } else { 0 -> 0 }
h :: \x -> if (odd x) then { }         else { 0 -> 0 }

For these inputs (and probably others), Mapnad (Sum Int) does not satisfy the associativity law. Nevertheless, hedgehog-classes doesn't find any problems:

Monad: Left Identity    ✓ <interactive> passed 100 tests.
Monad: Right Identity    ✓ <interactive> passed 100 tests.
Monad: Associativity    ✓ <interactive> passed 100 tests.
Monad: Return    ✓ <interactive> passed 100 tests.
Monad: Ap    ✓ <interactive> passed 100 tests.
Monad: Left Identity    ✓ <interactive> passed 100 tests.
Monad: Right Identity    ✓ <interactive> passed 100 tests.
Monad: Associativity    ✓ <interactive> passed 100 tests.
Monad: Return    ✓ <interactive> passed 100 tests.
Monad: Ap    ✓ <interactive> passed 100 tests.

/cc @chessai, who asked me to file an issue about this.