-- ignore these imports: we need them to use some standard-library monads and such
-- (your homework needs no such imports)
import Control.Monad (liftM, ap) 
import Control.Monad.State

-- Throughout this file, we will often give fields and functions 
-- primed names (foo') because our examples otherwise name-clash with 
-- various things in the standard Prelude.

-- PART 1
-- These are examples of "life without type classes", all subsumed by
-- Haskell's standard library of type classes.
-- In other words, "don't do it this way" in Haskell but it /explains/ Haskell's
-- dictionary-passing semantics/implementation of type classes

member :: (a -> a -> Bool)-> [a] -> a -> Bool
member eqFun []     v = False
member eqFun (x:xs) v = eqFun x v || member eqFun xs v

data NumberOps a  = NumberOps { plus  :: a -> a -> a
                              , times :: a -> a -> a
                              , neg   :: a -> a
                              , zero  :: a
                              } 
intDict :: NumberOps Int
intDict = NumberOps { plus  = (+)
                    , times = (*)
                    , neg   = \ x -> -1 * x
                    , zero  = 0
                    }

floatDict :: NumberOps Float -- only looks like intDict b/c +, *, etc. already overloaded
floatDict = NumberOps { plus  = (+)
                      , times = (*)
                      , neg   = \ x -> -1.0 * x
                      , zero  = 0.0
                      }

data Complex a = Complex { real :: a
                         , imag :: a
                         }
   
-- Note: given record field (e.g., real or plus), we get an accessor function 
-- (e.g., real :: Complex a -> a or plus :: NumberOps a -> a -> a -> a)

complexDictMaker :: NumberOps a -> NumberOps (Complex a)
complexDictMaker d = 
  NumberOps { plus  = \c1 c2 -> Complex { real = (plus d) (real c1) (real c2)
                                        , imag = (plus d) (imag c1) (imag c2)
                                        }
            , times = \c1 c2 -> let 
                                  (r1,i1,r2,i2) = (real c1, imag c1, real c2, imag c2)
                                  (p,t,n)       = (plus d, times d, neg d)
                                in
                                Complex { real = p (t r1 r2) (n (t i1 i2)) 
                                        , imag = p (t r1 i2) (t r2 i1) 
                                        }
            , neg   = \c -> Complex { real = (neg d) (real c)
                                    , imag = (neg d) (imag c)
                                    }
            , zero = Complex { real = zero d
                             , imag = zero d
                             } 
            }

complexIntDict :: NumberOps (Complex Int)
complexIntDict = complexDictMaker intDict

complexFloatDict :: NumberOps (Complex Float)
complexFloatDict = complexDictMaker floatDict

double :: NumberOps a -> a -> a
double d v = plus d v v

sumOfSquares :: NumberOps a -> [a] -> a
sumOfSquares d [] = zero d
sumOfSquares d (x:xs) = (plus d) (times d x x) (sumOfSquares d xs)

sixtyFour = double intDict 32

fourteenAndEighteen = 
     let c = double complexIntDict (Complex{real=7,imag=9})
     in (real c, imag c)

fortyTwo = double (intDict { plus = \x y -> 42}) 32 -- record-update syntax

-- PART 2
-- now doing this the typeclass way  but not using Haskell's pre-defined type-class 
-- for Num a because it's rather complicated for Complex and has special support 
-- for numeric literals which makes it seem "too magical" pedagogically

-- using primed function names here just to avoid name clashes in one file
-- (multiple modules would be better but trying not to confuse issues)

-- Eq is a type-class defined in the standard library with (==) :: a -> a -> Bool
member' :: Eq a => [a] -> a -> Bool
member' []     v = False
member' (x:xs) v = (==) x v || member' xs v

-- Ord and Show provide min and show respectively
stringOfMin :: (Ord a, Show a) => [a] -> String
stringOfMin  = show . f 
  where f [] = error "none"
        f [x] = x
        f (x:xs) = min x (f xs)

-- now let's define our own typeclass
class MyNum a where
   plus'  :: a -> a -> a
   times' :: a -> a -> a
   neg'   :: a -> a
   zero'  :: a

instance MyNum Int where
   plus'  = (+)
   times' = (*)
   neg'   = \x -> -1 * x
   zero'  = 0

instance MyNum Float where
   plus'  = (+)
   times' = (*)
   neg'   = \x -> -1.0 * x
   zero'  = 0.0

instance MyNum a => MyNum (Complex a) where
   plus'  = \c1 c2 -> Complex { real = plus' (real c1) (real c2)
                              , imag = plus' (imag c1) (imag c2)
                              }
   times' = \c1 c2 -> let 
                         (r1,i1,r2,i2) = (real c1,imag c1,real c2,imag c2)
                      in
                         Complex { real = plus' (times' r1 r2) (neg' (times' i1 i2)) 
                                 , imag = plus' (times' r1 i2) (times' r2 i1) 
                                 }
   neg'   = \ c -> Complex { real = neg' (real c)
                           , imag = neg' (imag c)
                           }
   zero'  = Complex { real = zero'
                    , imag = zero'
                    } 

double' :: MyNum a => a -> a
double' v = (plus' (plus' v v) zero')

sumOfSquares' :: MyNum a => [a] -> a
sumOfSquares' [] = zero' 
sumOfSquares' (x:xs) = plus' (times' x x) (sumOfSquares' xs)

sixtyFour' :: Int -- avoids ambiguity b/c 32 is overloaded
sixtyFour' = double' 32

fourteenAndEighteen' :: (Int,Int) -- avoids ambiguity b/c 7 and 9 are overloaded
fourteenAndEighteen' = 
     let c = double' (Complex{real=7,imag=9})
     in (real c, imag c)

