module JSExec

//////////////////////// place holder for helper functions /////////////
let float_of_string (s:string) = 0.0
let float_to_string (f:float) = ""
let startsWith (s1:string) (s2:string): bool = false
let toString (i:int): string = ""
let toInt (f:float): int = 0
let error() = Microsoft.FSharp.Core.Operators.exit -1 (*modeling F* error, cannot be caught*)
let NaN  = nan


////////////////////////// type dyn and heap model //////////////////////
(* use a record? *) 
type attrs = bool * bool * bool  (* property attributes: isWritable, isEnumerable, isConfigurable *)
let d_attrs: attrs = (true, true, true) (* default attributes *)

(* locations, for objects *)
type loc = obj ref (* our only ref type *)

(* properties: divided into data properties and accessors *)
and property =
  | Data     of attrs * dyn         (* attributes and a value *)
  | Accessor of attrs * (dyn * dyn) (* attributes and a pair of (getter, setter) *)

(* object is a list of (string * property), mapping property names (string) to properties *)
and obj = (string * property) list

(* Type dyn is for JavaScript values *)
and dyn = 
  | Undef                              (* for undefined *)
  | Null                               (* for null *)
  | Bool of bool
  | Num  of float
  | Str  of string
  | Obj  of loc                        (* for objects *)
  | Fun  of dyn * (dyn -> dyn -> dyn)  (* for functions, funciton objects + function closures *)

(* check if a value is a function that can be called *)
let isCallable (d : dyn): bool = match d with Fun (_, _) -> true | _ -> false

(* check if a property is configurable (removable) *)
let isConfigurable (p : property): bool = match p with
  | Data (attrs, _) 
  | Accessor (attrs, _) -> let (_, _, configurable) = attrs in configurable

(* check if a property is enumerable (in for-in) *)
let isEnumerable (p : property): bool = match p with
  | Data (attrs, _) 
  | Accessor (attrs, _) -> let (_, enumerable, _) = attrs in enumerable

(* place holder for predefined objects and operators in JavaScript *)
let String:  dyn = Obj (ref [])
let Number:  dyn = Obj (ref [])
let Boolean: dyn = Obj (ref [])
let Object:  dyn = Obj (ref [])
let globalObj:  dyn = Obj (ref [])
let PhysicalEquality (d1:dyn) (d2:dyn) = false

let assoc (f:string) (o: obj): property option  = None
(* exception for Break l v *)
exception Break of dyn
(* function to create an arguments object when no arguments are needed *)
let mkEmptyArgs (): dyn = Obj(ref [])

///////////////// property lookup/update/delete ///////////////////

(* lookup a property in an object, without walking up the prototype chains. *)
let lookup (l:dyn) (f:string) : property option = match l with
  | Fun (Obj l, _)
  | Obj l -> assoc f !l
  | _ -> None

(* update a property of an object, without walking up the prototype chains. *)
let updateP (l:dyn) (f:string) (v:dyn) = match l with
  | Fun (Obj l, _)
  | Obj l -> l := (f, Data(d_attrs, v)) :: !l
  | _ -> ()

(* lookup a property in an object, return a value if the property is a value *)
let bracket (l:dyn) (f:string) : dyn = match lookup l f with
  | Some (Data(_, v)) -> v
  | _ -> Undef

(* apply a function closure in callee to this and args. The parameter caller_obj *)
(* is the enclosing function object, used to set callee.caller property *)
let apply (caller_obj:dyn) (callee:dyn) (this:dyn) (args:dyn) : dyn = 
  match callee with 
    | Fun (callee_obj, f) -> 
      (* save the "caller" and "arguments" properties of callee before the call *)
      let caller0 = bracket callee_obj "caller" in 
      let args0   = bracket callee_obj "arguments" in
      try 
        try
          (* set up the "caller", "arguments", and "callee" properties *)
          updateP callee_obj "caller" (bracket caller_obj "@code"); 
          updateP callee_obj "arguments" args;
          updateP args "callee" callee;
          (* apply the function closure to this and args *)
          f this args
        with Break _ -> error()  | e -> raise e
      finally
        (* restore the "caller" and "arguments" properties of callee, even in the case of exceptions *)
        updateP callee_obj "caller" caller0; 
        updateP callee_obj "arguments"args0
    | _ -> error()

