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 (including closures) 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 =
      match (List.assoc_opt varname env) with 
      | Some x -> !x
      | None -> raise (EvalError "no varid found")

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

    let rec value_to_string ?(printenvp : bool = true) (v : value) : string =
      match v with
      | Val exp -> exp_to_concrete_string exp
      | Closure (exp, env) -> 
        let exp_str = exp_to_concrete_string exp in 
        if printenvp 
          then "[" ^ env_to_string env ^ " ⊢ " ^ exp_str ^ "]"
        else exp_str

    and env_to_string (env : env) : string =
      let length = ref (List.length env) in
      let rec environment (env : env): string =
        match env with 
        | [] -> ""
        | (varid, value) :: tl -> 
          let inner = varid ^ " -> " ^ value_to_string !value in
          if !length = 1 then inner
          else (decr length; inner ^ "; " ^ environment tl) in
      "{" ^ environment 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. *)
   
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 *)

(* global bc I use val_to_exp in miniml.ml *)
let val_to_exp (e : Env.value) : expr =
  (match e with
  | Val exp -> exp
  | Closure (exp, _) -> exp) ;;

let eval (f : expr -> Env.env -> Env.value) (exp : expr) (env : Env.env)
        : Env.value = 
  match exp with 
  | Num _ | Bool _ | Float _ | String _ | Unit -> Env.Val exp             
  | Unop (u, e) -> 
    let unop_helper (u : unop) (e : expr) : expr =
      (match u, e with 
      | Negate, Num n -> Num ~-n
      | Negate, _ -> raise (EvalError "can only negate integers") 
      | FloatNegate, Float f -> Float ~-.f
      | FloatNegate, _ -> raise (EvalError "can only negate floats") 
      | Sin, Num n -> Float (sin (float_of_int n))
      | Sin, Float f -> Float (sin f) 
      | Sin, _ -> raise (EvalError "can only find sin of integers/floats") 
      | Cos, Num n -> Float (cos (float_of_int n))
      | Cos, Float f -> Float (cos f) 
      | Cos, _ -> raise (EvalError "can only find cos of integers/floats") 
      | Tan, Num n -> Float (tan (float_of_int n))
      | Tan, Float f -> Float (tan f) 
      | Tan, _ -> raise (EvalError "can only find tan of integers/floats")) in 
    Env.Val (unop_helper u (val_to_exp(f e env)))
  | Binop (b, e1, e2) -> 
    let binop_helper (b : binop) (e1 : expr) (e2 : expr) : expr =
      (match b, e1, e2 with 
      | Plus, Num n1, Num n2 -> Num (n1 + n2)
      | Plus, _, _ -> raise (EvalError "can only add integers")
      | FloatPlus, Float f1, Float f2 -> Float (f1 +. f2)
      | FloatPlus, _, _ -> raise (EvalError "can only add floats")
      | Minus, Num n1, Num n2 -> Num (n1 - n2)
      | Minus, _, _ -> raise (EvalError "can only subtract integers")
      | FloatMinus, Float f1, Float f2 -> Float (f1 -. f2)
      | FloatMinus, _, _ -> raise (EvalError "can only subtract floats")
      | Times, Num n1, Num n2 -> Num (n1 * n2)
      | Times, _, _ -> raise (EvalError "can only multiply integers")
      | FloatTimes, Float f1, Float f2 -> Float (f1 *. f2)
      | FloatTimes, _, _ -> raise (EvalError "can only multiply floats")
      | Divide, Num n1, Num n2 -> Num (n1 / n2)
      | Divide, _, _ -> raise (EvalError "can only divide integers")
      | FloatDivide, Float f1, Float f2 -> Float (f1 /. f2)
      | FloatDivide, _, _ -> raise (EvalError "can only divide floats")
      | Power, Num n1, Num n2 -> 
        Num (int_of_float ((float_of_int n1) ** (float_of_int n2)))
      | Power, Float f1, Float f2 -> Float (f1 /. f2)
      | Power, _, _ -> raise (EvalError "can only take power of integers/floats")
      | Equals, x1, x2 -> Bool (x1 = x2)
      | LessThan, Num n1, Num n2 -> Bool (n1 < n2)
      | LessThan, Float f1, Float f2 -> Bool (f1 < f2)
      | LessThan, _, _ -> raise (EvalError "can only compare integers/floats") 
      | GreaterThan, Num n1, Num n2 -> Bool (n1 > n2)
      | GreaterThan, Float f1, Float f2 -> Bool (f1 > f2)
      | GreaterThan, _, _ -> raise (EvalError "can only compare integers/floats")) in 
    Env.Val (binop_helper b (val_to_exp (f e1 env)) (val_to_exp (f e2 env)))
  | Conditional (e1, e2, e3) -> 
    (match f e1 env with
    | Env.Val Bool b -> if b then f e2 env else f e3 env
    | _ -> raise (EvalError "condition not bool"))
  | Raise -> raise EvalException
  | Unassigned -> raise (EvalError "cannot evaluate unassigned") ;;

  
