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 e => Applicative (Validation e) 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


newtype Identity a = Identity a deriving (Eq, Show)

instance Functor Identity where
  fmap f (Identity a) = Identity (f a)

instance Applicative Identity where
  pure = Identity
  Identity f <*> Identity a = Identity (f a)

instance Arbitrary a => Arbitrary (Identity a) where
  arbitrary = do
    a <- arbitrary
    return $ Identity a

instance (Eq a) => EqProp (Identity a) where
  (=-=) = eq


data Pair a = Pair a a deriving (Eq, Show)

instance Functor Pair where
  fmap f (Pair a a') = Pair (f a) (f a')

instance Applicative Pair where
  pure a = Pair a a
  Pair f f' <*> Pair a a' = Pair (f a) (f' a')

instance Arbitrary a => Arbitrary (Pair a) where
  arbitrary = do
    a <- arbitrary
    a' <- arbitrary
    return $ Pair a a'

instance (Eq a) => EqProp (Pair a) where
  (=-=) = eq


data Two a b = Two a b deriving (Eq, Show)

instance Functor (Two a) where
  fmap f (Two a b)  = Two a (f b)


instance (Monoid a) => Applicative (Two a) where
  pure b = Two mempty b
  Two f f' <*> Two a a' = Two (f `mappend` a) (f' a')


instance (Arbitrary a, Arbitrary b) => Arbitrary (Two a b) where
  arbitrary = do
    a <- arbitrary
    b <- arbitrary
    return $ Two a b

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

data Three a b c = Three a b c deriving (Eq, Show)

instance Functor (Three a b) where
  fmap f (Three a b c) = Three a b (f c)

instance (Monoid a, Monoid b) => Applicative (Three a b) where
  pure = Three mempty mempty
  Three a b f <*> Three a' b' c = Three (a `mappend` a') (b `mappend` b') (f c)

instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (Three a b c) where
  arbitrary = do
    a <- arbitrary
    b <- arbitrary
    c <- arbitrary
    return $ Three a b c

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

data Three' a b = Three' a b b deriving (Eq, Show)

instance Functor (Three' a) where
  fmap f (Three' a b b') = Three' a (f b) (f b')

instance Monoid a => Applicative (Three' a) where
  pure b = Three' mempty b b
  Three' a b f <*> Three' a' b' c = Three' (a `mappend` a') (b b') (f c)

instance (Arbitrary a, Arbitrary b) => Arbitrary (Three' a b) where
  arbitrary = do
    a <- arbitrary
    b <- arbitrary
    return $ Three' a b b

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

data Four a b c d = Four a b c d deriving (Eq, Show)

instance Functor (Four a b c) where
  fmap f (Four a b c d) = Four a b c (f d)

instance (Monoid a, Monoid b, Monoid c) =>Applicative (Four a b c) where
  pure = Four mempty mempty mempty
  (Four a b c f) <*> (Four a' b' c' d) = Four (mappend a a') (mappend b b') (mappend c c') (f d)

instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (Four a b c d) where
  arbitrary = do
    a <- arbitrary
    b <- arbitrary
    c <- arbitrary
    d <- arbitrary
    return $ Four a b c d

instance (Eq a, Eq b, Eq c, Eq d) => EqProp (Four a b c d) where
  (=-=) = eq

data Four' a b = Four' a a a b deriving (Eq, Show)

instance Functor (Four' a) where
  fmap f (Four' a a' a'' b) = Four' a a' a'' (f b)

instance Monoid a => Applicative (Four' a) where
  pure = Four' mempty mempty mempty
  Four' a a' a'' f <*> Four' b b' b'' c = Four' (mappend a b) (mappend a' b') (mappend a'' b'') (f c)

instance (Arbitrary a, Arbitrary b) => Arbitrary (Four' a b) where
  arbitrary = do
    a <- arbitrary
    b <- arbitrary
    return $ Four' a a a b

instance (Eq a, Eq b) => EqProp (Four' a b) 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

  let triggerIdentity = undefined :: Identity (Int, String, Int)
  quickBatch $ functor triggerIdentity
  quickBatch $ applicative triggerIdentity

  let triggerPair = undefined :: Pair (Int, String, Int)
  quickBatch $ functor triggerPair
  quickBatch $ applicative triggerPair

  let triggerTwo = undefined :: Two [Int] (Int, String, Int)
  quickBatch $ functor triggerTwo
  quickBatch $ applicative triggerTwo

  let triggerThree = undefined :: Three [Int] [Int] (Int, String, Int)
  quickBatch $ functor triggerThree
  quickBatch $ applicative triggerThree

  let triggerThree' = undefined :: Three' [Int] (Int, String, Int)
  quickBatch $ functor triggerThree'
  quickBatch $ applicative triggerThree'

  let triggerFour = undefined :: Four [Int] [Int] [Int] (Int, String, Int)
  quickBatch $ functor triggerFour
  quickBatch $ applicative triggerFour

  let triggerFour' = undefined :: Four' [Int] (Int, String, Int)
  quickBatch $ functor triggerFour'
  quickBatch $ applicative triggerFour'