-- | MonadicEvaluators
-- Exercises with expressions and monads
-- Functional Programming course 2017.
-- Thomas Hallgren

{-
We started working on this on Monday in Week 5, and filled in the rest
on Thursday in Week 5.
-}
--------------------------------------------------------------------------------

module MonadicEvaluators where
import Data.Char(isDigit,isLetter)
import Data.List(union)
import Control.Monad(ap,liftM)
import Parsing

-- | A Haskell data type for arithmetic expressions with variables and division
data Expr = Num Integer
          | Var Name           -- new
          | Add Expr Expr
          | Mul Expr Expr
          | Div Expr Expr      -- new
          deriving (Eq)

type Name = String

ex1 = Num 2
ex2 = Add (Num 2) (Num 2)
ex3 = Mul (Add (Num 1) (Num 2)) (Num 3)
ex4 = Add (Num 1) (Mul (Num 2) (Num 3))
ex5 = Div x (Mul (Num 2) y)
ex6 = Mul (Num 2) x
ex7 = Add (Mul (Num 2) x) (Mul (Num 3) y)
ex8 = Add (Mul (Num 2) (Mul x x)) (Mul (Num 3) y)

x   = Var "x"
y   = Var "y"

--------------------------------------------------------------------------------

-- Here is a different implementation of the Show instance for Expr,
-- to illustrate the systematic treatment of operator precedences used in the
-- Show class, which makes them work across Show instances for different
-- types. Examples to try:
--     > show ex2            -- ex2 is shown at precedence level 0
--     > show (Just ex2)     -- ex2 is shown at precedence level 11
--     > show ex5            -- 2*y is shown at precedence level 8

instance Show Expr where
  showsPrec p e =
    case e of
      Num n     -> shows n
      Var x     -> (x++)
      Add e1 e2 -> showParen (p>6) (showsPrec 6 e1 . ('+':) . showsPrec 6 e2)
      Mul e1 e2 -> showParen (p>7) (showsPrec 7 e1 . ('*':) . showsPrec 7 e2)
      Div e1 e2 -> showParen (p>7) (showsPrec 7 e1 . ('/':) . showsPrec 8 e2)

--------------------------------------------------------------------------------
-- * Parsing expressions with variables and division

expr, term, factor :: Parser Expr

expr = leftAssoc Add term (char '+')

term = do f1 <- factor
          fs <- zeroOrMore (char '*' *> (flip Mul <$> factor)
                            <|> char '/' *> (flip Div <$> factor))
          return (foldl (flip id) f1 fs)

          -- f1 :: Expr
          -- fs :: [Expr -> Expr]
          -- flip id x f ==> id f x ==> f x
          -- foldl (flip id) :: Expr -> [Expr->Expr] -> Expr


factor =   Num <$> number
       <|> Var <$> name
       <|> char '(' *> expr <* char ')'

name = oneOrMore (sat isLetter)

number :: Parser Integer
number = read <$> oneOrMore (sat isDigit)

leftAssoc :: (t->t->t) -> Parser t -> Parser sep -> Parser t
leftAssoc op item sep = foldl1 op <$> chain item sep


--------------------------------------------------------------------------------

-- | Gathering variables
vars :: Expr -> [Name]
vars (Num n) = []
vars (Var x) = [x]
vars (Add a b) = vars a `union` vars b
vars (Mul a b) = vars a `union` vars b
vars (Div a b) = vars a `union` vars b


-- | Substituting expressions for variables
substitute :: [(Name,Expr)] -> Expr -> Expr
substitute env (Num n) = Num n
substitute env (Var x) = case lookup x env of
                           Just e -> e
                           _ -> Var x
substitute env (Add a b) = Add (substitute env a) (substitute env b)
substitute env (Mul a b) = Mul (substitute env a) (substitute env b)
substitute env (Div a b) = Div (substitute env a) (substitute env b)

--------------------------------------------------------------------------------
-- | Evaluating Symbolic Expressions, without error handling

eval :: [(Name,Integer)] -> Expr -> Integer
eval env (Num n) = n
eval env (Var x) = case lookup x env of
                     Just n -> n
                     Nothing -> error ("undefined variable: "++x)
eval env (Add a b) = eval env a + eval env b
eval env (Mul a b) = eval env a * eval env b
eval env (Div a b) = eval env a `div` eval env b

--------------------------------------------------------------------------------
-- | Applicative Expression Evaluator

--evalA :: Expr -> Integer
evalA (Num n)     = pure n
evalA (Add e1 e2) = (+) <$> evalA e1 <*> evalA e2
evalA (Mul e1 e2) = (*) <$> evalA e1 <*> evalA e2


--------------------------------------------------------------------------------
-- * Avoiding division by zero

