Example.hs

module Example where

import Control.Applicative
import Test.QuickCheck
import Test.QuickCheck.Checkers
import Test.QuickCheck.Classes


data Sum a b =
  First a
  | Second b
  deriving (Eq, Show)

data Validation e a =
  Error e
  | Success a
  deriving (Eq, Show)

instance Functor (Sum a) where
  fmap _ (First a) = First a
  fmap f (Second b) = Second (f b)

instance Applicative (Sum a) where
  pure b = Second b
  (First a) <*> _         = First a
  _ <*> (First a)         = First a
  (Second f) <*> (Second b) = Second (f b)

instance (Arbitrary a, Arbitrary b) => Arbitrary (Sum a b) where
  arbitrary = do
    a <- arbitrary
    b <- arbitrary
    elements [First a, Second b]

instance (Eq a, Eq b) => EqProp (Sum a b) where
  (=-=) = eq

  -- same as Sum/Either
instance Functor (Validation e) where
  fmap _ (Error a) = Error a
  fmap f (Example.Success b) = Example.Success (f b)

instance Monoid a => Applicative (Validation a) where
  pure = Example.Success
  Error a <*> Error a' = Error (a `mappend` a')
  _ <*> Error a = Error a
  Error a <*> _ = Error a
  Example.Success f <*> Example.Success b = Example.Success (f b)


instance (Arbitrary e, Arbitrary a) => Arbitrary (Validation e a) where
  arbitrary = do
    e <- arbitrary
    a <- arbitrary
    elements [Error e, Example.Success a]

instance (Eq e, Eq a) => EqProp (Validation e a) where
  (=-=) = eq

main :: IO ()
main = do
  let trigger = undefined :: Sum () (Int, String, Int)
  quickBatch $ functor trigger
  quickBatch $ applicative trigger

  let triggerVal = undefined :: Validation () (Int, String, Int)
  quickBatch $ functor triggerVal
  quickBatch $ applicative triggerVal