let rec eval_s (exp : expr) (env : Env.env) : Env.value =
  match exp with
  | Num _ | Bool _ | Float _ | String _ | Unit | Unop _| Binop _
  | Conditional _ | Raise | Unassigned -> eval eval_s exp env 
  | Var _ -> raise (EvalError "unbound variable")
  | Fun _ -> Env.Val exp
  | Let (v, e1, e2) -> eval_s (subst v e1 e2) env
  | Letrec (v, e1, e2) -> 
    eval_s (subst v (subst v (Letrec (v, e1, Var v)) e1) e2) env                             
  | App (e1, e2) -> 
    (match eval_s e1 env with
    | Env.Val Fun (v, e) -> eval_s (subst v e2 e) env
    | _ -> raise (EvalError "bad redex")) ;;
     
(* The DYNAMICALLY-SCOPED ENVIRONMENT MODEL evaluator -- to be
   completed *)

let rec eval_d (exp : expr) (env : Env.env) : Env.value =
  match exp with
  | Num _ | Bool _ | Float _ | String _ | Unit | Unop _| Binop _
  | Conditional _ | Raise | Unassigned -> eval eval_d exp env 
  | Var v -> Env.lookup env v
  | Fun _ -> Env.Val exp
  | Let (v, e1, e2) -> eval_d e2 (Env.extend env v (ref (eval_d e1 env)))
  | Letrec (v, e1, e2) -> 
    let value = ref (eval_d e1 env) in
    let new_env = Env.extend env v (value) in
    value := eval_d e1 new_env ;
    eval_d e2 new_env                         
  | App (e1, e2) -> 
    (match eval_d e1 env with
    | Env.Val Fun (v, e) -> eval_d e (Env.extend env v (ref ((eval_d e2 env))))
    | _ -> raise (EvalError "bad redex")) ;;
       
(* 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
  | Num _ | Bool _ | Float _ | String _ | Unit | Unop _| Binop _
  | Conditional _ | Raise | Unassigned -> eval eval_l exp env 
  | Var v -> Env.lookup env v 
  | Fun (v, e) -> Env.Closure (Fun (v, e), env) 
  | Let (v, e1, e2) -> eval_l e2 (Env.extend env v (ref (eval_l e1 env)))
  | Letrec (v, e1, e2) -> 
    let unassigned = ref (Env.Val Unassigned) in
    let env_x = Env.extend env v unassigned in
    let v_D = eval_l e1 env_x in
    if v_D = Env.Val Unassigned then raise (EvalError "invalid letrec")
    else unassigned := v_D; eval_l e2 env_x
  | App (e1, e2) -> 
    (match eval_l e1 env with
    | Env.Closure (Fun (v, e), new_env) -> 
      (eval_l e (Env.extend new_env v (ref ((eval_l e2 env)))))
    | _ -> raise (EvalError "bad redex")) ;;

(* 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_s = eval_s ;;
let evaluate_d = eval_d ;;
let evaluate_l = eval_l ;;