lib.hs

module Lib where
import Data.HashMap.Strict as H (HashMap, empty, fromList, insert, lookup, union)


--- Data Types
--- ----------

--- ### Environments and Results

type Env  = H.HashMap String Val
type PEnv = H.HashMap String Stmt

type Result = (String, PEnv, Env)

--- ### Values

data Val = IntVal Int
         | BoolVal Bool
         | CloVal [String] Exp Env
         | ExnVal String
    deriving (Eq)

instance Show Val where
    show (IntVal i) = show i
    show (BoolVal i) = show i
    show (CloVal xs body env) = "<" ++ show xs   ++ ", "
                                    ++ show body ++ ", "
                                    ++ show env  ++ ">"
    show (ExnVal s) = "exn: " ++ s

--- ### Expressions

data Exp = IntExp Int
         | BoolExp Bool
         | FunExp [String] Exp
         | LetExp [(String,Exp)] Exp
         | AppExp Exp [Exp]
         | IfExp Exp Exp Exp
         | IntOpExp String Exp Exp
         | BoolOpExp String Exp Exp
         | CompOpExp String Exp Exp
         | VarExp String
    deriving (Show, Eq)

--- ### Statements

data Stmt = SetStmt String Exp
          | PrintStmt Exp
          | QuitStmt
          | IfStmt Exp Stmt Stmt
          | ProcedureStmt String [String] Stmt
          | CallStmt String [Exp]
          | SeqStmt [Stmt]
    deriving (Show, Eq)

--- Primitive Functions
--- -------------------

intOps :: H.HashMap String (Int -> Int -> Int)
intOps = H.fromList [ ("+", (+))
                    , ("-", (-))
                    , ("*", (*))
                    , ("/", (div))
                    ]

boolOps :: H.HashMap String (Bool -> Bool -> Bool)
boolOps = H.fromList [ ("and", (&&))
                     , ("or", (||))
                     ]

compOps :: H.HashMap String (Int -> Int -> Bool)
compOps = H.fromList [ ("<", (<))
                     , (">", (>))
                     , ("<=", (<=))
                     , (">=", (>=))
                     , ("/=", (/=))
                     , ("==", (==))
                     ]

--- Problems
--- ========

--- Lifting Functions
--- -----------------

liftIntOp :: (Int -> Int -> Int) -> Val -> Val -> Val
liftIntOp op (IntVal a) (IntVal b) = IntVal (op a b)
liftIntOp _ _ _ = ExnVal "Cannot lift"

liftBoolOp :: (Bool -> Bool -> Bool) -> Val -> Val -> Val
liftBoolOp op (BoolVal a) (BoolVal b) = BoolVal (op a b)
liftBoolOp _ _ _ = ExnVal "Cannot lift"

liftCompOp :: (Int -> Int -> Bool) -> Val -> Val -> Val
liftCompOp op (IntVal a) (IntVal b) = BoolVal (op a b)
liftCompOp _ _ _ = ExnVal "Cannot lift"

--- Eval
--- ----

eval :: Exp -> Env -> Val

--- ### Constants

eval (IntExp i)  _ = IntVal i
eval (BoolExp i) _ = BoolVal i

--- ### Variables

eval (VarExp s) env = case (H.lookup s env) of
  (Just v) -> v
  _ -> ExnVal ("No match in env")

--- ### Arithmetic

eval (IntOpExp op e1 e2) env = case (H.lookup op intOps) of
  (Just f) -> aux f (eval e1 env) (eval e2 env)
    where aux (/) (IntVal a) (IntVal 0) = ExnVal "Division by 0"
          aux f (IntVal a) (IntVal b) = liftIntOp f (IntVal a) (IntVal b)
          aux _ a b = ExnVal "Cannot lift"
  _ -> ExnVal "Undefined operator"

--- ### Boolean and Comparison Operators

eval (BoolOpExp op e1 e2) env = case (H.lookup op boolOps) of
  (Just f) -> aux f (eval e1 env) (eval e2 env)
    where aux f (BoolVal a) (BoolVal b) = liftBoolOp f (BoolVal a) (BoolVal b)
          aux _ _ _ = ExnVal "Cannot lift"
  _ -> ExnVal "Undefined operator"

eval (CompOpExp op e1 e2) env = case (H.lookup op compOps) of
  (Just f) -> aux f (eval e1 env) (eval e2 env)
    where aux f (IntVal a) (IntVal b) = liftCompOp f (IntVal a) (IntVal b)
          aux _ _ _ = ExnVal "Cannot lift"
  _ -> ExnVal "Undefined operator"

--- ### If Expressions

eval (IfExp e1 e2 e3) env = case (eval e1 env) of
  (BoolVal c) -> if c then eval e2 env else eval e3 env
  _ -> ExnVal "Condition is not a Bool"

--- ### Functions and Function Application

eval (FunExp params body) env = CloVal params body env

eval (AppExp e1 args) env = case (eval e1 env) of
  (CloVal params body clo) -> let p = map (\x -> eval x env) args
    in eval body (H.union (H.fromList (zip params p)) clo)
  _ -> ExnVal "Apply to non-closure"

--- ### Let Expressions

eval (LetExp pairs body) env = let p = map (\(name, exp) -> (name, eval exp env)) pairs
  in eval body (H.union (H.fromList p) env)

--- Statements
--- ----------

-- Statement Execution
-- -------------------

exec :: Stmt -> PEnv -> Env -> Result
exec (PrintStmt e) penv env = (show (eval e env), penv, env)

--- ### Set Statements

exec (SetStmt var e) penv env = ("", penv, H.insert var (eval e env) env)

--- ### Sequencing

exec (SeqStmt []) penv env = ("", penv, env)
exec (SeqStmt (stmt:stmts)) penv env = let (s, p, e) = exec stmt penv env
  in let (s1, p1, e1) = exec (SeqStmt stmts) p e in (s ++ s1, p1, e1)

--- ### If Statements

exec (IfStmt e1 s1 s2) penv env = case eval e1 env of
  BoolVal c -> if c then exec s1 penv env else exec s2 penv env
  _ -> ("exn: Condition is not a Bool", penv, env)

--- ### Procedure and Call Statements

exec p@(ProcedureStmt name args body) penv env = ("", H.insert name p penv, env)

exec (CallStmt name args) penv env = case H.lookup name penv of
  Just (ProcedureStmt n a b) -> let (s, p, e) = exec b penv (H.union (H.fromList (zip a (map (\x -> eval x env) args))) env) in (s, p, e)
  _ -> ("Procedure " ++ name ++ " undefined", penv, env)