(* A meta-circular CBV interpreter for the core calculus. *)

module Interp :
sig 
  type value = 
      Vint of int 
    | Vrecord of (Tcore.label * value) list
    | Vvariant of Tcore.label * value
    | Vfn of (value -> value)   (* user-defined functions *)

  val evaluate : Tcore.exp -> value
end =
struct
  open Tcore

(* Values manipulated by the interpreter. *)
  type value = 
      Vint of int 
    | Vrecord of (label * value) list
    | Vvariant of label * value
    | Vfn of (value -> value)   (* user-defined functions *)

(* Various exceptions raised if invalid program is interpreted. *)
  exception Bad_exp
  exception Bad_app
  exception Bad_primarg
  exception Bad_switch
  exception Bad_select
  exception Bad_fix

(* The main interpreter loop. *)
  let rec eval (env:value Env.env) : exp -> value =
    let rec eval0 (e: exp) : value = 
      match e with
	Var id -> Env.lookup env id
      | Abs(id,_,e) -> Vfn (fun x -> eval (Env.extend env id x) e)
      | App(e1,e2) -> 
	  let v1 = eval0 e1 in
  	  let v2 = eval0 e2 in
	  apply v1 v2
      | Int i -> Vint i
      | Fix ([fid,Abs(id,_,e1),_],e2) -> 
	  let rec f = fun x -> eval (Env.extend (Env.extend env fid (Vfn f)) id x) e1 in
	  eval (Env.extend env fid (Vfn f)) e2
      | Fix _ -> raise Bad_fix
      | Record el ->  Vrecord(List.map (fun (l,e) -> (l,eval0 e)) el) 
      | Select(l, e) ->  
	  begin
	    match eval0 e with
	      Vrecord(vl) ->
		begin
		  try List.assoc l vl  
		  with Not_found -> raise Bad_select
		end
	    | _ -> raise Bad_select
	  end
      | Variant(l,e) -> Vvariant(l,eval0 e)
      | Switch(e, el) ->
	  begin
	    match eval0 e with
	      Vvariant(l,v) ->
		begin
		  try 
		    let e = List.assoc l el in
		    apply (eval0 e) v
		  with Not_found -> raise Bad_switch
		end
	    | _ ->  raise Bad_switch
	  end in
    eval0

  and apply v1 v2 =
    match v1 with
      Vfn f -> f v2
    | _ -> raise Bad_app
	  

(* Initial environment defining primitive operations *)
  let initial_env = 
    let vFalse = eval Env.empty eFalse in
    let vTrue = eval Env.empty eTrue in
    let vFst = eval Env.empty eFst in
    let vSnd = eval Env.empty eSnd in
    let iadd_prim = 
      Vfn (fun v -> 
        match (apply vFst v,apply vSnd v) with
          (Vint i1,Vint i2) -> Vint(i1+i2)
        | _ -> raise Bad_primarg) in
    let imul_prim = 
      Vfn (fun v -> 
        match (apply vFst v,apply vSnd v) with
          (Vint i1,Vint i2) -> Vint(i1*i2)
        | _ -> raise Bad_primarg) in
    let ieql_prim =
      Vfn (fun v ->
        match (apply vFst v,apply vSnd v) with
	  (Vint i1,Vint i2) -> if i1 = i2 then vTrue else vFalse
	| _ -> raise Bad_primarg) in
    List.fold_left2 Env.extend Env.empty primops [iadd_prim;imul_prim;ieql_prim] 
      
(* The top level evaluator *)
  let evaluate (e : exp) : value = eval initial_env e

end