js_of_ast.ml

open Params
open Asttypes
open Attributes
open Log
open Misc
open Mytools
open Parse_type
open Print_type
open Types
open Typedtree

module L = Logged (Token_generator) (struct let size = 256 end)

(* TODO: Field annotations for builtin type constructors *)

let string_of_longident i =
  String.concat "." @@ Longident.flatten @@ i


(****************************************************************)
(* SHADOWING CHECKER *)

let report_shadowing = 
  !current_mode = Mode_cmi

let check_shadowing ?loc env id =
  if report_shadowing then begin
     let is_shadowing =
       try ignore (Env.lookup_value (Longident.Lident id) env); true
       with Not_found -> false
       in
     if is_shadowing 
       then warning ?loc:loc (" !!!!! shadowing of variable: " ^ id);
  end


(****************************************************************)
(* STRING UTILITIES *)

(**
 * Useful functions (Warning: shadows `show_list' from Mytools)
 *)

let show_list_f f sep l = l
  |> List.map f
  |> List.fold_left (fun acc x -> acc ^ (if acc = "" then "" else sep) ^ x) ""

let show_list sep l =
  List.fold_left (fun acc x -> acc ^ (if acc = "" then "" else sep) ^ x) "" l

let rec zip l1 l2 = match l1, l2 with
  | [], x :: xs | x :: xs, [] -> failwith "zip: list must have the same length."
  | [], [] -> []
  | x :: xs, y :: ys -> (x, y) :: zip xs ys

let unzip l =
  let rec aux acc1 acc2 = function
  | [] -> List.rev acc1, List.rev acc2
  | (x, y) :: xs -> aux (x :: acc1) (y :: acc2) xs
in aux [] [] l

let string_fold_lefti f acc s =
  let len = String.length s in
  let rec aux f acc i =
    if i = len then acc
    else aux f (f acc i s.[i]) (succ i)
  in aux f acc 0

let string_fold_righti f s acc =
 let len = String.length s in
  let rec aux f i acc =
    if i = len then acc
    else f i s.[i] (aux f (succ i) acc)
  in aux f 0 acc


(****************************************************************)
(* RECOGNIZING EXPRESSIONS *)

let is_sbool x = List.mem x ["true" ; "false"]

let is_unit x = x = "()"

let unit_repr = "{}"

(* Given an expression, check whether it is a primitive type or a constructed type *)
let exp_type_is_constant exp =
  List.exists (Ctype.matches exp.exp_env exp.exp_type)
  [Predef.type_bool; Predef.type_int; Predef.type_char; Predef.type_string; Predef.type_float]

let is_infix f args = match args with
  | _ :: [] | [] -> false
  | x :: xs ->
     let open Location in
     let f_loc = (f.exp_loc.loc_start, f.exp_loc.loc_end) in
     let args_loc = (x.exp_loc.loc_start, x.exp_loc.loc_end) in
     if fst args_loc < fst f_loc then true else false

exception Map_fields_elements_mismatch_number_args

(* here, bind is the function to be applied to a field and an element,
   and it returns an option, with None when the entry should be ignored,
   and with a result otherwise, to be added to the list of results *)

let map_filter_fields_elements bind fields elements =
  let rec aux = function
    | [], [] -> []
    | f :: fs, e :: es ->
      let res = aux (fs,es) in
      begin match bind f e with
        | None -> res
        | Some p -> p :: res  (* p is a pair identifier, code to be bound *)
      end
    | _ -> raise Map_fields_elements_mismatch_number_args
  in aux (fields, elements)

let map_cstr_fields ?loc bind (cstr : constructor_description) elements =
  let fields = extract_cstr_attrs cstr in
  try map_filter_fields_elements bind fields elements 
  with   Map_fields_elements_mismatch_number_args -> 
     error ?loc ("Insufficient fieldnames for arguments to " ^ cstr.cstr_name)
  

(****************************************************************)
(* PPF HELPERS *)

(**
 * Before-hand definitions of Pretty-Printer-Format for converting ocaml
 * to ECMAScript, therefore all of them are in a single place.
 *)

let ppf_lambda_wrap s =
  Printf.sprintf "(function () {@;<1 2>@[<v 0>%s@]@,}())@," s

let ppf_function args body=
  (L.log_line (Printf.sprintf "function (%s) {" args) [L.Enter; (L.CreateCtx args)]) ^ (Printf.sprintf "@;<1 2>return@[<hov 2>@ (%s);@]@,}" body)

let ppf_apply f args =
  Printf.sprintf "@[<hov 2>%s(@,%s)@]"
                 f args

let ppf_apply_infix f arg1 arg2 =
  Printf.sprintf "%s %s %s"
                 arg1 f arg2

let ppf_match_case c =
  Printf.sprintf "case %s" c

let ppf_match_binders binders =
  if binders = [] then "" else
  let binds = show_list ",@ " (List.map (fun (id,se) -> Printf.sprintf "%s = %s" id se) binders) in
  Printf.sprintf "@[<hov 2>var %s;@]" binds

let ppf_array values =
  Printf.sprintf "[%s]"
                 values

let ppf_tuple = ppf_array

let ppf_sequence exp1 exp2 =
  Printf.sprintf "%s;@,%s"
                 exp1 exp2

let ppf_while cd body =
  let s =
    Printf.sprintf "@[<v 2>while(%s) {@;<1 2>%s@,@]}"
                   cd body
  in ppf_lambda_wrap s

let ppf_for id start ed flag body =
  let fl_to_string = function
    | Upto   -> "++"
    | Downto -> "--" in
  let fl_to_symbl = function
    | Upto   -> "<="
    | Downto -> ">=" in
  let s =
    Printf.sprintf "@[<v 2>for (%s = %s ; %s %s %s ; %s%s) {@,%s@]@,}"
                   id start id (fl_to_symbl flag) ed (fl_to_string flag) id body
  in ppf_lambda_wrap s

(*let ppf_single_cstr tag =
  Printf.sprintf "%s"
    tag
*)
let ppf_cstr tag value =
  Some (Printf.sprintf "%s: %s" tag value)

(* deprecated:
  let expanded_constructors = map_cstr_fields (*~loc*) ppf_cstr cd args in
*)

let ppf_cstrs styp cstr_name rest =
  let comma = if rest = "" then "" else "," in
  let styp_full =
    match !current_mode with
    | Mode_cmi -> assert false
    | Mode_unlogged
    | Mode_line_token -> ""
    | Mode_logged -> Printf.sprintf "type: \"%s\", " styp
    in
  Printf.sprintf "{@[<v 2>%stag: \"%s\"%s %s@]}" (* TODO: cleanup *)
    styp_full cstr_name comma rest

let ppf_cstrs_fct cstr_fullname args =
   ppf_apply cstr_fullname (show_list ",@ " args)

let ppf_record llde =
  let rec aux acc = function
    | []               -> Printf.sprintf "{@;<1 2>@[<v 0>%s@]@,}" (*"@[<v 2>{@;<1 2>%s@]@,}"*) (* TODO: cleanup *) acc
    | (lbl, exp) :: [] -> aux (acc ^ Printf.sprintf "%s: %s" lbl exp) []
    | (lbl, exp) :: xs -> aux (acc ^ Printf.sprintf "%s: %s,@," lbl exp) xs
  in aux "" llde

let ppf_record_with seinit slbl sexp =
   ppf_apply "record_with" (show_list ",@ " [ seinit; Printf.sprintf "\"%s\"" slbl; sexp ])

let ppf_decl id expr = Printf.sprintf "@[<v 0>%s: %s,@,@]" id expr

let ppf_pat_array id_list array_expr =
  Printf.sprintf "var __%s = %s;@," "array" array_expr ^
    List.fold_left2 (fun acc (name, exp_type) y -> acc ^ Printf.sprintf "@[<v 0>var %s = __%s[%d];@,@]" name "array" y)
                    "" id_list @@ range 0 (List.length id_list - 1)

let ppf_field_access expr field =
  Printf.sprintf "%s.%s" expr field

let ppf_ident_name x =
  if List.mem x ["arguments"; "eval"; "caller"]
    then unsupported ("use of reserved keyword: " ^ x);
    (* TODO: complete the list *)
  Str.global_replace (Str.regexp "'") "$" x

let ppf_ident i =
  i |> Ident.name |> ppf_ident_name

let ppf_path =
  Path.name

let ppf_module content =
  Printf.sprintf "{@,%s@,}" content

let ppf_module_wrap name content names_bound =
  let bindings = show_list ", " (List.map (fun id -> Printf.sprintf "@;<0 2>%s: %s" id id) names_bound) in
  Printf.sprintf "@[<v 0>var %s = (function() {@,%s@,@,return {%s};@,})();@,@]" name content bindings



(****************************************************************)
(* FRESH ID NAMES *)

let id_fresh =
  let r = ref 0 in
  fun prefix -> (incr r; prefix ^ string_of_int !r)


(****************************************************************)
(* TOKEN TO LOC BINDINGS FOR THE ML SOURCE FILES *)

(* Keeps track of the location associated with each token,
   maps int to (pos*pos).  *)

type pos = { pos_line: int; pos_col: int }
let token_locs = Hashtbl.create 50 

let pos_of_lexing_pos lexing_pos =
  let (file, line, char) = Location.get_pos_info lexing_pos in
  { pos_line = line; pos_col = char } 

let pos_pair_of_loc loc =
  (pos_of_lexing_pos loc.Location.loc_start,
   pos_of_lexing_pos loc.Location.loc_end)


(****************************************************************)
(* FRESH TOKEN NAMES *)

let token_basename_ref = ref "no_token_basename_registered"

let token_register_basename basename =
  token_basename_ref := basename

(* returns a string of the form: ["filename.js", 3425],
   where 3425 describes the token. *)

let token_fresh =
  let r = ref 0 in
  fun loc -> (
    incr r; 
    Hashtbl.add token_locs (!r) (pos_pair_of_loc loc);
    let token_start = Printf.sprintf "@{<%d>" !r in
    let token_stop = "@}" in
    let token_loc = Printf.sprintf "\"%s.js\", %d" !token_basename_ref !r in 
    (token_start, token_stop, token_loc))



(****************************************************************)
(* CONTEXTS *)

(** Fresh name generator for contexts *)

let ctx_fresh =
  let r = ref 0 in
  fun () -> (incr r; "ctx_" ^ string_of_int !r)

let ctx_initial =
  "ctx_empty"




(****************************************************************)
(* LOGGED CONSTRUCTORS *)




(*--------- if ---------*)

let ppf_ifthenelse arg iftrue iffalse =
  Printf.sprintf "@[<v 0>if (%s) {@;<1 2>@[<v 0>%s@]@,} else {@;<1 2>@[<hv 0>%s@]@,}@]"
                 arg iftrue iffalse

let generate_logged_if loc ctx sintro sarg siftrue siffalse =
  (* sintro is not empty only in the logged case,
     it describes the binding of the value describing the argument of the if *)
  let (token_start, token_stop, token_loc) = token_fresh loc in
  match !current_mode with
  | Mode_cmi -> assert false
  | Mode_unlogged -> 
     ppf_ifthenelse sarg siftrue siffalse
  | Mode_line_token ->
     let sarg_with_token = Printf.sprintf "%s%s%s" token_start sarg token_stop in
     ppf_ifthenelse sarg_with_token siftrue siffalse
  | Mode_logged ->
     let sevent = Printf.sprintf "%slog_event(%s, %s, \"if\");@,"
        sintro token_loc ctx in
     let sbody = ppf_ifthenelse sarg siftrue siffalse in
     sevent ^ sbody


  (* TODO: extend the ctx with if_arg *)

(*--------- match ---------*)

let generate_logged_case loc spat binders ctx newctx sbody need_break =
  (* Note: binders is a list of pairs of id *)
  (* Note: if binders = [], then newctx = ctx *)
  let (token_start, token_stop, token_loc) = token_fresh loc in
  let (shead, sintro) =
    match !current_mode with
    | Mode_cmi -> assert false
    | Mode_line_token -> 
      (token_start, token_stop)
    | Mode_logged ->
      let ids = List.map fst binders in
      let mk_binding x =
        Printf.sprintf "{key: \"%s\", val: %s}" x x
      in
      let bindings =
        Printf.sprintf "[%s]" (show_list ", " (List.map mk_binding ids))
      in 
      let spreintro =
        if binders = [] then ""
        else Printf.sprintf "var %s = ctx_push(%s, %s);@," newctx ctx bindings
      in
      let sintro = Printf.sprintf "%slog_event(%s, %s, \"case\");@,"
        spreintro token_loc newctx in
      ("", sintro)
    | Mode_unlogged -> ("", "")
    in
  let sbinders = Printf.sprintf "%s%s" (if binders = [] then "" else "@;<1 2>") (ppf_match_binders binders) in
  (Printf.sprintf "@[<v 0>%s%s:%s%s@;<1 2>@[<v 0>%s%s@]@]"
     shead spat sbinders sintro sbody
     (if need_break then "@,break;" else ""))


let ppf_match sintro sarg sbranches =
  let sbranches = 
    match !current_mode with
    | Mode_cmi -> assert false
    | Mode_unlogged -> sbranches
    | Mode_line_token
    | Mode_logged -> sbranches 
      (* TODO: put back if there is not already a default case:
          ^ "@,default: throw \"No matching case for switch\";" *)
    in
  Printf.sprintf "%sswitch (%s) {@;<1 2>@[<v 0>%s@]@,}@,"
    sintro sarg sbranches

let generate_logged_match loc ctx sintro sarg sbranches arg_is_constant =
  (* sintro is useful not just in the logged case, but also in unlogged;
     this is needed for the semantics *)
  (* arg_is_constant describes whether the argument of switch is a basic JS value,
     or whether it is an encoded object from which we need to read the tag field *)
  let sarg = if arg_is_constant then sarg else sarg ^ ".tag" in
  let (token_start, token_stop, token_loc) = token_fresh loc in
  match !current_mode with
  | Mode_cmi -> assert false
  | Mode_unlogged -> 
     ppf_match sintro sarg sbranches 
  | Mode_line_token ->
     let sarg_with_token = Printf.sprintf "%s%s%s" token_start sarg token_stop in
     ppf_match sintro sarg_with_token sbranches 
  | Mode_logged ->
     let sbody = ppf_match "" sarg sbranches in
     Printf.sprintf "%slog_event(%s, %s, \"switch\");@,%s"
        sintro token_loc ctx sbody

  (* TODO: extend the ctx with switch_arg *)

(*--------- let ---------*)

let generate_logged_let loc ids ctx newctx sdecl sbody =
  let (token_start, token_stop, token_loc) = token_fresh loc in
  match !current_mode with
  | Mode_cmi -> assert false
  | Mode_unlogged -> 
     Printf.sprintf "%s@,%s" sdecl sbody
  | Mode_line_token ->
     Printf.sprintf "%s%s%s@,%s" token_start sdecl token_stop sbody  
  | Mode_logged ->
    let mk_binding x =
      Printf.sprintf "{key: \"%s\", val: %s}" x x in
    let bindings =
      Printf.sprintf "[%s]" (show_list ", " (List.map mk_binding ids)) in 
    Printf.sprintf "%s@,var %s = ctx_push(%s, %s);@,log_event(%s, %s, \"let\");@,%s@,"
      sdecl newctx ctx bindings token_loc newctx sbody


(*--------- function call ---------*)

let generate_logged_apply loc ctx sbody =
  let (token_start, token_stop, token_loc) = token_fresh loc in
  match !current_mode with
  | Mode_cmi -> assert false
  | Mode_unlogged -> 
     sbody
  | Mode_line_token ->
     Printf.sprintf "%s%s%s" token_start sbody token_stop
  | Mode_logged ->
     Printf.sprintf "log_event(%s, %s, \"call\");@,%s" token_loc ctx sbody


(*--------- enter function body ---------*)

let generate_logged_enter loc arg_ids ctx newctx sbody = 
  let (token_start, token_stop, token_loc) = token_fresh loc in
  let (shead1, shead2, sintro) =
    match !current_mode with
    | Mode_cmi -> assert false
    | Mode_line_token -> (token_start, token_stop, "")
    | Mode_logged ->
      let mk_binding x =
        Printf.sprintf "{key: \"%s\", val: %s}" x x
      in
      let bindings =
        Printf.sprintf "[%s]" (show_list ", " (List.map mk_binding arg_ids))
      in 
      let sintro = Printf.sprintf "var %s = ctx_push(%s, %s);@,log_event(%s, %s, \"enter\");@,"
        newctx ctx bindings token_loc newctx in
      ("", "", sintro)
    | Mode_unlogged -> ("", "", "")
  in
  let args = String.concat ", " arg_ids in
  Printf.sprintf "%sfunction (%s)%s {@;<1 2>@[<v 0>%s%s@]@,}" shead1 args shead2 sintro sbody


(*--------- return ---------*)

(* possibly: optimize return when it's a value *)

let generate_logged_return loc ctx sbody = 
  let (token_start, token_stop, token_loc) = token_fresh loc in
  match !current_mode with
  | Mode_cmi -> assert false
  | Mode_unlogged ->
     Printf.sprintf "@[<hv 2>return (@,%s);@]" sbody
  | Mode_line_token ->
     Printf.sprintf "@[<hv 2>%sreturn (@,%s);%s@]" token_start sbody token_stop
  | Mode_logged ->
    let id = id_fresh "_return_" in
    Printf.sprintf "var %s = %s;@,log_event(%s, ctx_push(%s, [{key: \"#RETURN_VALUE#\", val: %s}]), \"return\");@,return (%s); "
      id sbody token_loc ctx id id



(****************************************************************)
(* DESTINATIONS *)

(** Destination-style translation of expressions *)

type dest = 
  | Dest_ignore
  | Dest_return
  | Dest_assign of string
  | Dest_inline

let apply_dest loc ctx dest sbody =
  match dest with
  | Dest_ignore -> sbody
  | Dest_return -> generate_logged_return loc ctx sbody
  | Dest_assign id -> Printf.sprintf "var %s = %s;" id sbody
  | Dest_inline -> sbody

(* LATER: pull out the "var" out of switch *)

exception Not_good_for_dest_inline

let reject_inline dest =
  if dest = Dest_inline then raise Not_good_for_dest_inline



(****************************************************************)
(* TRANSLATION *)

(* takes a list of pairs made of: list of strings, and list of strings, 
   and return a pair of a string (the string concat with newlines of the fst strings),
   and a list of strings (the list flatten of the snd strings) *)

let combine_list_output args = 
   let (strs,bss) = List.split args in
   (show_list "@,@," strs), (List.flatten bss)

let rec js_of_structure s =
   let rec extract_opens acc items =
      match items with
      | { str_desc = Tstr_open od }::items2 ->
         extract_opens (od.open_path::acc) items2
      | _ -> (List.rev acc, items)
      in
   let open_paths, items = extract_opens [] s.str_items in
   let contents, namesbound = combine_list_output (List.map (fun strct -> js_of_structure_item strct) items) in
   let prefix = List.fold_left (fun str path -> str ^ "with (" ^ ppf_path path ^ ") {@,") "" open_paths in
   let postfix = List.fold_left (fun str path -> str ^ "@,}// end of with " ^ ppf_path path) "" open_paths in
   (prefix ^ "@," ^ contents ^ postfix, namesbound)

and js_of_submodule m =
  warning "code generation is incorrect for local modules\n"; 
  let loc = m.mod_loc in
  match m.mod_desc with
  | Tmod_structure  s -> ppf_module (fst (*TODO*) (js_of_structure s))
  | Tmod_functor (id, _, mtyp, mexp) -> ppf_function (ppf_ident id) (js_of_submodule mexp)
  | Tmod_apply (m1, m2, _) -> ppf_apply (js_of_submodule m1) (js_of_submodule m2)
  | Tmod_ident (p,_) -> ppf_path p
  | Tmod_constraint _ -> out_of_scope loc "module constraint"
  | Tmod_unpack     _ -> out_of_scope loc "module unpack"

and show_value_binding ctx vb = (* dest is Ignore *)
  js_of_let_pattern ctx vb.vb_pat vb.vb_expr

and js_of_structure_item s =
  let loc = s.str_loc in
  match s.str_desc with
  | Tstr_eval (e, _)     -> 
     let str = Printf.sprintf "%s" @@ js_of_expression ctx_initial Dest_ignore e in
     (str, [])
  | Tstr_value (_, vb_l) -> 
     combine_list_output (~~ List.map vb_l (fun vb -> 
        let id = ident_of_pat vb.vb_pat in
        check_shadowing ~loc:loc s.str_env id;
        let sbody = js_of_expression_inline_or_wrap ctx_initial vb.vb_expr in
        let s = Printf.sprintf "@[<v 0>var %s = %s;@]" id sbody in
        (s, [id])))
  | Tstr_type decls -> 
     combine_list_output (~~ List.map decls (fun decl -> 
        match decl.typ_type.type_kind with
        | Type_variant cstr_decls ->
           let styp = decl.typ_name.txt in
           combine_list_output (~~ List.map cstr_decls (fun (cd:Types.constructor_declaration) -> 
              let cstr_name = cd.Types.cd_id.Ident.name in
              let fields = extract_cstr_attrs_basic cstr_name cd.cd_attributes in
              let sargs = show_list ", " fields in
              let sbindings = map_filter_fields_elements ppf_cstr fields fields in
              let rest = show_list ", " sbindings in
              let sobj = ppf_cstrs styp cstr_name rest in 
              let sbody = Printf.sprintf "function %s(%s) { return %s; }" cstr_name sargs sobj in
              (sbody, [cstr_name])
              ))
        | _ -> ("", [])
        ))
  | Tstr_open       _  -> ("",[]) (* Handle modules by use of multiple compilation/linking *)
  | Tstr_modtype    _  -> ("",[])
  | Tstr_module     b  -> 
     let id = ppf_ident b.mb_id in
     let sbody = ppf_decl id (js_of_submodule b.mb_expr) in
     (sbody, [id])
  | Tstr_primitive  _  -> out_of_scope loc "primitive functions"
  | Tstr_typext     _  -> out_of_scope loc "type extensions"
  | Tstr_exception  _  -> out_of_scope loc "exceptions"
  | Tstr_recmodule  _  -> out_of_scope loc "recursive modules"
  | Tstr_class      _  -> out_of_scope loc "objects"
  | Tstr_class_type _  -> out_of_scope loc "class types"
  | Tstr_include    _  -> out_of_scope loc "includes"
  | Tstr_attribute  _  -> out_of_scope loc "attributes"

and js_of_branch ctx dest b eobj =
  let spat, binders = js_of_pattern b.c_lhs eobj in
  let newctx = if binders = [] then ctx else ctx_fresh() in
  let sbody = js_of_expression newctx dest b.c_rhs in
  let need_break = (dest <> Dest_return) in
  generate_logged_case b.c_lhs.pat_loc spat binders ctx newctx sbody need_break 
     
and js_of_expression_inline_or_wrap ctx e = 
  try 
    js_of_expression ctx Dest_inline e
  with Not_good_for_dest_inline ->
    js_of_expression_wrapped ctx e

and js_of_expression_wrapped ctx e = (* dest = Dest_return *)
  ppf_lambda_wrap (js_of_expression ctx Dest_return e)

and js_of_expression_naming_argument_if_non_variable ctx obj name_prefix = 
  match obj.exp_desc with
  | Texp_ident (path, ident,  _) -> 
      "", (js_of_path_longident path ident)
  | _ ->  (* generate  var id = sexp;  *)
      let id = id_fresh name_prefix in
      let sintro = js_of_expression ctx (Dest_assign id) obj in
      (sintro ^ "@,"), id

and js_of_expression ctx dest e =
  let inline_of_wrap = js_of_expression_inline_or_wrap ctx in (* shorthand *)
  let loc = e.exp_loc in
  let apply_dest' = apply_dest loc in
  match e.exp_desc with

  | Texp_ident (path, ident,  _) -> 
      let sexp = js_of_path_longident path ident in
      apply_dest' ctx dest sexp

  | Texp_constant c -> 
      let sexp = js_of_constant c in
      apply_dest' ctx dest sexp

  | Texp_let (_, vb_l, e) ->
    reject_inline dest;
    let (ids, sdecl) = begin match vb_l with  
      | [ { vb_pat = { pat_desc = Tpat_tuple el }; vb_expr = obj } ] -> (* binding tuples *)
         let (sintro, seobj) = js_of_expression_naming_argument_if_non_variable ctx obj "_tuple_arg_" in     
         let bind i var = 
            match var.pat_desc with
            | Tpat_var (id, _) -> 
                let sid = ppf_ident id in
                (sid, Printf.sprintf "%s[%d]" seobj i)
            | Tpat_any -> out_of_scope var.pat_loc "Underscore pattern in let-tuple"
            | _ -> out_of_scope var.pat_loc "Nested pattern matching"
            in
          let binders = List.mapi bind el in
          let ids = List.map fst binders in
          let sdecl = ppf_match_binders binders in
          (ids, sintro ^ sdecl)
      | [ { vb_pat = { pat_desc = Tpat_record (args, closed_flag) }; vb_expr = obj } ] -> (* binding records *)
          (* args : (Longident.t loc * label_description * pattern) list *)
         let (sintro, seobj) = js_of_expression_naming_argument_if_non_variable ctx obj "_record_arg_" in     
         let bind (arg_loc,label_descr,pat) = 
            let name = label_descr.lbl_name in
            match pat.pat_desc with
            | Tpat_var (id, _) -> 
                let sid = ppf_ident id in
                (sid, Printf.sprintf "%s.%s" seobj name)
            | Tpat_any -> out_of_scope e.exp_loc "Underscore pattern in let-record"
            | _ -> out_of_scope e.exp_loc "Nested pattern matching"
            in
          let binders = List.map bind args in
          let ids = List.map fst binders in
          let sdecl = ppf_match_binders binders in
          (ids, sintro ^ sdecl)
      | _ -> (* other cases *)
        let (ids,sdecls) = List.split (List.map (fun vb -> show_value_binding ctx vb) @@ vb_l) in
        let sdecl = String.concat lin1 @@ sdecls in
        (ids, sdecl)
      end in
    let newctx = ctx_fresh() in
    let sbody = js_of_expression newctx dest e in
    let sexp = generate_logged_let loc ids ctx newctx sdecl sbody in
    sexp

  | Texp_function (_, c :: [], Total) ->
    let rec explore pats e = match e.exp_desc with
      | Texp_function (_, c :: [], Total) ->
        let (p, e) = (c.c_lhs, c.c_rhs) in 
        explore (p :: pats) e
      | _ ->
        List.map ident_of_pat @@ List.rev @@ pats, e 
      in
    let arg_ids, body = explore [c.c_lhs] c.c_rhs in
    let newctx = ctx_fresh() in
    let sbody = js_of_expression newctx Dest_return body in
    let sexp = generate_logged_enter loc arg_ids ctx newctx sbody in
    apply_dest' ctx dest sexp

  | Texp_apply (f, exp_l) ->

     (* first check not partial application *)
     let is_result_arrow = 
        let ty = e.exp_type in
        let ty = Ctype.repr ty in
        match ty.desc with
        | Tarrow(l, ty1, ty2, _) -> true
        | _ -> false
        in
     if is_result_arrow then out_of_scope loc "partial application";
     
     let sl' = exp_l  (* only used to know if infix *)
               |> List.map (fun (_, eo, _) -> match eo with 
                                              | None -> out_of_scope loc "optional apply arguments"
                                              | Some ei -> ei) in
     let sl_clean = exp_l
              |> List.map (fun (_, eo, _) -> match eo with 
                                             | None -> out_of_scope loc "optional apply arguments" 
                                             | Some ei -> ei) in
     let sl = sl_clean |> List.map (fun ei -> inline_of_wrap ei) in
     let se = inline_of_wrap f in
     let sexp = 
        if is_triple_equal_comparison f then begin
          if (List.length exp_l <> 2) 
            then out_of_scope loc "=== should be applied to 2 arguments";
          let typ = (List.hd sl_clean).exp_type in
          let stype = Print_type.string_of_type_exp typ in
          let stype = Str.global_replace (Str.regexp "\\.") "_" stype in
          ppf_apply ("_compare_" ^ stype) (String.concat ",@ " sl)
        end else if is_infix f sl' && List.length exp_l = 2 then begin
           ppf_apply_infix se (List.hd sl) (List.hd (List.tl sl))
        end else begin
           ppf_apply se (String.concat ",@ " sl)
        end in

     if !current_mode = Mode_logged then begin
        (* use this to prevent logging of the result
           let return_exp = Printf.sprintf "return %s;" sexp in *)
        let return_exp = apply_dest' ctx Dest_return sexp in
        let logged_sexp = generate_logged_apply loc ctx return_exp in
        let wrapped_exp = ppf_lambda_wrap logged_sexp in
        apply_dest' ctx dest wrapped_exp
     end else begin
        (* we need a token to match the Dest_return above *)
        let (token_start, token_stop, _token_loc) = token_fresh loc in 
        let sexp2 = generate_logged_apply loc ctx sexp in
        let sexp3 = Printf.sprintf "%s%s%s" token_start sexp2 token_stop in
        apply_dest' ctx dest sexp3
     end


  | Texp_match (obj, l, [], Total) ->
     reject_inline dest;
     let (sintro, sarg) = js_of_expression_naming_argument_if_non_variable ctx obj "_switch_arg_" in     
     let sbranches = String.concat "@," (List.map (fun b -> js_of_branch ctx dest b sarg) l) in
     let arg_is_constant = exp_type_is_constant obj in
     generate_logged_match loc ctx sintro sarg sbranches arg_is_constant


  | Texp_tuple (tl) -> 
     let sexp = ppf_tuple @@ show_list_f (fun exp -> inline_of_wrap exp) ", " tl in
     apply_dest' ctx dest sexp

  | Texp_construct (p, cd, el) ->
    let cstr_fullname = string_of_longident p.txt in
    let cstr_name = cd.cstr_name in
    let cstr_fullname = 
      if cstr_fullname = "[]" then "mk_nil" 
      else if cstr_fullname = "::" then "mk_cons" 
      else cstr_fullname in  (* TODO: clean up this hack *)
    (*let styp = string_of_type_exp e.exp_type in*)
    let sexp =
      if is_sbool cstr_name then cstr_name else
      if is_unit cstr_name then unit_repr else
        begin
          let expr_strs = List.map (fun exp -> inline_of_wrap exp) el in
          ppf_cstrs_fct cstr_fullname expr_strs
        end in
    apply_dest' ctx dest sexp

  | Texp_array      (exp_l)           -> ppf_array @@ show_list_f (fun exp -> inline_of_wrap exp) ", " exp_l
  | Texp_ifthenelse (e1, e2, None)    -> out_of_scope loc "if without else"
    (* ppf_ifthen (js_of_expression e1) (js_of_expression e2) *)
  | Texp_ifthenelse (e1, e2, Some e3) ->
     reject_inline dest;
     let (sintro, se1) = 
       match !current_mode with
       | Mode_logged -> 
           let (sintro, sobj) = js_of_expression_naming_argument_if_non_variable ctx e1 "_if_arg_" in 
           (sintro, sobj)
       | _ ->  ("", inline_of_wrap e1)
       in
     generate_logged_if loc ctx sintro se1 (js_of_expression ctx dest e2) (js_of_expression ctx dest e3)
  | Texp_sequence (e1, e2) -> 
     ppf_sequence (inline_of_wrap e1) (js_of_expression ctx dest e2)
  | Texp_while      (cd, body)        -> out_of_scope loc "while"
    (* ppf_while (js_of_expression cd) (js_of_expression body) *)
  | Texp_for        (id, _, st, ed, fl, body) -> out_of_scope loc "for"
    (* ppf_for (ppf_ident id) (js_of_expression st) (js_of_expression ed) fl (js_of_expression body) *)
  | Texp_record     (llde,None)          -> 
      let sexp = ppf_record (List.map (fun (_, lbl, exp) -> (lbl.lbl_name, inline_of_wrap exp)) llde) in
      apply_dest' ctx dest sexp
  | Texp_record  ([(_,lbl, exp)], Some einit) -> (* record_with(einit, lbl, exp) *)
      let sexp = ppf_record_with (inline_of_wrap einit) (lbl.lbl_name) (inline_of_wrap exp) in
      apply_dest' ctx dest sexp

  | Texp_record (_,Some e0)  -> out_of_scope loc "record with multiple fields assigned"
  | Texp_field      (exp, _, lbl)     ->
      let sexp = ppf_field_access (inline_of_wrap exp) lbl.lbl_name in
      apply_dest' ctx dest sexp
      
  | Texp_assert      e                -> 
      let sexp = inline_of_wrap e in
      Printf.sprintf "throw %s;" sexp
      (* TODO: what about apply_dest? *)

  | Texp_function (label, cases, Total) when label = "" -> 
      let mk_pat pat_des =
        { pat_desc = pat_des;
          pat_loc = e.exp_loc;
          pat_extra = [];
          pat_type = e.exp_type;
          pat_env = e.exp_env;
          pat_attributes = [];
         } in
      let mk_exp exp_desc =
         { exp_desc = exp_desc;  
           exp_loc = e.exp_loc;
           exp_extra = [];
           exp_type = e.exp_type;
           exp_env = e.exp_env;
           exp_attributes = [];
         } in
      let name = "_fun_arg_" in
      let arg = Ident.create name in
      let thearg_lident = { txt = Longident.Lident name; loc = Location.none } in
      let thearg = mk_exp (Texp_ident (Path.Pident arg, thearg_lident, Obj.magic ())) in
      let thecase = {  
           c_lhs = mk_pat (Tpat_var (arg, Location.mknoloc name));
           c_guard = None;
           c_rhs = mk_exp (Texp_match (thearg, cases, [], Total));
          } in
      let exp = mk_exp (Texp_function (label, [thecase], Total)) in
      js_of_expression ctx dest exp

  | Texp_match      (_,_,_, Partial)  -> out_of_scope loc "partial matching"
  | Texp_match      (_,_,_,_)         -> out_of_scope loc "matching with exception branches"
  | Texp_try        (_,_)             -> out_of_scope loc "exceptions"
  | Texp_function (_, _, _) -> out_of_scope loc "use of labels"

  | Texp_variant    (_,_)             -> out_of_scope loc "polymorphic variant"
  | Texp_setfield   (_,_,_,_)         -> out_of_scope loc "setting field"
  | Texp_send       (_,_,_)           -> out_of_scope loc "objects"
  | Texp_new        (_,_,_)           -> out_of_scope loc "objects"
  | Texp_instvar    (_,_,_)           -> out_of_scope loc "objects"
  | Texp_setinstvar (_,_,_,_)         -> out_of_scope loc "objects"
  | Texp_override   (_,_)             -> out_of_scope loc "objects"
  | Texp_letmodule  (_,_,_,_)         -> out_of_scope loc "local modules"
  | Texp_lazy        _                -> out_of_scope loc "lazy expressions"
  | Texp_object     (_,_)             -> out_of_scope loc "objects"
  | Texp_pack        _                -> out_of_scope loc "packing"

and js_of_constant = function
  | Const_int       n     -> string_of_int n
  | Const_char      c     -> String.make 1 c
  | Const_string   (s, _) -> "\"" ^ (String.escaped (String.escaped s)) ^ "\"" (* Warning: 2 levels of printf *)
  | Const_float     f     -> f
  | Const_int32     n     -> Int32.to_string n
  | Const_int64     n     -> Int64.to_string n
  | Const_nativeint n     -> Nativeint.to_string n


and js_of_path_longident path ident =
  match String.concat "." @@ Longident.flatten ident.txt with
  (* for unit: *)
  | "()"  -> unit_repr
  (* for bool: *)
  | "&&"  -> "&&"
  | "||"  -> "||"
  (* for float: *)
  | "="  -> "=="
  | "+."  -> "+"
  | "*."  -> "*"
  | "-."  -> "-"
  | "~-." -> "-"
  | "/."  -> "/"
  | "<"   -> "<"
  | ">"   -> ">"
  | "<="   -> "<="
  | ">="   -> ">="
  (* for int: *)
  | "+"  -> "+"
  | "*"  -> "*"
  | "-"  -> "-"
  | "/"  -> "/"
  (* for string *)
  | "^"   -> "+" (* !!TODO: we want to claim ability to type our sublanguage, so we should not use this *)
  | res   -> 
      let res = if !generate_qualified_names && (Path.head path).Ident.name <> "Stdlib" 
                   then ppf_path path else res in
      ppf_ident_name res

and is_triple_equal_comparison e =
   match e.exp_desc with
   | Texp_ident (path, ident,  _) ->
      let sexp = js_of_path_longident path ident in
      sexp = "==="
      (* TODO: this text could be optimized *)
   | _ -> false

and ident_of_pat pat = match pat.pat_desc with
  | Tpat_var (id, _) -> ppf_ident id
  | Tpat_any         -> id_fresh "_pat_any_"
  | _ -> error ~loc:pat.pat_loc "functions can't deconstruct values"

(* returns the name bound and the code that assigns a value to this name *)
and js_of_let_pattern ctx pat expr =
  let id = 
    match pat.pat_desc with
    | Tpat_var (id, _) -> ppf_ident id
    | Tpat_any -> Printf.printf "warning: unsupported let-any\n"; ""
    | Tpat_alias _ -> Printf.printf "warning: unsupported let-alias\n"; ""
    | Tpat_constant _ -> Printf.printf "warning: unsupported let-constant\n"; ""
    | Tpat_tuple _ -> Printf.printf "warning: unsupported let-tuple\n"; ""
    | Tpat_construct _ -> Printf.printf "warning: unsupported let-construct\n"; ""
    | Tpat_variant _ -> Printf.printf "warning: unsupported let-variant\n"; ""
    | Tpat_record _ -> Printf.printf "warning: unsupported let-record\n"; ""
    | Tpat_array _ -> Printf.printf "warning: unsupported let-array\n"; ""
    | Tpat_or _ -> Printf.printf "warning: unsupported let-or\n"; ""
    | Tpat_lazy _ -> Printf.printf "warning: unsupported let-lazy\n"; ""
      (*  error ~loc:pat.pat_loc "let can't deconstruct values"  *)
    in
  check_shadowing ~loc:pat.pat_loc pat.pat_env id;
  (id, js_of_expression ctx (Dest_assign id) expr)

  (* LATER: for   let (x,y) = e,  encode as  translate(e,assign z); x = z[0]; y=z[1] 
    | Tpat_tuple (pat_l)
    | Tpat_array (pat_l) ->
       let l = List.map
                 (function pat ->
                           match pat.pat_desc with
                           | Tpat_var (id, _) -> (ppf_ident id, string_of_type_exp pat.pat_type)
                           | _ -> out_of_scope pat.pat_loc "nested pattern-matching in tuples or arrays"
                 ) pat_l in
       ppf_pat_array l sexpr
       *)

(* [js_of_pattern] translates a pattern to a "case" statement of a switch,
   and a list of assignements of variables (pairs of identifier and body).
   Nested patterns are not supported.
   It returns a pair: spat (the "case" instruction), binders (the assignements) *)
and js_of_pattern pat obj = 
  let loc = pat.pat_loc in
  match pat.pat_desc with
  | Tpat_any -> 
     "default", []
  | Tpat_constant c -> 
     ppf_match_case (js_of_constant c), []
  | Tpat_construct (_, cd, el) ->
     let c = cd.cstr_name in
     let spat = if is_sbool c then ppf_match_case c else ppf_match_case ("\"" ^ c ^ "\"") in
     let bind field var = 
        match var.pat_desc with
        | Tpat_var (id, _) -> 
            Some (ppf_ident id, Printf.sprintf "%s.%s" obj field)
        | Tpat_any -> None
        | _ -> out_of_scope var.pat_loc "Nested pattern matching"
        in
      let binders = map_cstr_fields ~loc bind cd el in
      spat, binders
  | Tpat_var (id, _) -> unsupported ~loc "Tpat_var"
  | Tpat_tuple el -> unsupported ~loc "tuple matching, if not in a simple let-binding"
  | Tpat_array el -> unsupported ~loc "array-match"
  | Tpat_record (_,_) -> unsupported ~loc "record"
  | Tpat_or (_,_,_) -> error ~loc "or pattern not implemented yet"
  | Tpat_alias (_,_,_) -> out_of_scope loc "alias-pattern"
  | Tpat_variant (_,_,_) -> out_of_scope loc "polymorphic variants in pattern matching"
  | Tpat_lazy _ -> out_of_scope loc "lazy-pattern"

let to_javascript basename module_name typedtree =
  token_register_basename basename;
  let (content,names_bound) = js_of_structure typedtree in
  let pre_res = ppf_module_wrap module_name content names_bound in
  let str_ppf = Format.str_formatter in
  if (!current_mode = Mode_line_token) then begin
  Format.pp_set_tags str_ppf true;
  Format.pp_set_mark_tags str_ppf true;
  Format.pp_set_formatter_tag_functions str_ppf
    {Format.mark_open_tag = (fun t -> Printf.sprintf "#<%s#" t);
     Format.mark_close_tag = (fun t -> Printf.sprintf "#%s>#" t);
     Format.print_open_tag = (fun _ -> ());
     Format.print_close_tag = (fun _ -> ())};
  end;
  Format.fprintf str_ppf (Scanf.format_from_string pre_res "");
  Format.flush_str_formatter ()