-- | Examples of type classes and overloading
-- Functional Programming course 2017.
-- Thomas Hallgren

{-
This started as a skeleton, the definitions were filled in
during the lecture. Some of the definitions were filled in
after the lecture.
-}

module Overloading where

--------------------------------------------------------------------------------
-- * Defining your own Eq instances

data TrafficLight = Red | Yellow | Green deriving (Show,Enum,Bounded)

instance Eq TrafficLight where
  Red    == Red    = True
  Yellow == Yellow = True
  Green  == Green  = True
  _      == _      = False


-------------------------------------------------------------------------------
-- * The Bounded class

-- | If a type is in both Bounded and Enum,
-- it's easy to enumerate all the values in the type
enumAll :: (Bounded a,Enum a) => [a]
enumAll = [minBound .. maxBound]


--------------------------------------------------------------------------------
-- * Writing your own Show instances

-- | Every card has a suit  ♠ ♥ ♦ ♣
data Suit = Spades | Hearts | Diamonds | Clubs
            deriving (Eq,Enum)


instance Show Suit where
  show Spades   = "♠"
  show Hearts   = "♥"
  show Diamonds = "♦"
  show Clubs    = "♣"


-- | ANSI color escape sequences
red = "\ESC[31m"
normal = "\ESC[m"


-- | Cards have ranks: 2, 3 .. 10, J, Q, K, A
data Rank = Numeric Int | Jack | Queen | King | Ace
            deriving (Eq,Ord)

all_ranks = [Numeric n|n<-[2..10]]++[Jack,Queen,King,Ace]

rankBeats :: Rank -> Rank -> Bool
rankBeats r1 r2 = r1>r2


instance Show Rank where
  show (Numeric n) = show n
  show Jack  = "J"
  show Queen = "Q"
  show King  = "K"
  show Ace   = "A"


-- | A Card has a Rank and a Suit
data Card = Card {rank::Rank, suit::Suit}
            deriving (Eq)

cardBeats :: Card -> Card -> Bool
cardBeats (Card r1 s1) (Card r2 s2) = s1==s2 && rankBeats r1 r2

example_card_1 = Card King Clubs
example_card_2 = Card {rank=Ace, suit=Spades}

instance Show Card where
  show (Card r s) = show r ++ show s



-- | A hand contains zero or more cards
data Hand = Empty | Add Card Hand --deriving Show

example_hand_0 = Empty

example_hand_1 = Add example_card_1 Empty

example_hand_2 = Add example_card_2 example_hand_1

example_hand_3 = Add (Card (Numeric 5) Hearts) example_hand_2

instance Show Hand where
  show Empty = "."
  show (Add c h) = show c ++ " " ++ show h


--------------------------------------------------------------------------------
-- * Defining your own class

-- | The class of "small" types, e.g. types for which we can enumerate
-- all values
class Small a where values :: [a]


--------------------------------------------------------------------------------
-- * Small instances

instance Small ()  where values = [()]
instance Small Bool where values = [False, True]
instance Small Char where values = enumAll
--instance Small Int -- too big to be considered small


-- | We consider pairs of small types to be small too
instance (Small a,Small b) => Small (a,b) where
  values = [(x,y)|x<-values,y<-values]


instance Small Suit where values = [Spades, Hearts, Diamonds, Clubs]
instance Small Rank where values = all_ranks
instance Small Card where values = [Card r s | s<-values, r<-values]


--------------------------------------------------------------------------------
-- * A function for exhaustive testing properties with one small argument

smallCheck1 :: Small a => (a->Bool) -> Bool
--smallCheck1 p = and [p x|x<-values]
smallCheck1 p = all p values


--------------------------------------------------------------------------------
-- * Properties that can be tested exhaustively

-- | There is no card that can beat an Ace
prop_Ace c = not (c `cardBeats` Card Ace Spades)

-- | Any face card beats any numeric card of the same suit
prop_Face fc nc = (isFace fc && isNumeric nc && suit fc==suit nc)
                   ==> (fc `cardBeats` nc)

isFace c = rank c>=Jack
isNumeric c = rank c<Jack


-- | Logical implication
infixr 0 ==>
h ==> c = not h || c

test1 = smallCheck1 prop_Ace
--test2 = smallCheck1 prop_Face -- type error becase prop_Face has 2 arguments

--------------------------------------------------------------------------------
-- * The class for exhaustive test of properties with zero or more
-- "small" arguments

-- | The class of properties that can be tested exhaustively
class SmallCheck prop where
  smallCheck :: prop -> Bool


-- | Bool is testable (base case)
instance SmallCheck Bool where
  smallCheck b = b

-- | Functions with any number of small arguments are testable (inductive step)
instance (Small a,SmallCheck prop) => SmallCheck (a->prop) where
  smallCheck p = and [smallCheck (p x)|x<-values]


test1b = smallCheck prop_Ace
test2b = smallCheck prop_Face

--------------------------------------------------------------------------------
-- * Ambiguity and defaulting

--f s = show (read s)         -- defaulting does not kick in,
                              -- rejected as ambiguous

g s = show (10+read s)        -- with Num constraints, defaulting kicks in


--Defaulting, monomorphism restriction
answer1 = 6*7  -- defaulting kicks in Integer is chosen

-- Avoiding the defaulting caused by the monomorphism restriction
answer2 :: Num a => a
answer2 = 6*7

-- Note: for expressions entered directly in GHCi, there is extended defaulting
-- and the monomorphism restriction is not applied, but there are settings
-- in GHCi to changes this.