data FunnyInt = FunnyInt Int
instance MyNum FunnyInt where
   plus'  = \ _ _ -> FunnyInt 42 -- !!!
   times' = \ (FunnyInt x) (FunnyInt y) -> FunnyInt (times' x y)
   neg'   = \ (FunnyInt x) -> FunnyInt (neg' x)
   zero'  = FunnyInt 30 -- !!!

FunnyInt fortyTwo' = double' (FunnyInt 32)

-- PART 3
-- and now let's see that typeclasses can work on type /constructors/ 
-- (not used here: the standard-library typeclass for map-like stuff is Functor)

class HasMap g where
   map' :: (a -> b) -> g a -> g b

instance HasMap [] where
   map' = map

data Tree a = Leaf  | Node a (Tree a) (Tree a)

instance HasMap Tree where
   map' _ Leaf = Leaf
   map' f (Node v l r) = Node (f v) (map' f l) (map' f r)

doubleAll :: (MyNum a, HasMap c) => c a -> c a
doubleAll = map' (\x -> plus' x x)

x1 :: [Int]
x2 :: Tree Int
x3 :: [Int]

x1 = doubleAll [3,4,5]
x2 = doubleAll (Node 3 (Node 4 Leaf Leaf) (Node 5 Leaf Leaf))
x3 = map' (\ (FunnyInt x) -> x) (doubleAll (map' FunnyInt [7, 9, 11]))

-- PART 4
-- and now let's see that Monad is another typeclass over a type /constructor/
-- and any instance of Monad can use do-notation for its implementation of >>= 
-- etc. (and >> has a default implementation in terms of >>=)

{- from the standard library:
class Monad m where
   >>= :: m a -> (a -> m b) -> m b
   return :: a -> m a

standard library also defines a Maybe monad and a State monad as instances,
but we can just as well define them ourselves and define our own monads...

[alas, more recent versions of Haskell got a bit carried away with
class constraints, so we also have to make each Monad a Functor and
an Applicative, which I don't want to talk about, so I've squirreled
away some magic incantations at the bottom of the file] 
-}

data Maybe' a = Just' a | Nothing'
    deriving Show

instance Monad Maybe' where
   return = Just'
   Nothing'  >>= f = Nothing'
   (Just' x) >>= f = f x

seventeen :: Maybe' Int
seventeen = do x <- return 9
               y <- if True then return (x * 2) else Nothing'
               z <- return (x + y - 10)
               return (z * 1)

nada :: Maybe' Int
nada      = do x <- return 9
               y <- if False then return (x * 2) else Nothing'
               z <- return (x + y - 10)
               return (z * 1)

-- compare to the non-monad, non-do way:
alsoSeventeen = let x = Just' 9
                    y = if True 
                        then case x of 
                                Nothing' -> Nothing'
                                Just' j  -> Just' (j * 2)
                        else Nothing'  
                    z = case (x,y) of
                           (Nothing', _) -> Nothing'
                           (_, Nothing') -> Nothing'
                           (Just' j1, Just' j2) -> Just' (j1 + j2 - 10)
                  in case z of 
                        Nothing' -> Nothing'
                        Just' j -> Just' (j * 1)

-- PART 5
-- next wizardry: we defined sequence last time for the IO monad, but it works fine
-- for /any/ monad (!!)

sequence' :: Monad m => [m a] -> m [a]
sequence' xs = 
   case xs of
     [] -> return []
     y:ys -> do { r  <- y;
                  rs <- sequence' ys;
                  return (r:rs) }

-- note: s1 :: IO [()] and/but ghci "runs" IO actions at its top-level, so you see
-- "what happens" when you "run" a program whose main = s1, rather than the "action"
-- waiting to be run
s1 = sequence' [print "A", print "B", print "hooray", print 34]

s2 = sequence' [Just' "A", Just' "B", Just' "hooray"]
s3 = sequence' [Just' "A", Nothing', Just' "hooray"]

-- PART 6
-- last: the state monad
-- the state monad is a little funky to define: super fun but more than
-- I want to mess with, so let's just use the one from the standard library...
-- State is a two-argument type constructor:
--   * State s a describes an action that given a 'state' s produces an s' and 
--     produces an a
--   * E.g., if we wanted the state to be a single counter, we could have State Int a
--   * State s (partial application to one argument (!)) is an instance of Monad (!!)
--      * return :: a -> State s a produces an action that doesn't change state
--      * >>= :: State s a -> (a -> State s b) -> State s b produces an action
--          that sequences the state transforms
--   * other useful operations:
--      * get :: State s s is an action doesn't change state and produces the state
--      * put :: s -> State s () produces an action that changes state to arg
--      * evalState :: State s a -> s -> a "does it"
--   * not shown: entire implementation is purely functional -- "threading through"
--      the "state" "correctly"

incr :: State Int ()
incr = get >>= \c -> put (c+1) 

withCounter :: State Int a -> a
withCounter action = evalState action 0

five :: Int
five = withCounter (do { x <- return 2;
                         incr; 
                         y <- get; 
                         incr;
                         z <- get;
                         return (x + y + z) }) 
         
-- and our sequence' function "works" for the State monad too:

myStateAction :: State Int Int
myStateAction = get >>= \i -> put (i+i) >> return (min i 40)

s4 :: State Int [Int]
s4 = sequence' [myStateAction, myStateAction, myStateAction, myStateAction]

s5 :: [Int]
s5 = evalState s4 16

--  as promised, ignore this gunk :)

instance Functor Maybe' where
    fmap = liftM
instance Applicative Maybe' where 
    pure = return
    (<*>) = ap