-- | Implementing a small functional language
-- More exercises with symbolic expressions
-- Functional Programming course 2017.
-- Thomas Hallgren

{-
The starting point is the code from the lecture on
symbolic expressions last week. In this lecture we extended
the syntax of expressions and added support for other types of values,
including functions.
-}
--------------------------------------------------------------------------------

module Main where
import Data.List(union)
import Data.Char(isLetter,isDigit,isSpace)
import Parsing

-- | A Haskell data type for arithmetic expressions with variables
data Expr = Num Integer
          | Var Name
          | Add Expr Expr
          | Mul Expr Expr
          | Equal Expr Expr
          | App Expr Expr
          | Lambda Name Expr
          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 = Add (Mul (Num 2) x) (Mul (Num 3) y)
ex6 = Add (Mul (Num 2) (Mul x x)) (Mul (Num 3) y)

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

--------------------------------------------------------------------------------
-- * Showing expressions

instance Show Expr where
  show = showExpr

showExpr :: Expr -> String
showExpr (Lambda x e)  = "λ"++x++"->"++showExpr e
showExpr e             = showBody e

showBody (Equal e1 e2) = showAddExpr e1 ++ "==" ++ showAddExpr e2
showBody e             = showAddExpr e

showAddExpr (Add e1 e2) = showAddExpr e1 ++ "+" ++ showAddExpr e2
showAddExpr e           = showFactor e

showFactor :: Expr -> String
showFactor (Mul e1 e2) = showFactor e1 ++ "*" ++ showFactor e2
showFactor e           = showApp e

showApp (App e1 e2) = showApp e1 ++ " "++showArg e2
showApp e           = showArg e

showArg (Num n) = show n
showArg (Var x) = x
showArg e       = "("++showExpr e++")"

--------------------------------------------------------------------------------
-- * Parsing expressions

expr, term, factor :: Parser Expr

expr = pure Lambda <* chars "\\" <*> name <* chars "->" <*> expr
       <|> body
       
body = Equal <$> addExpr <* chars "==" <*> addExpr
       <|> addExpr

addExpr = leftAssoc Add term (chars "+")
term    = leftAssoc Mul factor (chars "*")

factor = foldl1 App <$> oneOrMore arg

arg =  Num <$> number
       <|> Var <$> name
       <|> chars "(" *> expr <* chars ")"

name :: Parser Name
name = spaces *> oneOrMore (sat isLetter)

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

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

chars :: String -> Parser String
chars s = spaces *> mapM char s

spaces :: Parser String
spaces = zeroOrMore (sat isSpace)

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

-- | Evaluating Symbolic Expressions

data Value = N Integer | B Bool | F (Value -> Value) | E String

instance Show Value where
  show (N n) = show n
  show (B b) = show b
  show (F f) = "‹function›"
  show (E e) = "Error: "++e

type Env = [(Name,Value)]

eval :: Env -> Expr -> Value
eval env (Num n)   = N n
eval env (Var x)   = case lookup x env of
                       Just n  -> n
                       Nothing -> E ("undefined variable: "++x)
eval env (Add a b) = numOp (+) (eval env a) (eval env b)
eval env (Mul a b) = numOp (*) (eval env a) (eval env b)
eval env (Equal a b) = eqOp (eval env a) (eval env b)
eval env (App a b)   = apply (eval env a) (eval env b)
eval env (Lambda x b) = F (\v->eval ((x,v):env) b)

apply :: Value -> Value -> Value
apply (F f) v = f v
apply (E e) v = E e
apply _     _ = E "non-function applied to an argument"

numOp :: (Integer->Integer->Integer) -> Value->Value->Value
numOp op (N n1) (N n2) = N (op n1 n2)
numOp op (E e)  _      = E e
numOp op _      (E e)  = E e
numOp op _      _      = E "wrong type of argument to numeric operator"

eqOp :: Value -> Value -> Value
eqOp (N n1) (N n2) = B (n1==n2)
eqOp (B b1) (B b2) = B (b1==b2)
eqOp (E e)  _      = E e
eqOp _      (E e)  = E e
eqOp _      _      = E "wrong type of argument in equality test"


initial_env :: Env
initial_env = [("true",B True),
               ("false",B False),
               ("pred",F pred),
               ("if",F (\bv->F (\tv-> F (\fv->ifte bv tv fv))))]
   where
     pred :: Value -> Value
     pred (N n) = N (n-1)
     pred (E e) = E e
     pred _     = E "wrong type of argument to pred"

     ifte (B True)  tv fv = tv
     ifte (B False) tv fv = fv
     ifte (E e)     _  _  = E e
     ifte _         _  _  = E "if: expected boolean argument"

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

data Command = Define Name Expr | Eval Expr

command :: Parser Command
command =   Define <$> name <* chars "=" <*> expr
        <|> Eval   <$> expr

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

-- | Our read-eval-print loop
readEvalPrintLoop env =
  do putStr "> "
     s <- getLine
     case completeParse command s of
       Just (Define x e) -> readEvalPrintLoop ((x,eval env e):env)
       Just (Eval e)     -> do print (eval env e)
                               readEvalPrintLoop env
       _ -> do putStrLn "Syntax error!"
               readEvalPrintLoop env
               
--------------------------------------------------------------------------------

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