--evalD :: Expr ->
evalD (Num n)     = pure n
evalD (Add e1 e2) = (+) <$> evalD e1 <*> evalD e2
evalD (Mul e1 e2) = (*) <$> evalD e1 <*> evalD e2
evalD (Div e1 e2) = do n1 <- evalD e1
                       n2 <- evalD e2
                       safeDiv1 n1 n2

safeDiv1 x 0 = Nothing
safeDiv1 x y = Just (x `div` y)

--------------------------------------------------------------------------------
-- * Making the environment implicit


{-
--evalE :: Expr ->
evalE (Num n)   =
evalE (Var x)   =
evalE (Add e1 e2) =
evalE (Mul e1 e2) =
-}
varE :: Name -> Env -> Integer
varE x env = case lookup x env of
               Just n -> n
               Nothing -> error ("Undefined variable: "++x)

--------------------------------------------------------------------------------
-- * A monad for eval

-- | A monad for environments and avoiding failures

type Env = [(Name,Integer)]

type ErrorMessage = String
data Eval a = E (Env -> Either ErrorMessage a)
                                        -- data Maybe    a = Nothing | Just a
                                        -- data Either e a = Left e | Right a
runE (E f) = f

instance Functor Eval where
  fmap = liftM

instance Applicative Eval where
  pure = return
  (<*>) = ap

instance Monad Eval where
  -- return :: a -> Eval a
  return x = E (\ env -> Right x) 
  -- (>>=) :: Eval a -> (a->Eval b) -> Eval b
  E m >>= f = E (\env-> case m env of
                          Left e -> Left e
                          Right a -> runE (f a) env)
  -- m :: Env -> Either String a
  -- m env :: Either String a
  -- f :: a -> Eval b
  -- f a :: Eval b
  -- runE (f a) :: Env -> Either String b
  -- runE (f a) env :: Either String b

raise :: ErrorMessage -> Eval a
raise e = E (\env->Left e)

lookupVar :: Name -> Eval Integer
lookupVar x = E (\env->
              case lookup x env of
                Just n -> Right n
                _ -> Left ("undefined variable: "++x))


safeDiv :: Integer -> Integer -> Eval Integer
safeDiv x 0 = raise "division by zero"
safeDiv x y = return (x `div` y)


evalM :: Expr -> Eval Integer
evalM (Num n) = pure n
evalM (Var x) = lookupVar x
evalM (Add a b) = (+) <$> evalM a <*> evalM b
evalM (Mul a b) = (*) <$> evalM a <*> evalM b
evalM (Div a b) = do va <- evalM a
                     vb <- evalM b
                     safeDiv va vb

--------------------------------------------------------------------------------
-- * A simple calculator with definitions

data Command = Define Name Expr | Eval Expr deriving Show

command :: Parser Command
command =     Define <$> name <* char '=' <*> expr
          <|> Eval   <$> expr

main = do putStrLn "Welcome to the simple calculator!"
          readEvalPrintLoop []

-- | Our read-eval-print loop
readEvalPrintLoop :: Env -> IO void
readEvalPrintLoop env =
  do putStr "> "
     s <- getLine
     case completeParse command s of
       Nothing -> do putStrLn "Syntax error!"
                     readEvalPrintLoop env
       Just (Define n e) -> case runE (evalM e) env of
                              Right v -> readEvalPrintLoop ((n,v):env)
                              Left e -> do putStrLn e
                                           readEvalPrintLoop env
       Just (Eval e) -> do case runE (evalM e)env of
                             Right v -> print v
                             Left e -> putStrLn e
                           readEvalPrintLoop env

--------------------------------------------------------------------------------

completeParse p s =
  case parse p s of
    Just (e,"") -> Just e
    _ -> Nothing

{- Below are the tests we ran in GHCi:
:l MonadicEvaluators.hs 
ex5
eval [("x",10),("y",5)] ex5
eval [("x",10),("y",0)] ex5
eval [("x",10)] ex5
:r
:t evalA
:r
:t evalD
evalD (Div (Num 5) (Num 2))
evalD (Div (Num 5) (Num 0))
:r

:l MonadicEvaluators.hs 
main   -- 1/0, division by zero crashes the loop
main   -- x+z, undefined variables crash the loop
:t evalA
:t evalD
:r
:i Eval
:r
:r
:t raise
:t lookupVar 
:r
:t safeDiv
:r
ex5
:t evalM ex5
:t runE (evalM ex5)
runE (evalM ex5) []
runE (evalM ex5) [("x",10)]
runE (evalM ex5) [("x",10),("y",1)]
runE (evalM ex5) [("x",10),("y",0)]
:r
:r
main
-}