ch17.hs

{-# LANGUAGE InstanceSigs #-}

import Data.Monoid
import Control.Applicative hiding (ZipList)
import Test.QuickCheck
import Test.QuickCheck.Checkers
import Test.QuickCheck.Classes

-- Identity

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

instance Functor Identity where
  fmap :: (a -> b) -> Identity a -> Identity b
  fmap = undefined

instance Applicative Identity where
  pure :: a -> Identity a
  pure = undefined
  
  (<*>) :: Identity (a -> b) -> Identity a -> Identity b
  (<*>) = undefined

-- Constant

newtype Constant a b = Constant { getConstant :: a }
  deriving (Eq, Show)

instance Functor (Constant a) where
  fmap :: (b -> c) -> Constant a b -> Constant a c
  fmap = undefined

instance Monoid m => Applicative (Constant m) where
  pure :: b -> Constant m b
  pure = undefined

  (<*>) :: Constant m (a -> b) -> Constant m a -> Constant m b
  (<*>) = undefined

-- List

data List a =
    Nil
  | Cons a (List a)
  deriving (Eq, Show)

instance Monoid (List a) where
  mempty :: List a
  mempty = undefined

  mappend :: List a -> List a -> List a
  mappend = undefined

instance Functor List where
  fmap :: (a -> b) -> List a -> List b
  fmap = undefined

instance Applicative List where
  pure :: a -> List a
  pure = undefined

  (<*>) :: List (a -> b) -> List a -> List b
  (<*>) = undefined

-- ZipList

newtype ZipList a = ZipList (List a)
  deriving (Eq, Show)

instance Monoid a => Monoid (ZipList a) where
  mempty :: ZipList a
  mempty = undefined

  mappend :: ZipList a -> ZipList a -> ZipList a
  mappend = undefined

instance Functor ZipList where
  fmap :: (a -> b) -> ZipList a -> ZipList b
  fmap = undefined

instance Applicative ZipList where
  pure :: a -> ZipList a
  pure = undefined

  (<*>) :: ZipList (a -> b) -> ZipList a -> ZipList b
  (<*>) = undefined

-- Validation

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

instance Functor (Validation e) where
  fmap :: (a -> b) -> Validation e a -> Validation e b
  fmap = undefined

instance Monoid e => Applicative (Validation e) where
  pure ::  a -> Validation e a
  pure = undefined

  (<*>) :: Validation e (a -> b) -> Validation e a -> Validation e b
  (<*>) = undefined

-- Pair

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

instance Functor Pair where
  fmap :: (a -> b) -> Pair a -> Pair b
  fmap = undefined

instance Applicative Pair where
  pure :: a -> Pair a
  pure = undefined

  (<*>) :: Pair (a -> b) -> Pair a -> Pair b
  (<*>) = undefined

-- Two

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

instance (Monoid a, Monoid b) => Monoid (Two a b) where
  mempty :: Two a b
  mempty = undefined

  mappend :: Two a b -> Two a b -> Two a b
  mappend = undefined

instance Functor (Two a) where
  fmap :: (b -> c) -> Two a b -> Two a c
  fmap = undefined

instance Monoid a => Applicative (Two a) where
  pure :: b -> Two a b
  pure = undefined

  (<*>) :: Two a (b -> c) -> Two a b -> Two a c
  (<*>) = undefined

-- Three

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

instance (Monoid a, Monoid b, Monoid c) => Monoid (Three a b c) where
  mempty :: Three a b c
  mempty = Three mempty mempty mempty

  mappend :: Three a b c -> Three a b c -> Three a b c
  mappend = undefined

instance Functor (Three a b) where
  fmap :: (c -> d) -> Three a b c -> Three a b d
  fmap = undefined

instance (Monoid a, Monoid b) => Applicative (Three a b) where
  pure :: c -> Three a b c
  pure = undefined

  (<*>) :: Three a b (c -> d) -> Three a b c -> Three a b d
  (<*>) = undefined

-- Three'

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

instance (Monoid a, Monoid b) => Monoid (Three' a b) where
  mempty :: Three' a b
  mempty = Three' mempty mempty mempty

  mappend :: Three' a b -> Three' a b -> Three' a b
  mappend = undefined

instance Functor (Three' a) where
  fmap :: (b -> c) -> Three' a b -> Three' a c
  fmap = undefined

instance Monoid a => Applicative (Three' a) where
  pure :: b -> Three' a b
  pure = undefined

  (<*>) :: Three' a (b -> c) -> Three' a b -> Three' a c
  (<*>) = undefined

-- Four

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

instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (Four a b c d) where
  mempty :: Four a b c d
  mempty = undefined

  mappend :: Four a b c d -> Four a b c d -> Four a b c d
  mappend = undefined

instance Functor (Four a b c) where
  fmap :: (d -> e) -> Four a b c d -> Four a b c e
  fmap = undefined

instance (Monoid a, Monoid b, Monoid c) => Applicative (Four a b c) where
  pure :: d -> Four a b c d
  pure = undefined

  (<*>) :: Four a b c (d -> e) -> Four a b c d -> Four a b c e
  (<*>) = undefined

-- Four'

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

instance (Monoid a, Monoid b) => Monoid (Four' a b) where
  mempty :: Four' a b
  mempty = undefined

  mappend :: Four' a b -> Four' a b -> Four' a b
  mappend = undefined

instance Functor (Four' a) where
  fmap :: (b -> c) -> Four' a b -> Four' a c
  fmap = undefined

instance Monoid a => Applicative (Four' a) where
  pure :: b -> Four' a b
  pure = undefined

  (<*>) :: Four' a (b -> c) -> Four' a b -> Four' a c
  (<*>) = undefined

-- Tests

type SSI = (String, String, Sum Int)

take' :: Int -> List a -> List a
take' _ Nil = Nil
take' 0 xs = Nil
take' n (Cons x xs) = Cons x (take' (n - 1) xs)

instance Arbitrary a => Arbitrary (List a) where
  arbitrary = do
    a <- arbitrary
    b <- arbitrary
    frequency [(1, return Nil),
               (2, return $ Cons a (Cons b Nil)),
               (3, return $ Cons a Nil)]

instance Eq a => EqProp (List a) where
  xs =-= ys = xs' `eq` ys'
    where xs' = let l = xs
                in take' 3000 l
          ys' = let l = ys
                in take' 3000 l

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

instance Eq a => EqProp (ZipList a) where
  xs =-= ys = xs' `eq` ys'
    where xs' = let (ZipList l) = xs
                in take' 3000 l
          ys' = let (ZipList l) = ys
                in take' 3000 l

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

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

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

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

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

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

listTrigger = undefined :: List (String, Int, Int)
zipListTrigger = undefined :: ZipList (String, Int, Int)
pairTrigger = undefined :: Pair (String, String, Int)
twoTrigger = undefined :: Two SSI SSI
threeTrigger = undefined :: Three SSI SSI SSI
threeTrigger' = undefined :: Three' SSI SSI
fourTrigger = undefined :: Four SSI SSI SSI SSI
fourTrigger' = undefined :: Four' SSI SSI

testList = quickBatch $ applicative listTrigger
testZipList = quickBatch $ applicative zipListTrigger
testPair = quickBatch $ applicative pairTrigger
testTwo = quickBatch $ applicative twoTrigger
testThree = quickBatch $ applicative threeTrigger
testThree' = quickBatch $ applicative threeTrigger'
testFour = quickBatch $ applicative fourTrigger
testFour' = quickBatch $ applicative fourTrigger'