evaluation.ml

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

(* This module implements a small untyped ML-like language under
   various operational semantics.
 *)
    
open Expr ;;
  
(* Exception for evaluator runtime, generated by a runtime error *)
exception EvalError of string ;;
(* Exception for evaluator runtime, generated by an explicit "raise" construct *)
exception EvalException ;;


(* Environments and values *)

module type Env_type = sig
    type env
    type value =
      | Val of expr
      | Closure of (expr * env)
    val create : unit -> env
    val close : expr -> env -> value
    val lookup : env -> varid -> value
    val extend : env -> varid -> value ref -> env
    val env_to_string : env -> string
    val value_to_string : ?printenvp:bool -> value -> string
    val change_value : env -> varid -> value -> unit
  end

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

    (* Creates an empty environment *)
    let create () : env = [] ;;

    (* Creates a closure from an expression and the environment it's
       defined in *)
    let close (exp : expr) (env : env) : value =
      Closure (exp, env)

    (* Looks up the value of a variable in the environment *)
    let rec lookup (env : env) (varname : varid) : value =
      match env with 
      | [] -> raise (Invalid_argument "couldn't find the value")
      | (var, v) :: tl -> 
          if var = varname then !v else lookup tl varname

    let rec change_value (env : env) (varname : varid) (v : value) : unit = 
      match env with
      | [] -> raise (Invalid_argument "couldn't find the value")
      | (var, v') :: tl -> 
          if var = varname then v' := v else change_value tl varname v

    (* Returns a new environment just like env except that it maps the
       variable varid to loc *)
    let extend (env : env) (varname : varid) (loc : value ref) : env =
      [(varname, loc)] @ (List.remove_assoc varname env) 

    (* Returns a printable string representation of a value; the flag
       printenvp determines whether to include the environment in the
       string representation when called on a closure *)
    let rec value_to_string ?(printenvp : bool = true) (v : value) : string =
      match v with 
      | Val exp -> "Val (" ^ exp_to_abstract_string exp ^ ")"
      | Closure (exp, env) -> 
          if printenvp then
            "Closure (" ^ exp_to_abstract_string exp ^ ", " ^ 
            env_to_string env ^ ")"
          else 
            "Closure (" ^ exp_to_abstract_string exp ^ ")"

      (* Returns a printable string representation of an environment *)
    and env_to_string (env : env) : string =
      "[" ^ (List.fold_left (fun acc (var, v) -> 
                               if acc = "" then
                                 "(" ^ var ^ ", " ^
                                 value_to_string ~printenvp:true !v ^ ")"
                               else 
                                 acc ^ "; (" ^ var ^ ", " ^ 
                                 value_to_string ~printenvp:true !v ^ ")")
                                  "" env)
      ^ "]"

  end
;;
  

let binopeval (op : binop) (eval1 : Env.value) (eval2 : Env.value) : Env.value = 
    match op, eval1, eval2 with 
    | Plus, Val (Num i1), Val (Num i2) -> Val (Num (i1 + i2))
    | Plus, _, _ -> raise (EvalError "can't add non-ints")
    | Minus, Val (Num i1), Val (Num i2) -> Val (Num (i1 - i2))
    | Minus, _, _ -> raise (EvalError "can't subtract non-ints")
    | Times, Val (Num i1), Val (Num i2) -> Val (Num (i1 * i2))
    | Times, _, _ -> raise (EvalError "can't multiply non-ints")
    | Equals, Val (Num i1), Val (Num i2) -> Val (Bool (i1 = i2))
    | Equals, _, _ -> raise (EvalError "can't compare non-ints")
    | LessThan, Val (Num i1), Val (Num i2) -> Val (Bool (i1 < i2))
    | LessThan, _, _ -> raise (EvalError "can't compare non-ints") ;;

(* The evaluation function: Returns the result of type `value` of
   evaluating the expression `exp` in the environment `env`. In this
   initial implementation, we just convert the expression unchanged to
   a value and return it. *)


(** The external evaluator, which can be either the identity function,
    the substitution model version or the dynamic or lexical
    environment model version. *)

let eval_t exp _env = exp ;;

let rec eval_s (exp : expr) (env : Env.env) : Env.value =
  match exp with
  | Num _ | Bool _ | Fun _ -> Val exp
  | Var _ -> raise (EvalError "unbound variable")
  | Raise | Unassigned -> raise (EvalError "can't evaluate exceptions")
  | Unop (u, exp1) ->
      (match eval_s exp1 env with 
       | Env.Val (Num i) -> Env.Val (Num (-i))
       | _ -> raise (EvalError "can't negate non-ints"))
  | Binop (b, exp1, exp2) ->
      binopeval b (eval_s exp1 env) (eval_s exp2 env)
  | Conditional (exp1, exp2, exp3) ->
      (match eval_s exp1 env with 
      | Env.Val (Bool true) -> eval_s exp2 env
      | Env.Val (Bool false) -> eval_s exp3 env
      | _ -> raise (EvalError "first expression is not bool"))
  | Let (v, exp1, exp2) ->
      let Env.Val exp1' = eval_s exp1 env in
      (match exp1' with 
       | Num _ | Fun _ | Bool _ ->
         eval_s (subst v exp1' exp2) env
       | _ ->
         raise (EvalError "can't substitute "))
  | Letrec (v, exp1, exp2) ->
      let Env.Val exp1' = eval_s (subst v (Letrec (v, exp1, Var v)) exp1) env in 
      (match exp1' with 
      | Num _ | Fun _ | Bool _ ->
          eval_s (subst v exp1' exp2) env
      | _ ->
          raise (EvalError "can't substitute"))
  | App (exp1, exp2) -> 
    match eval_s exp1 env with
    | Env.Val (Fun(x, p)) ->
        let Env.Val exp2' = eval_s exp2 env in 
        eval_s (subst x exp2' p) env
    | _ -> raise (EvalError "can't apply non-functions") ;;

let rec eval_d (exp : Expr.expr) (env : Env.env) : Env.value = 
  match exp with 
  | Raise | Unassigned -> raise (EvalError "can't evaluate exceptions")
  | Num _ | Bool _ | Fun _ -> Val exp 
  | Var v -> Env.lookup env v
  | App (exp1, exp2) -> 
      (match eval_d exp1 env with 
       | Val (Fun (v, exp3)) -> 
           eval_d exp3 (Env.extend env v (ref (eval_d exp2 env))) 
       | _ -> raise (EvalError "not a funcion application"))
  | Let (v, def, body) -> 
      eval_d body (Env.extend env v (ref (eval_d def env)))
  | Letrec (v, def, body) -> 
      let new_env = Env.extend env v (ref (Env.Val Unassigned)) in
      let def_val = eval_d def new_env in
      if def_val = Val Unassigned then
        raise (EvalError "definition equals variable")
      else
        Env.change_value new_env v def_val; 
        eval_d body new_env 
  | Unop (u, exp1) -> 
      (match eval_d exp1 env with 
       | Env.Val (Num i) -> Env.Val (Num (-i))
       | _ -> raise (EvalError "can't negate non-ints"))
  | Binop (b, exp1, exp2) ->
      binopeval b (eval_d exp1 env) (eval_d exp2 env)
  | Conditional (exp1, exp2, exp3) -> 
      (match eval_d exp1 env with 
       | Val (Bool true) -> eval_d exp2 env
       | Val (Bool false) -> eval_d exp3 env
       | _ -> raise (EvalError "first expression is not bool")) ;;


let rec eval_l (exp : Expr.expr) (env : Env.env) : Env.value = 
  match exp with 
  | Raise | Unassigned -> raise (EvalError "can't evaluate exceptions")
  | Num _ | Bool _ -> Val exp 
  | Fun _ -> Closure (exp, env)
  | Var v -> Env.lookup env v
  | App (exp1, exp2) -> 
      (match eval_l exp1 env with 
       | Closure (Fun (v, exp3), env') -> 
           eval_l exp3 (Env.extend env' v (ref (eval_l exp2 env'))) 
       | _ -> raise (EvalError "not a funcion application"))
  | Let (v, def, body) -> 
      eval_l body (Env.extend env v (ref (eval_l def env)))
  | Letrec (v, def, body) -> 
      let new_env = Env.extend env v (ref (Env.Val Unassigned)) in
      let def_val = eval_l def new_env in
      if def_val = Val Unassigned then
        raise (EvalError "definition equals variable")
      else
        Env.change_value new_env v def_val; 
        eval_l body new_env 
  | Unop (u, exp1) -> 
      (match eval_l exp1 env with 
       | Env.Val (Num i) -> Env.Val (Num (-i))
       | _ -> raise (EvalError "can't negate non-ints"))
  | Binop (b, exp1, exp2) ->
      binopeval b (eval_l exp1 env) (eval_l exp2 env)
  | Conditional (exp1, exp2, exp3) -> 
      (match eval_l exp1 env with 
       | Val (Bool true) -> eval_l exp2 env
       | Val (Bool false) -> eval_l exp3 env
       | _ -> raise (EvalError "first expression is not bool")) ;;

let evaluate = eval_d ;;

(*
FIX: OPEN Env SO THAT I DON'T HAVE TO DO Env.Val all the time
CHANGE EXCEPTION STRINGS
*)