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

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

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

-- | A Haskell data type for arithmetic expressions with variables and division
data Expr = Num Integer
          | Var Name
          | 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)

-- Warning: for testing in GHCi, it might be better to use deriving Show,
-- so that you can see the difference between e.g. (1+2)+3 and 1+(2+3)

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

{- BNF:
expr ::= term {"+" term}.
term ::= factor {mulOp factor}.
mulOp  ::= "*" | "/".
factor ::= number | name | "(" expr ")".
number ::= digit {digit}.
name ::= letter {letter}.
-}

expr, term, factor :: Parser Expr

expr = leftAssoc Add term (char '+')

term = do f1 <- factor
          fs <- zeroOrMore (flip <$> mulOp <*> 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

mulOp :: Parser (Expr->Expr->Expr)
mulOp = char '*' *> return Mul
        <|>
        char '/' *> return Div

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

name :: Parser Name
name = oneOrMore (sat isLetter)

number :: Parser Integer
number = readsP   -- From the Parsing library: readsP :: Read a => Parser a


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


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

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


--------------------------------------------------------------------------------
-- | Evaluating Symbolic Expressions, using Maybe for error handling

eval :: [(Name,Integer)] -> Expr -> Maybe Integer
eval env (Num n)     = Just n
eval env (Var x)     = lookup x env
eval env (Add e1 e2) = case (eval env e1,eval env e2) of
                         (Just n1,Just n2) -> Just (n1+n2)
                         _                 -> Nothing
eval env (Mul e1 e2) = case (eval env e1,eval env e2) of
                         (Just n1,Just n2) -> Just (n1*n2)
                         _                 -> Nothing
eval env (Div e1 e2) =  case (eval env e1,eval env e2) of
                         (Just n1,Just n2) | n2/=0 -> Just (n1 `div` n2)
                         _                         -> Nothing

--------------------------------------------------------------------------------
-- | Monadic Expression Evaluator using the do notation

evalDo :: [(Name,Integer)] -> Expr -> Maybe Integer
evalDo env (Num n)     = Just n
evalDo env (Var x)     = lookup x env
evalDo env (Add e1 e2) = do n1 <- evalDo env e1
                            n2 <- evalDo env e2
                            return (n1+n2)
evalDo env (Mul e1 e2) = do n1 <- evalDo env e1
                            n2 <- evalDo env e2
                            return (n1*n2)
evalDo env (Div e1 e2) = do n1 <- evalDo env e1
                            n2 <- evalDo env e2
                            guard (n2/=0)
                            return (n1 `div` n2)

--------------------------------------------------------------------------------
-- | Monadic Expression Evaluator using <$> and <*> instead of the do notation

evalA :: [(Name,Integer)] -> Expr -> Maybe Integer
evalA env (Num n)     = pure n
evalA env (Var x)     = lookup x env
evalA env (Add e1 e2) = (+) <$> evalA env e1 <*> evalA env e2
evalA env (Mul e1 e2) = (*) <$> evalA env e1 <*> evalA env e2
evalA env (Div e1 e2) = do n1 <- evalA env e1
                           n2 <- evalA env e2
                           safeDiv1 n1 n2

safeDiv1 :: Integer -> Integer -> Maybe Integer
safeDiv1 x 0 = Nothing
safeDiv1 x y = Just (x `div` y)


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

type Env = [(Name,Integer)]
type ErrorMessage = String

-- | A monad for environments and error handling
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 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
                         Right x -> runE (f x) env
                         Left e -> Left e)
  -- m :: Env -> Either ErrorMessage a
  -- m env :: Either ErrorMessage a
  -- f :: a -> Eval b
  -- x :: a
  -- f x :: Eval b
  -- runE (f x) :: Env -> Either ErrorMessage b
  -- runE (f x) env :: Either ErrorMessage b


instance Functor Eval where
  fmap = liftM

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


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

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

safeDiv :: Integer -> Integer -> Eval Integer
safeDiv x 0 = throw "divide 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 e1 e2) = (+) <$> evalM e1 <*> evalM e2
evalM (Mul e1 e2) = (*) <$> evalM e1 <*> evalM e2
evalM (Div e1 e2) = join (safeDiv <$> evalM e1 <*> evalM e2)

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

{- BNF:
command ::= name "=" expr
          | expr.
-}

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 ()
readEvalPrintLoop env =
  do putStr "> "
     s <- getLine
     case parse command s of
       Just (Define x e,"") -> case runE (evalM e) env of
                                Right n -> readEvalPrintLoop ((x,n):env)
                                Left e -> do putStrLn e
                                             readEvalPrintLoop env
       Just (Eval e,"") -> case runE (evalM e) env of
                             Right n -> do print n
                                           readEvalPrintLoop env
                             Left e -> do putStrLn e
                                          readEvalPrintLoop env
       _ -> do putStrLn "Syntax error!"
               readEvalPrintLoop env