Monad for Functional Programming

monad.hs

module Lib where

import           Control.Arrow (first)

data Term = Con Int | Div Term Term deriving Show

eval :: Term -> Int
eval (Con a)   = a
eval (Div t u) = eval t `div` eval u

answer, error :: Term
answer = Div (Div (Con 1972) (Con 2)) (Con 23)
error = Div (Con 1) (Con 0)

-- Variation one: Exceptions
-- data M a = Raise Exception | Return a deriving Show
-- type Exception = String

-- eval' :: Term -> M Int
-- eval' (Con a) = Return a
-- eval' (Div t u) = case eval' t of
--                    Raise e -> Raise e
--                    Return a ->
--                     case eval' u of
--                         Raise e -> Raise e
--                         Return b ->
--                             if b == 0
--                                 then Raise "divide by zero"
--                                 else Return (a `div` b)

-- Variation two: State
-- type M a   = State -> (a, State)
-- type State = Int

-- eval'             :: Term -> M Int
-- eval' (Con a) x   = (a, x)
-- eval' (Div t u) x = let (a, y) = eval' t x in
--                     let (b, z) = eval' u y in
--                         (a `div` b, z + 1)
-- eval' answer 0

-- Variation three: Output
-- type M a    = (Output, a)
-- type Output = String

-- line :: Term -> Int -> Output
-- line t a = "eval (" ++ show t ++ ") <= " ++ show a ++ "\n"

-- eval' :: Term -> M Int
-- eval' (Con a) = (line (Con a) a, a)
-- eval' (Div t u) = let (x, a) = eval' t in
--                   let (y, b) = eval' u in
--                     (line (Div t u) (a `div` b) ++ y ++ x, a `div` b)


newtype Identity a = Identity {runIdentity :: a}

instance Functor Identity where
  fmap f  = Identity . f . runIdentity

instance Applicative Identity where
  pure = Identity
  f <*> g = Identity $ runIdentity f (runIdentity g)

instance Monad Identity where
  ma >>= mf = mf $ runIdentity ma

evalMonad :: (Monad m) => Term -> m Int
evalMonad (Con a)   = return a
evalMonad (Div t u) = do
  a <- evalMonad t
  b <- evalMonad u
  return (a `div` b)


evalIdentity :: Term -> Identity Int
evalIdentity = evalMonad

type Exception = String
data MException a = Raise Exception | Return a deriving Show

instance Functor MException where
    fmap _ (Raise e)  = Raise e
    fmap f (Return a) = Return $ f a

instance Applicative MException where
  pure = Return
  (<*>) (Raise e) _ = Raise e
  (<*>) _ (Raise e) = Raise e
  (Return f) <*> (Return a) = Return $ f a

instance Monad MException where
  (Raise e) >>= _ = Raise e
  (Return a) >>= mf = mf a


evalException :: Term -> MException Int
evalException (Con a) = evalMonad (Con a)
evalException (Div t u) = case evalException u of
                            Return 0 -> Raise "divide by zero"
                            _        -> evalMonad (Div t u)



newtype MState a = MState {runState :: State -> (a, State)}
type State = Int

instance Functor MState where
  fmap f (MState k) = MState (\ s -> let (a, t) = k s in (f a, t) )

instance Applicative MState where
  pure a = MState (\ s -> (a, s))
  (MState f) <*> (MState g) = MState (\ s -> let (a, t) = f s
                                                 (b, u) = g t
                                              in (a b, u))

instance Monad MState where
  (MState ma) >>= mf= MState (\ s -> let (x, t) = ma s
                                         in runState (mf x) t)
tick :: MState ()
tick = MState (\ s -> ((), s + 1))

evalState :: Term -> MState Int
evalState (Con a)   = return a
evalState (Div t u) = do
  a <- evalState t
  b <- evalState u
  tick >>= (\_ -> return (a `div` b))
-- print $ runState (evalState Lib.answer) 0


newtype MOutout a = MOutout {getOutput :: (Output, a)}
type Output = String

instance Functor MOutout where
  fmap f (MOutout g) = let (o, a) = g in MOutout(o, f a)

instance Applicative MOutout where
  pure a = MOutout ("", a)
  MOutout (x, f) <*> MOutout (y , a) = MOutout (x ++ y, f a)

instance Monad MOutout where
  MOutout (x, a) >>= mf = let (y, b)  = getOutput (mf a) in MOutout (x ++ y, b)

out :: Output -> MOutout ()
out x = MOutout (x, ())

line :: Term -> Int -> Output
line t a = "eval (" ++ show t ++ ") <= " ++ show a ++ "\n"


evalOutput :: Term -> MOutout Int
evalOutput (Con a)   = out (line (Con a) a) >>= (\_ -> return a)
evalOutput (Div t u) = do
  a <- evalOutput t
  b <- evalOutput u
  out (line (Div t u) (a `div` b)) >>= (\_ -> return (a `div` b))
-- putStrLn . fst . getOutput . evalOutput) Lib.answer