Skip to content

Instantly share code, notes, and snippets.

@Kailang
Created February 21, 2018 14:39
Show Gist options
  • Save Kailang/b98694726907745e45c76422967941e1 to your computer and use it in GitHub Desktop.
Save Kailang/b98694726907745e45c76422967941e1 to your computer and use it in GitHub Desktop.
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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment