
module Apl3 where

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

-- 1. Identity

newtype Identity a = Identity a deriving (Show, Eq)
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 = genId
genId :: Arbitrary a => Gen (Identity a)
genId = do
  a <- arbitrary
  return $ Identity a

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

-- 2. Pair

data Pair a = Pair a a deriving (Show, Eq)
instance Functor Pair where
  fmap f (Pair a a') = Pair (f a) (f a')
instance Applicative Pair where
  pure x = Pair x x
  Pair f f' <*> Pair x x' = Pair (f x) (f' x')
instance Arbitrary a => Arbitrary (Pair a) where
  arbitrary = genPair
genPair :: Arbitrary a => Gen (Pair a)
genPair = do
  a  <- arbitrary
  a' <- arbitrary
  return $ Pair a a'
instance Eq a => EqProp (Pair a) where
  (=-=) = eq

-- 3. Two
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 = Two mempty
  Two m f <*> Two m' x = Two (m <> m') (f x)
instance (Arbitrary a, Arbitrary b) => Arbitrary (Two a b) where
  arbitrary = genTwo
genTwo :: (Arbitrary a, Arbitrary b) => Gen (Two a b)
genTwo = do
  a <- arbitrary
  b <- arbitrary
  return $ Two a b
instance (Eq a, Eq b) => EqProp (Two a b) where
  (=-=) = eq

-- 4. Three
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' x = Three (a <> a') (b <> b') (f x)
instance (Arbitrary a, Arbitrary b, Arbitrary c)
    => Arbitrary (Three a b c) where
  arbitrary = genThree
genThree :: (Arbitrary a, Arbitrary b, Arbitrary c)
            => Gen (Three a b c)
genThree = 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

-- 5. Three'
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 x = Three' mempty x x
  Three' m f f' <*> Three' m' x x' = Three' (m <> m') (f x) (f' x')
instance (Arbitrary a, Arbitrary b) => Arbitrary (Three' a b) where
  arbitrary = genThree'
genThree' :: (Arbitrary a, Arbitrary b) => Gen (Three' a b)
genThree' = do
  a  <- arbitrary
  b  <- arbitrary
  b' <- arbitrary
  return $ Three' a b b'
instance (Eq a, Eq b) => EqProp (Three' a b) where
  (=-=) = eq

-- 6. Four
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 ma mb mc f <*> Four ma' mb' mc' x =
    Four (ma <> ma') (mb <> mb') (mc <> mc') (f x)
instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
    => Arbitrary (Four a b c d) where
  arbitrary = genFour
genFour :: (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
           => Gen (Four a b c d)
genFour = 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

-- 7. Four'

data Four' a b = Four' a a a b deriving (Eq, Show)
instance Functor (Four' a) where
  fmap f (Four' a b c d) = Four' a b c (f d)
instance Monoid a => Applicative (Four' a) where
  pure = Four' mempty mempty mempty
  Four' ma mb mc f <*> Four' ma' mb' mc' x =
    Four' (ma <> ma') (mb <> mb') (mc <> mc') (f x)
instance (Arbitrary a, Arbitrary b) => Arbitrary (Four' a b) where
  arbitrary = genFour'
genFour' :: (Arbitrary a, Arbitrary b) => Gen (Four' a b)
genFour' = do
  a <- arbitrary
  b <- arbitrary
  c <- arbitrary
  d <- arbitrary
  return $ Four' a b c d
instance (Eq a, Eq b) => EqProp (Four' a b) where
  (=-=) = eq

-- Test it

type S = String
type I = Int

main :: IO ()
main = do
  putStr "\n-- Identity"
  quickBatch (applicative (undefined :: Identity (I, I, I)))
  putStr "\n-- Pair"
  quickBatch (applicative (undefined :: Pair (I, I, I)))
  putStr "\n-- Two"
  quickBatch (applicative (undefined :: Two (S, S, S) (I, I, I)))
  putStr "\n-- Three"
  quickBatch (applicative (undefined ::
                              Three (S, S, S) (S, S, S) (I, I, I)))
  putStr "\n-- Three'"
  quickBatch (applicative (undefined ::
                              Three' (S, S, S) (I, I, I)))
  putStr "\n-- Four"
  quickBatch (applicative (undefined ::
                              Four (S, S, S)
                                   (S, S, S)
                                   (S, S, S)
                                   (I, I, I)))
  putStr "\n-- Four'"
  quickBatch (applicative (undefined ::
                              Four' (S, S, S)
                                    (I, I, I)))

-- Combinations

stops, vowels :: String
stops = "pbtdkg"
vowels = "aeiou"

combos :: [a] -> [b] -> [c] -> [(a, b, c)]
combos = liftA3 (,,)
