(* Environment model interpreter for Ibex *)

module IbexEnvInterp = struct
  
  open FunUtils
  open List
  open Ibex

  exception EvalError of string

  (* val run : Ibex.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 : Ibex.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)
    | Bind(name,defn,body) -> eval body (Env.bind name (eval defn env) env) 
    | 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)))
       )

  (* val primApply : Ibex.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)
    (* 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)) args	  

  (* A function for running a programs in a files *)
  let runFile pgmFile args = 
    run (sexpToPgm (Sexp.stringToSexp (File.fileToString pgmFile))) args	  

  (* An interactive read-eval-print loop (REPL) for Sigmex 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

     + (#args (a_1 i_1) ... (a_n i_n)):  Install the n integers i_ 1 ... i_n 
       as the current program arguments a_1 ... a_n

     + (#quit): Exit the interpreter
   *)

  (* val repl : unit -> unit *)
  let repl () =
    let print = StringUtils.print in 
    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 
    let rec loop env = 
      let _ = print "\n\nibex> " in 
      let line = read_line () in 
        match (Sexp.stringToSexp line) with 
          Sexp.Seq [Sexp.Sym "#quit"] -> print "\ndone\n"
        | Sexp.Seq [Sexp.Sym "#desugar"; sexp] -> 
            (print (expToString (sexpToExp sexp)); 
              (* stringToSexp performs both the desugaring of desugar
                 as well as the desugaring of bindpar *)
             loop env)
        | Sexp.Seq ((Sexp.Sym "#args") :: bindings) -> 
            let (names, ints) = ListUtils.unzip (map sexpToSymIntPair bindings) in 
	      loop (Env.make names (map (fun i -> Int i) ints))
        | _ -> 
            try 
             (print (valuToString (eval (stringToExp line) 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)
    in loop Env.empty

end