evaluation.ml

(* 
                         CS 51 Final Project
                         MiniML -- Evaluation
*)

(* This module implements a small untyped ML-like language under
   various operational semantics.
 *)

open Expr ;;
  
(* Exception for evaluator runtime, generated by a runtime error in
   the interpreter *)
exception EvalError of string ;;
  
(* Exception for evaluator runtime, generated by an explicit `raise`
   construct in the object language *)
exception EvalException ;;

(*......................................................................
  Environments and values 
 *)

module type ENV = sig
    (* the type of environments *)
    type env
    (* the type of values stored in environments *)
    type value =
      | Val of expr
      | Closure of (expr * env)
   
    (* empty () -- Returns an empty environment *)
    val empty : unit -> env

    (* close expr env -- Returns a closure for `expr` and its `env` *)
    val close : expr -> env -> value

    (* lookup env varid -- Returns the value in the `env` for the
       `varid`, raising an `Eval_error` if not found *)
    val lookup : env -> varid -> value

    (* extend env varid loc -- Returns a new environment just like
       `env` except that it maps the variable `varid` to the `value`
       stored at `loc`. This allows later changing the value, an
       ability used in the evaluation of `letrec`. To make good on
       this, extending an environment needs to preserve the previous
       bindings in a physical, not just structural, way. *)
    val extend : env -> varid -> value ref -> env

    (* env_to_string env -- Returns a printable string representation
       of environment `env` *)
    val env_to_string : env -> string
                                 
    (* value_to_string ?printenvp value -- Returns a printable string
       representation of a value; the optional flag `printenvp`
       (default: `true`) determines whether to include the environment
       in the string representation when called on a closure *)
    val value_to_string : ?printenvp:bool -> value -> string
  end

module Env : ENV =
  struct
    type env = (varid * value ref) list
     and value =
       | Val of expr
       | Closure of (expr * env)

    let empty () : env = []

    let close (exp : expr) (env : env) : value =
      Closure (exp, env)

    let lookup (env : env) (varname : varid) : value =
      try !(List.assoc varname env) with
      | Not_found -> raise (EvalError "Var undefined in environment")

    let extend (env : env) (varname : varid) (loc : value ref) : env =
      if List.mem_assoc varname env then
        (varname, loc) :: (List.remove_assoc varname env)
      else
        (varname, loc) :: env

    let rec value_to_string ?(printenvp : bool = true) (v : value) : string =
      match v with
      | Val (x) -> 
          exp_to_concrete_string x
      | Closure (exp, env) -> 
          "Closure (Val = " ^ exp_to_concrete_string exp ^ 
          ", Env : " ^ (if printenvp then env_to_string env ^ ")" else "{})")
        

    and env_to_string (env : env) : string =
      "{" ^ (List.fold_left (fun acc e -> 
                              let var, value = e in 
                              "" ^ var ^ " |-> " ^ value_to_string !value ^ ";" 
                              ^ acc) 
                            "" 
                            env) ^
      "}"
  end
;;


(*......................................................................
  Evaluation functions

  Each of the evaluation functions below evaluates an expression `exp`
  in an environment `env` returning a result of type `value`. We've
  provided an initial implementation for a trivial evaluator, which
  just converts the expression unchanged to a `value` and returns it,
  along with "stub code" for three more evaluators: a substitution
  model evaluator and dynamic and lexical environment model versions.

  Each evaluator is of type `expr -> Env.env -> Env.value` for
  consistency, though some of the evaluators don't need an
  environment, and some will only return values that are "bare
  values" (that is, not closures). 

  DO NOT CHANGE THE TYPE SIGNATURES OF THESE FUNCTIONS. Compilation
  against our unit tests relies on their having these signatures. If
  you want to implement an extension whose evaluator has a different
  signature, implement it as `eval_e` below.  *)

(* The TRIVIAL EVALUATOR, which leaves the expression to be evaluated
   essentially unchanged, just converted to a value for consistency
   with the signature of the evaluators. *)

(* HELPERS *)
let val_to_exp (v : Env.value) : expr =
  match v with
  | Env.Val (x) -> x
  | _ -> raise EvalException

