Testing of monad laws for https://www.reddit.com/r/haskell/comments/7oav51/i_made_a_monad_that_i_havent_seen_before_and_i/

prescient.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Applicative
import Data.Monoid
import GHC.Generics (Generic)
import Test.QuickCheck
import Test.QuickCheck.Function

data Prescient m a = Prescient (m -> a) m
instance Functor (Prescient m) where
    fmap f (Prescient g m) = Prescient (f . g) m

instance Monoid m => Applicative (Prescient m) where
    pure a = Prescient (const a) mempty
    Prescient f m1 <*> Prescient a m2 = Prescient (\m -> f m (a m)) (m1 <> m2)
    -- liftA2 f (Prescient a m1) (Prescient b m2) = Prescient (\m -> f (a m) (b m)) (m1 <> m2)

-- Does this break any laws?
instance Monoid m => Monad (Prescient m) where
    Prescient f m1 >>= b = Prescient (\m -> let Prescient g _ = b (f m) in g m) (let Prescient _ m2 = b (f mempty) in m1 <> m2)

-- Test it!

-- A morally equivalent type that can be generated, shrunk and shown.
data Prescient' m a = Prescient' (Fun m a) m
  deriving (Show, Generic)

instance (Function m, CoArbitrary m, Arbitrary m, Arbitrary a) => Arbitrary (Prescient' m a) where
  arbitrary = Prescient' <$> arbitrary <*> arbitrary
  shrink = genericShrink

unq :: Prescient' m a -> Prescient m a
unq (Prescient' (Fun _ f) m) = Prescient f m

type Prescient_ = Prescient' [Bool] -- fix a monoid

-- Testable equality
(=?)
  :: (Eq m, Eq a, Arbitrary m, Show m, Show a)
  => Prescient m a -> Prescient m a -> Property
Prescient f m =? Prescient f' m' = m === m' .&&. property (liftA2 (===) f f')

qc prop = quickCheckWith stdArgs{maxSuccess = 1000, maxSize = 1000} prop

main = do
  qc $ \(a :: Int) (Fun _ (k' :: Int -> Prescient_ Int)) ->
    let k = unq . k' in
    (return a >>= k) =? k a

  qc $ \(m' :: Prescient_ Int) ->
    let m = unq m' in
    (m >>= return) =? m

  qc $ \(m' :: Prescient_ Int) (Fun _ (k' :: Int -> Prescient_ Int)) (Fun _ (h' :: Int -> Prescient_ Int)) ->
    let m = unq m' ; k = unq . k' ; h = unq . h' in
    ((m >>= k) >>= h) =? (m >>= \a -> k a >>= h)