(* Environment model interpreter for Hoilic in which variables
   are modeled by OCAML refs. (An alternative strategy would be
   to model variables by locations in an explicit store.) *)

module HoilicCBNEnvInterp = struct
  
  open FunUtils
  open List
  open HoilicCBN
  open PromiseUnmemoized

  exception EvalError of string

  let print = StringUtils.print 
  let println = StringUtils.println

  (* val run : HoilicCBN.pgm -> int list -> valu *)
  let rec run (Pgm(fmls,body)) ints = 
    let flen = length fmls
    and ilen = length ints 
    in 
      if flen = ilen then 
        eval body (Env.make fmls ints)
      else 
        raise (EvalError ("Program expected " ^ (string_of_int flen)
                          ^ " arguments but got " ^ (string_of_int ilen)))

  (* Convert a value to a trivial promise *)
  and delayedValu v = makePromise (fun () -> v)

  (* val eval : HoilicCBN.exp -> valu ref Env.env -> valu *)
  and eval exp env = 
    match exp with 
      Lit v -> v
    | Var name -> 
	(match Env.lookup name env with 
	  Some(r) -> force (! r) 
	      (* Calculate value of promise from implicit variable dereference *)
        | None -> raise (EvalError("Unbound variable: " ^ name)))
    | Assign(name,rhs) -> 
        (* Store value of rhs in name and return old value. 
           Note that assignment in many other languages returns the new value (C) 
           or a trivial value (OCAML, Scheme). *)
	(match Env.lookup name env with 
	  Some(r) -> 
	    let oldValu = force (! r)
            and newValu = eval rhs env in (* evaluate *now* to avoid loops
					     like (<- c (+ c 1)) *)
	    let _ = r := delayedValu newValu in 
	    oldValu
	| None -> raise (EvalError("Unbound variable: " ^ name)))
    (* Special cases for lazy data constructors *)
    | PrimApp(PairFn, [rand1;rand2]) -> 
	Pair(makePromise (fun () -> eval rand1 env), 
	     makePromise (fun () -> eval rand2 env))
    | PrimApp(Prepend, [rand1;rand2]) -> 
	List(DCons(makePromise (fun () -> eval rand1 env), 
		   makePromise (fun () -> 
		                 match eval rand2 env with 
				   List dlist -> dlist
				 | v -> raise (EvalError ("Non-list tail in list: " 
							  ^ (valuToString v))))))
    | PrimApp(op, rands) -> primApply op (map (flip eval env) rands)
    | If(tst,thn,els) -> 
       (match eval tst env with 
         Bool true -> eval thn env
       | Bool false -> eval els env
       | v -> raise (EvalError ("Non-boolean test value " 
				^ (valuToString v)
				^ " in if expression:\n"
				^ (expToString exp)))
       )
    | Abs(fml,body) -> Fun(fml,body,env) (* make a closure *)
    | App(rator,rand) -> 
      (* In OCAML, this evaluates args right-to-left! *)
      (* apply (eval rator env) (eval rand env) *)
      (* This forces evaluation left-to-right *)
	let fcn = (eval rator env) in 
	let arg = makePromise (fun () -> eval rand env) in 
	apply fcn arg
    | Begin(exp1,exp2) -> let _ = eval exp1 env in eval exp2 env

  and apply fcn arg = 
    match fcn with 
      Fun(fml,body,env) -> eval body (Env.bind fml (ref arg) env)
    | _ -> raise (EvalError ("Non-function rator in application: "
			     ^ (valuToString fcn)))

  (* val primApply : HoilicCBN.binop -> valu list -> valu *)
  and primApply op args = 
    match (op, args) with 
      (Not,[Bool x]) -> Bool(not x)
    | (And,[Bool x; Bool y]) -> Bool(x && y) (* *not* short-circuit! *) 
    | (Or,[Bool x; Bool y]) -> Bool(x || y) (* *not* short-circuit! *) 
    | (LT,[Int x; Int y]) -> Bool(x < y)
    | (LE,[Int x; Int y]) -> Bool(x <= y)
    | (EQ,[Int x; Int y]) -> Bool(x = y)
    | (NE,[Int x; Int y]) -> Bool(x != y)
    | (GE,[Int x; Int y]) -> Bool(x >= y)
    | (GT,[Int x; Int y]) -> Bool(x > y)
    | (Add,[Int x; Int y]) -> Int(x + y)
    | (Sub,[Int x; Int y]) -> Int(x - y)
    | (Mul,[Int x; Int y]) -> Int(x * y)
    | (Div,[Int x; Int y]) -> if y = 0 then 
                                raise (EvalError ("Division by 0: " 
                                                  ^ (string_of_int x)))
                              else 
                                Int(x / y)
    | (Rem,[Int x; Int y]) -> if y = 0 then 
                                raise (EvalError ("Remainder by 0: "
                                                  ^ (string_of_int x)))
                              else 
                                Int(x mod y)
    | (Left, [Pair(dl,_)]) -> force dl
    | (Right, [Pair(_,dr)]) -> force dr
    | (Head, [List DNil]) -> raise (EvalError "Head of an empty list")
    | (Head, [List (DCons(dhd,_))]) -> force dhd
    | (Tail, [List DNil]) -> raise (EvalError "Tail of an empty list")
    | (Tail, [List (DCons(_,dtl))]) -> List (force dtl)
    | (Null, []) -> List DNil
    | (IsNull, [List DNil]) -> Bool(true)
    | (IsNull, [List _]) -> Bool(false)
    | (IsInt, [Int _]) -> Bool(true)
    | (IsInt, [_]) -> Bool(false)
    | (IsBool, [Bool _]) -> Bool(true)
    | (IsBool, [_]) -> Bool(false)
    | (IsFun, [Fun _]) -> Bool(true)
    | (IsFun, [_]) -> Bool(false)
    | (IsPair, [Pair _]) -> Bool(true)
    | (IsPair, [_]) -> Bool(false)
    | (IsList, [List _]) -> Bool(true)
    | (IsList, [_]) -> Bool(false)
    | (StrLen, [String s]) -> Int(String.length s)
    | (StrLT, [String s1; String s2]) -> Bool(s1 < s2)
    | (StrEQ, [String s1; String s2]) -> Bool(s1 = s2)
    | (StrConcat, [String s1; String s2]) -> String(s1 ^ s2)
    | (ToString, [String s]) -> String s (* special case *) 
    | (ToString, [v]) -> String(valuToString v)
    | (Print, [String s]) -> (print s; String s) (* special case *) 
    | (Print, [v]) -> (print (valuToString v); v)
    | (Println, [String s]) -> (println s; String s) (* special case *) 
    | (Println, [v]) -> (println (valuToString v); v)
    (* Else dynamic type error: wrong number and/or type of arguments *)
    | _ -> raise (EvalError ("Wrong arguments to " 
                             ^ (primopToString op) 
                             ^ ": " ^ (StringUtils.listToString valuToString args)))

  (* A function for running programs expressed as strings *)
  let runString pgmString args = 
    run (sexpToPgm (Sexp.stringToSexp pgmString)) 
        (map (fun i -> ref (delayedValu (Int i))) args)

  (* A function for running a programs in a files *)
  let runFile pgmFile args = 
    run (sexpToPgm (Sexp.stringToSexp (File.fileToString pgmFile))) 
        (map (fun i -> ref (delayedValu (Int i))) args)

  (* An interactive read-eval-print loop (REPL) for HoilicCBN expressions.
     By default, assumes zero arguments, but this can be changed
     with the #args directive (see below). The following directives
     are supported:

     + (#desugar <exp>) prints out the desugared form of <exp>

     + (def <name> <exp>) introduces a top-level binding of <name> to <exp>. 
       This binding is mutually recursive with all other top-level bindings.

     + (def (<name> <fml1> ... <fmln>) <exp>) is sugar for
       (def <name> (fun (<fml1> ... <fmln>) <exp>))

     + (#load "<filename>") loads definitions and other recursive loads
       from file named <filename>.

     + (#quit): Exit the interpreter
   *)

  (* val repl : unit -> unit *)
  let rec repl () =
    let sexpToSymIntPair sexp =   (* sexpToStringIntPair : sexp -> (string * int) *)
      match sexp with 
        Sexp.Seq [Sexp.Sym s; Sexp.Int i] -> (s, i)
      | _ -> raise (Failure "Not an symbol/int pair!") in 
    (* Repl loop carries with it an environment of name/value bindings 
       introduced by DEFs. In this implementation multiple DEFs are *not* mutually
       recursive, but a single DEF is *)
    let rec loop env = 
      let _ = print "\n\nhoilic-cbn> " in 
      let sexp = Sexp.readSexp() in 
        try 
          match sexp with 
            Sexp.Seq [Sexp.Sym "#quit"] -> print "\ndone\n"
          | Sexp.Seq [Sexp.Sym "#desugar"; sexp] -> 
	      ((match sexp with 
		Sexp.Seq (Sexp.Sym "def" :: _) -> 
		  print (Sexp.sexpToString (desugarDef sexp))
 	        | _ -> print (Sexp.sexpToString (desugar sexp))); 
	       loop env)
          | Sexp.Seq ((Sexp.Sym "#load" | Sexp.Sym "def") :: _) -> 
	      (* add new bindings to end of binding list *)
	      loop (Env.merge (declToEnv sexp env) env)
          | _ -> (printValu (eval (sexpToExp sexp) env);
                  loop env)
        with 
          EvalError s -> (print ("EvalError: " ^ s); loop env)
        | SyntaxError s -> (print ("SyntaxError: " ^ s); loop env)
        | Sexp.IllFormedSexp s -> (print ("SexpError: " ^ s); loop env)
        | Sys_error s -> (print ("Sys_error: " ^ s); loop env)
    in loop Env.empty

  (* val declToEnv: sexp -> valu ref Env -> valu ref Env *)
  and declToEnv decl env = 
    match decl with 
      Sexp.Seq ((Sexp.Sym "def") :: _) -> 
        let ((name,defn) as binding) = defToBinding decl in (* defined in HoilicCBN.ml *)
          Env.make [name] 
  	           [ref (fun () -> 
                           eval (sexpToExp (desugarBindrec' [name] [defn] (Sexp.Sym name)))
                                env)]
    | Sexp.Seq [Sexp.Sym "#load"; Sexp.Str filename] -> 
      (* filename is required to be a string literal *)
        let _ = println ("Loading " ^ filename) in 
        let env' = fileToEnv filename env in 
        let _ = println ("Done loading " ^ filename)in 
	env'
    | _ -> raise (EvalError ("unrecognized declaration" ^ (Sexp.sexpToString decl)))

  (* val fileToEnv: string -> valu ref Env -> valu ref Env *)
  and fileToEnv filename env = 
    let decls = Sexp.fileToSexps filename in 
      ListUtils.foldl Env.empty 
                      (fun e decl -> Env.merge (declToEnv decl (Env.merge e env)) e)
                      decls

end