(* Look up a property named f in an object l and its prototype chains *)
let rec getProperty (l:dyn) (f:string): property option = match lookup l f with
  | Some p -> Some p
  | None -> match lookup l "@proto" with  (* look in l's prototype object *)
    | Some (Data(_, l')) -> getProperty l' f
    | _ -> None

(* lookup a property in an object and its prototype chain and return a value or Undef if property not found *)
let select (caller_obj:dyn) (l:dyn) (f:string) : dyn = match getProperty l f with
  | Some(Data (_, d)) -> d            (* found a value property, return the value *)
  | Some(Accessor (_, (g, _))) ->     (* found a getter, call the getter *)
    apply caller_obj g l (mkEmptyArgs())
  | _ -> Undef


(* allocate an object, with a supplied list to initialize properties *)
let allocSetObj (ps: (string*property) list): dyn = (* alloc an obj*)
  (* set default values for internal properties of an object *)
  let internalps = [("@proto", Data (d_attrs, bracket Object "prototype"));
                    ("@class", Data (d_attrs, Str "Object"));
                    ("@extensible", Data (d_attrs, Bool true))] in
  Obj (ref (internalps@ps))
(* allocate an object, with no initialization *)
let alloc () = allocSetObj []
(* allocate a completely empty object, without any properties for objects. *)
(* Used for JavaScript local variables, which are represented in JS* as objects, but are not really objects *)
let allocEmpty () = Obj(ref [])  (* for locals *)

(* update a property of an object *)
(* If there is a setter in the object or the object's prototype chain, call the setter. *)
(* Otherwise, update the object *)
let update (caller_obj:dyn) (l:dyn) (f:string) (v:dyn) : dyn = match getProperty l f with
  | Some(Accessor(_, (_, s))) ->  (* a setter, passing l as "this" to the setter, and v as the argument *)
    apply caller_obj s l (allocSetObj [("0", Data(d_attrs, v)); ("length", Data(d_attrs, Num 1.0))])
  | _ -> updateP l f v; Undef 

(* delete a field from an object *)
let DeleteField (l: loc) (f:string) : dyn =
    let rec delete o found kept =  match o with
        | [] -> l := List.rev kept; Bool found
        | (p, v) :: rest ->
          if (p = f) && isConfigurable(v) 
          then delete rest true kept
          else delete rest found ((p,v)::kept) in
    delete !l false []

(* Function.prototype.apply *)
(* The function closure of Function.prototype.apply *)
let applyFun callee arguments = (* arguments: this and arguments for the func *)
  let this = bracket arguments "0" in
  let argsArray = bracket arguments "1" in
  let caller = bracket (bracket arguments "callee") "caller" in
  let args = alloc() in
  let rec copyArgs i =
    let ith = toString i;
    if (i >= 0) then (updateP args ith (bracket argsArray ith); copyArgs (i-1)) in
  match bracket argsArray "length" with
    | Num n -> copyArgs (toInt n); apply caller callee this args         
    | _ -> error()
let applyObj: dyn = Fun (Obj(ref []), applyFun)   (* omit other properties of call for now *)
let FunProto: dyn = Obj (ref [("apply", Data(d_attrs, applyObj))])  (* Function.prototype *)
let Function: dyn = Obj (ref [("prototype", Data(d_attrs, FunProto))])

(* create a function object *)
let mkFun (s:string) (code: dyn -> dyn -> dyn -> dyn): dyn = 
    let p = alloc () in // the closure prototype
    let o = alloc () in // the closure object
    let f : dyn = Fun (o, code o) in 
    updateP p "constructor"  f;
    updateP o "prototype" p;
    updateP o "@proto" (bracket Function "prototype");
    updateP o "@class" (Str "function");
    updateP o "@code" f;
    updateP o "@toString" (Str s);
    f

////////////////////// type tests and coercions ///////////////////////
(* test if a dyn value d is primitive *)
let isPrimitive d = match d with
    | Undef
    | Null
    | Str _
    | Num _
    | Bool _ -> true
    | _ -> false

(* coerce a dyn value to Boolean *)
let toBool d = match d with
    | Bool _ -> d
    | Undef
    | Null 
    | Str ""-> Bool false
    | Num x -> Bool (not (x = NaN || x = 0.0 || x = -0.0))
    | _ -> Bool true

(* test if o has a callable function named fname that returns a primtive value when called on o *)
let testF (caller_obj:dyn) (o:dyn) fname : dyn option =
  let f = select caller_obj o fname in
  if isCallable f
  then
    let v = apply caller_obj f o (allocSetObj [("length", Data(d_attrs, Num 0.0))]) in
    if isPrimitive v then Some v else None
  else None 

(* coerce a dyn value to Number *)
let rec toNum (caller_obj:dyn) (d:dyn):dyn = match d with
    | Undef -> Num NaN
    | Null -> Num 0.0
    | Bool true -> Num 1.0
    | Bool false -> Num 0.0
    | Num _ -> d
    | Str "" -> Num 0.0
    | Str s -> Num (float_of_string s)
    | Fun (_, _) -> Num NaN
    | Obj o ->
      match testF caller_obj d "valueOf" with
        | Some v -> v
        | None -> 
          (match testF caller_obj d "toString" with
             | Some v -> v
             | None -> error()) 

(* coerce a dyn value to String *)
let rec toStr (caller_obj:dyn) (d:dyn) : dyn = match d with
    | Undef -> Str "undefined"
    | Null -> Str "null"
    | Bool true -> Str "true"
    | Bool false -> Str "false"
    | Num x -> Str (float_to_string x)
    | Str _ -> d
    | Obj _ as o 
    | Fun (o, _) -> 
      match testF caller_obj o "toString" with
        | Some v -> v
        | None -> 
          (match testF caller_obj o "valueOf" with
             | Some v -> v
             | None -> error()) 

(* coerce a dyn value to Object *)
let toObj (caller_obj:dyn) (d:dyn) : dyn = match d with
   | Undef
   | Null -> error()
   | Bool b ->
     let x = alloc() in
     (apply caller_obj Boolean x (allocSetObj [("0",Data(d_attrs, d));("length", Data(d_attrs, Num 1.0))]); x)
   | Num _ ->
     let x = alloc() in
     apply caller_obj Number x (allocSetObj [("0", Data(d_attrs, d));("length", Data(d_attrs, Num 1.0))]); x
   | Str _ ->
     let x = alloc() in
     apply caller_obj String x (allocSetObj [("0", Data(d_attrs, d));("length", Data(d_attrs, Num 1.0))]); x
   | _ -> d

(* return a string representing the type of a dyn value *)
let typeOf d = match d with
   | Undef -> Str "undefined"
   | Null ->  Str "object"
   | Bool _ -> Str "boolean"
   | Num _ -> Str "number"
   | Str _ -> Str "string"
   | Obj _ -> Str "object"
   | Fun (_, _) -> Str "function"

(* JavaScript strict equality. d1 and d2 should be of the same type *)
let tripleEq (d1:dyn) (d2:dyn) = match d1, d2 with
    | Num n1, Num n2 -> n1 = n2
    | Str s1, Str s2 -> s1 = s2
    | Bool b1, Bool b2 -> b1 = b2
    | Obj l1, Obj l2 -> PhysicalEquality d1 d2
    | Fun (f1, _), Fun (f2, _) -> PhysicalEquality f1  f2
    | _, _ -> PhysicalEquality d1 d2
     
(* JavaScript abstract equalities. May need to cerce the two values first before comparison *)
let rec doubleEq caller_obj d1 d2 = tripleEq d1 d2 ||
  (match d1, d2 with
    | Null, Undef
    | Undef, Null -> true
    | Str _, Num _ -> tripleEq (toNum caller_obj d1) d2
    | Num _, Str _ -> tripleEq d1 (toNum caller_obj d2)
    | _, Bool _  
    | Bool _, _ -> doubleEq caller_obj (toNum caller_obj d1) (toNum caller_obj d2)
    | Str _, Obj _ -> tripleEq d1 (toStr caller_obj d2)
    | Num _, Obj _ -> tripleEq d1 (toNum caller_obj d2)
    | Obj _, Str _ -> tripleEq (toStr caller_obj d1) d2
    | Obj _, Num _ -> tripleEq (toNum caller_obj d1) d2
    | _ -> false)
  
/////////////////////// control flows ////////////////////
(* combinator for while loops *)
let rec While (guard: unit -> dyn) (body: unit -> dyn) : dyn =
  let v = guard() in
  match toBool v with
    | Bool true -> body(); While guard body
    | _ -> Undef

(* combinator for for-in loops *)
(* JavaScript for (x in e) s: iterate over e's enumerable properties, *)
(* bind x to the property name each time and execute s                *)
let For_in (caller_obj: dyn) (o:dyn) (body: dyn -> dyn) : dyn =
  let rec doFields ps : dyn = match ps with
    | [] -> Undef
    | (fn, p) :: rest ->
      (if isEnumerable(p) then body (Str fn) else Undef;
       doFields rest) in 
  match o with
    | Obj l
    | Fun (Obj l, _) -> doFields (!l)
    | _ -> Undef