Add instance Monad ZipList

[Roman Cheplyaka]

On 04/06/2020 09.53, Dannyu NDos wrote:
> instance Monad ZipList where
>     ZipList [] >>= _ = ZipList []
>     ZipList (x:xs) >>= f = ZipList $ do
>         let ZipList y' = f x
>         guard (not (null y'))
>         let ZipList ys = ZipList xs >>= ZipList . join . maybeToList . fmap snd . uncons . getZipList . f
>         head y' : ys
> 
> instance MonadFail ZipList where
>     fail _ = empty
> 
> instance MonadPlus ZipList

While others have commented on the general feasibility of the idea, the problem with this specific instance is that it appears to violate the associativity law:

% ./ziplist --smallcheck-depth=3                                                           
Monad laws
  Right identity: OK
    21 tests completed
  Left identity:  OK
    98 tests completed
  Associativity:  FAIL (0.04s)
    there exist {True->ZipList {getZipList = [True]};False->ZipList {getZipList = [False,True]}} {True->ZipList {getZipList = [True,True]};False->ZipList {getZipList = []}} ZipList {getZipList = [True,False]} such that
      condition is false

1 out of 3 tests failed (0.05s)


Here's the code I used for testing:

{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses #-}
import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe
import Test.SmallCheck.Series
import Test.Tasty
import Test.Tasty.SmallCheck

instance Monad ZipList where
    ZipList [] >>= _ = ZipList []
    ZipList (x:xs) >>= f = ZipList $ do
        let ZipList y' = f x
        guard (not (null y'))
        let ZipList ys = ZipList xs >>= ZipList . join . maybeToList . fmap snd . uncons . getZipList . f
        head y' : ys

instance Serial m a => Serial m (ZipList a) where
  series = ZipList <$> series

main = defaultMain $ testGroup "Monad laws"
  [ testProperty "Right identity" $ \(z :: ZipList Int) ->
      (z >>= return) == z
  , testProperty "Left identity" $ \(b :: Bool) (f :: Bool -> ZipList Bool) ->
      (return b >>= f) == f b
  , testProperty "Associativity" $
      \(f1 :: Bool -> ZipList Bool)
       (f2 :: Bool -> ZipList Bool)
       (z :: ZipList Bool) ->
         (z >>= (\x -> f1 x >>= f2)) == ((z >>= f1) >>= f2)
  ]

Roman