(* Environment model interpreter for Hofl *)

module HoflEnvInterp = struct
  
  open FunUtils
  open List
  open Hofl

  exception EvalError of string

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

  (* val run : Hofl.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)))

  (* val eval : Hofl.exp -> valu Env.env -> valu *)
  and eval exp env = 
    match exp with 
      Lit v -> v
    | Var name -> 
	(match Env.lookup name env with 
	   Some(i) -> i
         | None -> raise (EvalError("Unbound variable: " ^ name)))
    | 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) -> apply (eval rator env) (eval rand env)
    | Bindrec(names,defns,body) -> 
        eval body
             (Env.fix (fun e -> 
                             (Env.bindallThunks names 
                                                (map (fun defn -> 
                                                         (fun () -> eval defn e))
                                                     defns)
                                                env)))

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

  (* val primApply : Hofl.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)
    | (PairFn, [x;y]) -> Pair(x,y) (* Doesn't care about component types *)
    | (Left, [Pair(l,_)]) -> l
    | (Right, [Pair(_,r)]) -> r
    | (Prepend, [x; List xs]) -> List (x::xs)
    | (Head, [List []]) -> raise (EvalError "Head of an empty list")
    | (Head, [List (x::_)]) -> x
    | (Tail, [List []]) -> raise (EvalError "Tail of an empty list")
    | (Tail, [List (_::xs)]) -> List xs
    | (Null, []) -> List []
    | (IsNull, [List []]) -> 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)
    (* 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 -> 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 -> Int i) args)

  (* An interactive read-eval-print loop (REPL) for Hofl 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 a list of name/exp bindings introduced by DEFs. 
       These are used as the bindings of a BINDREC every time an expression is 
       evaluated. Thus, all the bindings are mutually recursive. *)
    let rec loop bindings = 
      let _ = print "\n\nhofl> " 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 bindings)
          | Sexp.Seq ((Sexp.Sym "#load" | Sexp.Sym "def") :: _) -> 
	      (* add new bindings to end of binding list *)
	      loop (bindings @ (declToBindings sexp))
          | _ -> 
           (* (* Bindseq-based interpretation of top-level definitions. *)
	      let (names,defns) = ListUtils.unzip bindings
	      in (print 
		    (valuToString 
		       (eval (sexpToExp sexp)
			     (ListUtils.foldl2 Env.empty
                                               (fun e n d -> Env.bind n (eval d e) e)
                                               names
                                               defns)));
		  loop bindings) 
            *)
           (* Bindrec-based interpretation of top-level definitions. *)
	      let (names,defns) = ListUtils.unzip (List.rev bindings)
                (* although bindings are mutually recursive, pay attention
                   to more recent bindings when the same name is defined twice. *)
	      in (print (valuToString (eval (Bindrec(names,defns, sexpToExp sexp))
				  	 Env.empty)); 
		  loop bindings)
        with 
          EvalError s -> (print ("EvalError: " ^ s); loop bindings)
        | SyntaxError s -> (print ("SyntaxError: " ^ s); loop bindings)
        | Sexp.IllFormedSexp s -> (print ("SexpError: " ^ s); loop bindings)
        | Sys_error s -> (print ("Sys_error: " ^ s); loop bindings)
    in loop [] 

  and declToBindings decl = 
    match decl with 
      (* "def" is effectively a top-level directive, but doesn't begin with a sharp sign. *)
      Sexp.Seq ((Sexp.Sym "def") :: _) -> 
        let ((name,defn) as binding) = defToBinding decl in (* defined in Hofl.ml *)
	let _ = println name in 
	[binding]
    | Sexp.Seq [Sexp.Sym "#load"; Sexp.Str filename] -> 
      (* filename is required to be a string literal *)
        let _ = println ("Loading " ^ filename) in 
        let bindings = fileToBindings filename in 
        let _ = println ("Done loading " ^ filename)in 
	bindings
    | _ -> raise (EvalError ("unrecognized declaration" ^ (Sexp.sexpToString decl)))

  (* val fileToBindings: string -> (string * Hofl.exp) list *)
  and fileToBindings filename = 
    let decls = Sexp.fileToSexps filename in 
      flatten (map declToBindings decls)

end