let binopeval (b : binop) (exp1 : expr) (exp2 : expr) : expr =
  match b with
  | Concat -> 
    (match exp1, exp2 with
     | String s1, String s2 -> String (s1 ^ s2)
     | _ -> raise (EvalError "Expected String"))
  | Plus -> 
    (match exp1, exp2  with
    | Num x1, Num x2 -> Num (x1 + x2)
    | _ -> raise (EvalError "Expected Num"))
  | FPlus -> 
    (match exp1, exp2  with
    | Float x1, Float x2 -> Float (x1 +. x2)
    | _ -> raise (EvalError "Expected Float"))
  | Minus -> 
    (match exp1, exp2  with
    | Num x1, Num x2 -> Num (x1 - x2)
    | _ -> raise (EvalError "Expected Num"))
  | FMinus ->
    (match exp1, exp2  with
    | Float x1, Float x2 -> Float (x1 -. x2)
    | _ -> raise (EvalError "Expected Float"))
  | Times ->
    (match exp1, exp2  with
    | Num x1, Num x2 -> Num (x1 * x2)
    | _ -> raise (EvalError "Expected Num"))
  | FTimes -> 
    (match exp1, exp2  with
    | Float x1, Float x2 -> Float (x1 *. x2)
    | _ -> raise (EvalError "Expected Float"))
  | Equals ->
    (match exp1, exp2  with
    | Float x1, Float x2 -> Bool (x1 = x2)
    | Num x1, Num x2 -> Bool (x1 = x2)
    | Bool x1, Bool x2 -> Bool (x1 = x2)
    | _ -> raise (EvalError "Operation not allowed"))
  | GreaterThan ->
    (match exp1, exp2  with
    | Float x1, Float x2 -> Bool (x1 > x2)
    | Num x1, Num x2 -> Bool (x1 > x2)
    | Bool x1, Bool x2 -> Bool (x1 > x2)
    | _ -> raise (EvalError "Operation not allowed"))
  | LessThan ->
    (match exp1, exp2  with
    | Float x1, Float x2 -> Bool (x1 < x2)
    | Num x1, Num x2 -> Bool (x1 < x2)
    | Bool x1, Bool x2 -> Bool (x1 < x2)
    | _ -> raise (EvalError "Operation not allowed"))

let eval_t (exp : expr) (_env : Env.env) : Env.value =
  (* coerce the expr, unchanged, into a value *)
  Env.Val exp ;;

(* The SUBSTITUTION MODEL evaluator -- to be completed *)
   
let rec eval_s (exp : expr) (env : Env.env) : Env.value =
  match exp with
  | Var v -> raise (EvalError ("Unbound variable " ^ v))
  | String s -> Env.Val (String s)
  | Num x -> Env.Val (Num x)
  | Float x -> Env.Val (Float x)
  | Bool b -> Env.Val (Bool b)
  | Unop (_, e) -> 
    let res = eval_s e env in 
    (match res with
    | Env.Val (Num x) -> Env.Val (Num ~-x)
    | _ -> raise (EvalError "Operation not allowed"))
  | Binop (b, e1, e2) ->
    let res1 = eval_s e1 env in 
    let res2 = eval_s e2 env in 
    Env.Val (binopeval b (val_to_exp res1) (val_to_exp res2))
  | Conditional (e1, e2, e3) -> 
    (let res1 = eval_s e1 env in 
    match res1 with
    | Env.Val (Bool b) -> if b then eval_s e2 env else eval_s e3 env
    | _ -> raise (EvalError "Expected bool")) 
  | Fun (v, e) -> Env.Val (Fun (v, e))
  | Let (v, e1, e2) -> 
    let x = val_to_exp (eval_s e1 env) in eval_s (subst v x e2) env
  | Letrec (v, e1, e2) -> 
      let x = val_to_exp (eval_s e1 env) in 
      let v_d = x in 
      let v_dsub = subst v (Letrec (v, v_d, Var v)) v_d in 
      let b_subbed = subst v v_dsub e2 in 
      eval_s b_subbed env
  | Raise -> raise EvalException 
  | Unassigned -> raise (EvalError "Encountered Unassigned")
  | App (f, e) -> 
    (match eval_s f env with 
     | Env.Val (Fun (v, b)) -> 
        eval_s (subst v 
                     (val_to_exp (eval_s e env)) 
                      b) 
                      env
     | _ -> raise (EvalError "Not a function, can't be applied")) ;;
     
(* The DYNAMICALLY-SCOPED ENVIRONMENT MODEL evaluator -- to be
   completed *)
   
