feat(eval): add tree-walking interpreter
This commit is contained in:
dualfroz committed
1 parent
296e6ffe54
commit
fa1ba2ecf4
1 file changed
+174
@@ -0,0 +1,174 @@
|
||||
module Fml.Core.Eval
|
||||
|
||||
open Fml.Core.Ast
|
||||
open Fml.Core.Value
|
||||
|
||||
let rec eval (env: Env) (expr: Expr) : Value =
|
||||
match expr with
|
||||
| IntLit n -> VInt n
|
||||
| BoolLit b -> VBool b
|
||||
| StringLit s -> VString s
|
||||
| UnitLit -> VUnit
|
||||
| Var x ->
|
||||
match Map.tryFind x env with
|
||||
| Some v -> v
|
||||
| None -> raise (RuntimeError(sprintf "unbound variable '%s'" x))
|
||||
| Lambda(x, body) -> VClosure(x, body, ref env)
|
||||
| App(fn, arg) ->
|
||||
let fnValue = eval env fn
|
||||
let argValue = eval env arg
|
||||
match fnValue with
|
||||
| VClosure(x, body, closureEnv) -> eval (Map.add x argValue closureEnv.Value) body
|
||||
| VBuiltin(_, f) -> f argValue
|
||||
| _ -> raise (RuntimeError "attempt to call a non-function value")
|
||||
| Let(false, name, rhs, body) ->
|
||||
let v = eval env rhs
|
||||
eval (Map.add name v env) body
|
||||
| Let(true, name, rhs, body) ->
|
||||
let v = eval env rhs
|
||||
match v with
|
||||
| VClosure(_, _, closureEnv) ->
|
||||
closureEnv.Value <- Map.add name v closureEnv.Value
|
||||
eval (Map.add name v env) body
|
||||
| _ -> eval (Map.add name v env) body
|
||||
| LetGroup(isRec, bindings, body) ->
|
||||
let groupEnv = evalLetGroup env isRec bindings
|
||||
eval groupEnv body
|
||||
| If(cond, thenBranch, elseBranch) ->
|
||||
match eval env cond with
|
||||
| VBool true -> eval env thenBranch
|
||||
| VBool false -> eval env elseBranch
|
||||
| _ -> raise (RuntimeError "if condition is not a boolean")
|
||||
| Neg inner ->
|
||||
match eval env inner with
|
||||
| VInt n -> VInt(-n)
|
||||
| _ -> raise (RuntimeError "negation of a non-integer")
|
||||
| BinOp(op, l, r) -> evalBinOp env op l r
|
||||
| Tuple items -> VTuple(List.map (eval env) items)
|
||||
| Nil -> VList []
|
||||
| Cons(headExpr, tailExpr) ->
|
||||
let headValue = eval env headExpr
|
||||
match eval env tailExpr with
|
||||
| VList items -> VList(headValue :: items)
|
||||
| _ -> raise (RuntimeError "tail of a cons is not a list")
|
||||
| Construct(name, args) -> VConstruct(name, List.map (eval env) args)
|
||||
| Record fields -> VRecord(fields |> List.map (fun (n, e) -> n, eval env e) |> Map.ofList)
|
||||
| Field(record, fieldName) ->
|
||||
match eval env record with
|
||||
| VRecord fields ->
|
||||
match Map.tryFind fieldName fields with
|
||||
| Some fv -> fv
|
||||
| None -> raise (RuntimeError(sprintf "record has no field '%s'" fieldName))
|
||||
| _ -> raise (RuntimeError "field access on a non-record value")
|
||||
| Match(scrut, cases) ->
|
||||
let scrutValue = eval env scrut
|
||||
let rec tryCases cs =
|
||||
match cs with
|
||||
| [] -> raise (RuntimeError "match failure: no pattern matched")
|
||||
| (pat, body) :: rest ->
|
||||
match matchPattern pat scrutValue with
|
||||
| Some binds -> eval (List.fold (fun e (n, bv) -> Map.add n bv e) env binds) body
|
||||
| None -> tryCases rest
|
||||
tryCases cases
|
||||
|
||||
and evalLetGroup (env: Env) (isRec: bool) (bindings: (string * Expr) list) : Env =
|
||||
if isRec then
|
||||
let closures =
|
||||
bindings
|
||||
|> List.map (fun (name, rhs) ->
|
||||
match eval env rhs with
|
||||
| VClosure(_, _, closureEnv) as closure -> name, closure, Some closureEnv
|
||||
| other -> name, other, None)
|
||||
let groupEnv =
|
||||
closures |> List.fold (fun e (name, closure, _) -> Map.add name closure e) env
|
||||
for (_, _, closureEnvOpt) in closures do
|
||||
match closureEnvOpt with
|
||||
| Some closureEnv -> closureEnv.Value <- groupEnv
|
||||
| None -> ()
|
||||
groupEnv
|
||||
else
|
||||
let evaluated = bindings |> List.map (fun (name, rhs) -> name, eval env rhs)
|
||||
evaluated |> List.fold (fun e (name, v) -> Map.add name v e) env
|
||||
|
||||
and evalBinOp (env: Env) (op: string) (l: Expr) (r: Expr) : Value =
|
||||
match op with
|
||||
| "&&" ->
|
||||
match eval env l with
|
||||
| VBool false -> VBool false
|
||||
| VBool true -> eval env r
|
||||
| _ -> raise (RuntimeError "&& applied to a non-boolean")
|
||||
| "||" ->
|
||||
match eval env l with
|
||||
| VBool true -> VBool true
|
||||
| VBool false -> eval env r
|
||||
| _ -> raise (RuntimeError "|| applied to a non-boolean")
|
||||
| _ ->
|
||||
let a = eval env l
|
||||
let b = eval env r
|
||||
match op, a, b with
|
||||
| "+", VInt x, VInt y -> VInt(x + y)
|
||||
| "-", VInt x, VInt y -> VInt(x - y)
|
||||
| "*", VInt x, VInt y -> VInt(x * y)
|
||||
| "/", VInt x, VInt y -> if y = 0 then raise (RuntimeError "division by zero") else VInt(x / y)
|
||||
| "mod", VInt x, VInt y -> if y = 0 then raise (RuntimeError "division by zero") else VInt(x % y)
|
||||
| "<", VInt x, VInt y -> VBool(x < y)
|
||||
| "<=", VInt x, VInt y -> VBool(x <= y)
|
||||
| ">", VInt x, VInt y -> VBool(x > y)
|
||||
| ">=", VInt x, VInt y -> VBool(x >= y)
|
||||
| "=", _, _ -> VBool(valueEquals a b)
|
||||
| "<>", _, _ -> VBool(not (valueEquals a b))
|
||||
| "^", VString x, VString y -> VString(x + y)
|
||||
| _ -> raise (RuntimeError(sprintf "invalid operands for %s" op))
|
||||
|
||||
and matchPattern (pat: Pattern) (v: Value) : (string * Value) list option =
|
||||
match pat, v with
|
||||
| PWildcard, _ -> Some []
|
||||
| PVar x, _ -> Some [ (x, v) ]
|
||||
| PInt n, VInt m when n = m -> Some []
|
||||
| PInt _, _ -> None
|
||||
| PBool a, VBool b when a = b -> Some []
|
||||
| PBool _, _ -> None
|
||||
| PString a, VString b when a = b -> Some []
|
||||
| PString _, _ -> None
|
||||
| PUnit, VUnit -> Some []
|
||||
| PUnit, _ -> None
|
||||
| PTuple ps, VTuple vs when List.length ps = List.length vs -> matchList ps vs
|
||||
| PTuple _, _ -> None
|
||||
| PNil, VList [] -> Some []
|
||||
| PNil, _ -> None
|
||||
| PCons(headPat, tailPat), VList(x :: xs) ->
|
||||
match matchPattern headPat x with
|
||||
| None -> None
|
||||
| Some headBinds ->
|
||||
match matchPattern tailPat (VList xs) with
|
||||
| None -> None
|
||||
| Some tailBinds -> Some(headBinds @ tailBinds)
|
||||
| PCons _, _ -> None
|
||||
| PConstruct(name, argPats), VConstruct(tag, argVals) when name = tag && List.length argPats = List.length argVals ->
|
||||
matchList argPats argVals
|
||||
| PConstruct _, _ -> None
|
||||
| PRecord fields, VRecord recordVals ->
|
||||
let rec go remaining acc =
|
||||
match remaining with
|
||||
| [] -> Some acc
|
||||
| (fieldName, fieldPat) :: rest ->
|
||||
match Map.tryFind fieldName recordVals with
|
||||
| Some fv ->
|
||||
match matchPattern fieldPat fv with
|
||||
| Some binds -> go rest (acc @ binds)
|
||||
| None -> None
|
||||
| None -> None
|
||||
go fields []
|
||||
| PRecord _, _ -> None
|
||||
|
||||
and matchList (ps: Pattern list) (vs: Value list) : (string * Value) list option =
|
||||
match ps, vs with
|
||||
| [], [] -> Some []
|
||||
| p :: pr, v :: vr ->
|
||||
match matchPattern p v with
|
||||
| None -> None
|
||||
| Some b1 ->
|
||||
match matchList pr vr with
|
||||
| None -> None
|
||||
| Some b2 -> Some(b1 @ b2)
|
||||
| _ -> None
|
||||
Reference in new issue
Block a user