let rec eval_d (exp : expr) (env : Env.env) : Env.value =
  match exp with
  | Var v -> Env.lookup env v
  | String s -> Env.Val (String s)
  | Num x -> Env.Val (Num x)
  | Float x -> Env.Val (Float x)
  | Bool b -> Env.Val (Bool b)
  | Unop (_, e) -> 
    let res = eval_d e env in 
    (match res with
    | Env.Val (Num x) -> Env.Val (Num ~-x)
    | _ -> raise (EvalError "Operation not allowed"))
  | Binop (b, e1, e2) ->
    let res1 = eval_d e1 env in 
    let res2 = eval_d e2 env in 
    Env.Val (binopeval b (val_to_exp res1) (val_to_exp res2))
  | Conditional (e1, e2, e3) -> 
    (let res1 = eval_d e1 env in 
    match res1 with
    | Env.Val (Bool b) -> if b then eval_d e2 env else eval_d e3 env 
    | _ -> raise (EvalError "Expected bool")) 
  | Fun (v, e) -> Env.Val (Fun (v, e))
  | Let (v, e1, e2)
  | Letrec (v, e1, e2) -> 
    let v_d = eval_d e1 env in 
    let v_b = eval_d e2 (Env.extend env v (ref v_d)) in 
    v_b
  | Raise -> raise EvalException 
  | Unassigned -> raise (EvalError "Encountered Unassigned expression")
  | App (f, e) ->  
     (match eval_d f env with
     | Env.Val (Fun (v, b)) -> 
      eval_d b (Env.extend env v (ref (eval_d e env)))
     | _ -> raise (EvalError "Not a function")) ;;
       
(* The LEXICALLY-SCOPED ENVIRONMENT MODEL evaluator -- optionally
   completed as (part of) your extension *)
   
let rec eval_l (exp : expr) (env : Env.env) : Env.value =
  match exp with
  | Var v -> Env.lookup env v
  | String s -> Env.Val (String s)
  | Float x -> Env.Val (Float x)
  | Num x -> Env.Val (Num x)
  | Bool b -> Env.Val (Bool b)
  | Unop (_, e) -> 
    let res = eval_l e env in 
    (match res with
    | Env.Val (Num x) -> Env.Val (Num ~-x)
    | _ -> raise (EvalError "Operator not allowed"))
  | Binop (b, e1, e2) ->
    let res1 = eval_l e1 env in 
    let res2 = eval_l e2 env in 
    Env.Val (binopeval b (val_to_exp res1) (val_to_exp res2))
  | Conditional (e1, e2, e3) -> 
    (let res1 = eval_l e1 env in 
    match res1 with
    | Env.Val (Bool b) -> if b then eval_l e2 env else eval_l e3 env 
    | _ -> raise (EvalError "Expected boolean in condition")) 
  | Fun (v, b) -> Env.close (Fun (v, b)) env 
  | Let (v, e1, e2) -> 
    let v_d = eval_l e1 env in 
    let v_b = eval_l e2 (Env.extend env v (ref v_d)) in 
    v_b
  | Letrec (v, e1, e2) -> 
    let placeholder = ref (Env.Val (Unassigned)) in
    let env_x = Env.extend env v placeholder in 
    let v_d = eval_l e1 env_x in 
    placeholder := v_d; 
    eval_l e2 env_x
  | Raise -> raise EvalException 
  | Unassigned -> raise (EvalError "Encountered Unassigned expression")
  | App (f, e) -> 
    let clos = eval_l f env in 
    match clos with
    | Env.Closure (Fun (v, b), env') -> 
      let v_q = eval_l e env in 
      let env_l = Env.extend env' v (ref v_q) in 
      eval_l b env_l 
    | _ -> raise (EvalError "This is not a function, it cannot be applied") ;;

(* The EXTENDED evaluator -- if you want, you can provide your
   extension as a separate evaluator, or if it is type- and
   correctness-compatible with one of the above, you can incorporate
   your extensions within `eval_s`, `eval_d`, or `eval_l`. *)

let eval_e _ =
  failwith "eval_e not implemented" ;;
  
(* Connecting the evaluators to the external world. The REPL in
   `miniml.ml` uses a call to the single function `evaluate` defined
   here. Initially, `evaluate` is the trivial evaluator `eval_t`. But
   you can define it to use any of the other evaluators as you proceed
   to implement them. (We will directly unit test the four evaluators
   above, not the `evaluate` function, so it doesn't matter how it's
   set when you submit your solution.) *)
   
let evaluate = eval_s ;;