diff --git a/generator/js_of_ast.ml b/generator/js_of_ast.ml
index 0d5bfca32c5bc066e8246177bc38d588797c2533..bd1e54265f2ab26cb4ea783411673ddeea110ae1 100644
--- a/generator/js_of_ast.ml
+++ b/generator/js_of_ast.ml
@@ -208,6 +208,15 @@ let ppf_module_wrap name content =
+
+(****************************************************************)
+(* FRESH ID NAMES *)
+
+let id_fresh prefix =
+ let r = ref 0 in
+ fun () -> (incr r; prefix ^ string_of_int !r)
+
+
(****************************************************************)
(* CONTEXTS *)
@@ -224,13 +233,13 @@ let ctx_initial =
(****************************************************************)
(* LOGGED CONSTRUCTORS *)
-let generate_logged_case spat binders ctx newctx sbody = ""
+let generate_logged_case spat binders ctx newctx sbody need_break = ""
(* Note: if binders = [], then newctx = ctx *)
(* generate_logged_case implement using
[insertCaseCode(caseBody,bindings,ctx,newctx,sbody)]
-£4424;case(caseBody);codeOf(bindings);sbody
-case(caseBody); codeOf(bindings); newctx=ctx_push(ctx,bindings); logEvent(LINEOF(432423), "case", newctx);sbody
+£4424;case(caseBody);codeOf(bindings);sbody;break
+case(caseBody); codeOf(bindings); newctx=ctx_push(ctx,bindings); logEvent(LINEOF(432423), "case", newctx);sbody;break
with help of
@@ -268,7 +277,25 @@ var x=e; var newctx=ctx_push(ctx,x,e); logEvent(LINEOF(432423), "let", ctx);sbod
----
*)
+let generate_logged_enter arg_ids ctx newctx sbody = ""
+
+(*
+----
+function(x,y) {
+ [isnertEnterCode(bindings,ctx,newctx)]fdqfdsf
+ }
+
+TOKEN(432423);sbody
+
+var newctx = ctx_push(bindings);
+logEvent(LINEOF(432423), newctx, "enter");sbody
+----
+
+may reuse
+ ppf_function args body
+
+*)
@@ -281,15 +308,22 @@ type dest =
| Dest_ignore
| Dest_return
| Dest_assign of id
+ | Dest_inline
let apply_dest dest sbody =
match dest with
| Dest_ignore -> sbody
| Dest_return -> generate_logged_return ctx sbody
| Dest_assign id -> Printf.sprintf "var %s = %s;" (ppf_ident 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 *)
@@ -330,68 +364,108 @@ and js_of_structure_item s =
| Tstr_include _ -> out_of_scope loc "includes"
| Tstr_attribute _ -> out_of_scope loc "attributes"
-and js_of_branch ctx dest b obj =
- let spat, binders = js_of_pattern b.c_lhs obj in
+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
- generate_logged_case spat binders ctx newctx sbody
-
+ let need_break = (dest <> Dest_return) in
+ generate_logged_case 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 ctx dest =
let loc = e.exp_loc in
match e.exp_desc with
+
| Texp_ident (_, ident, _) ->
- js_of_longident ident
+ let sexp = js_of_longident ident in
+ apply_dest dest sexp
+
| Texp_constant c ->
- js_of_constant c
+ let sexp = js_of_constant c in
+ apply_dest dest sexp
+
| Texp_let (_, vb_l, e) ->
+ reject_inline dest;
let (ids,sdecls) = List.split (List.map (fun vb -> show_value_binding ctx vb) @@ vb_l) in
let sdecl = String.concat lin1 @@ sdecls in
let newctx = ctx_fresh() in
let sbody = js_of_expression newctx dest e in
- generate_logged_let ids ctx newctx sdecl sbody
+ let sexp = generate_logged_let ids ctx newctx sdecl sbody in
+ apply_dest dest 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
+ let (p, e) = (c.c_lhs, c.c_rhs) in
+ explore (p :: pats) e
| _ ->
- String.concat ", " @@ List.map ident_of_pat @@ List.rev @@ pats, js_of_expression e in
- let args, body = explore [c.c_lhs] c.c_rhs
- in ppf_function args body
+ 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 newdest = Dest_return in
+ let sbody = js_of_expression newctx newdest body in
+ let sexp = generate_logged_enter arg_ids ctx newctx sbody in
+ apply_dest dest sexp
+
| Texp_apply (f, exp_l) ->
- let sl' = exp_l
+ 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 = exp_l
+ let sl_clean = exp_l
|> List.map (fun (_, eo, _) -> match eo with
- | one -> out_of_scope loc "optional apply arguments"
- | Some ei -> js_of_expression ei) in
- let se = js_of_expression f in
- if is_infix f sl' && List.length exp_l = 2
- then ppf_apply_infix se (List.hd sl) (List.hd (List.tl sl))
- else ppf_apply se (String.concat ", " sl)
+ | None -> out_of_scope loc "optional apply arguments"
+ | Some ei -> ei) in
+ let sl = sl_clean |> List.map (fun ei -> js_of_expression_inline_or_wrap ctx ei) in
+ let se = js_of_expression_inline_or_wrap ctx f in
+ let sexp =
+ if is_infix f sl' && List.length exp_l = 2
+ then ppf_apply_infix se (List.hd sl) (List.hd (List.tl sl))
+ else ppf_apply se (String.concat ", " sl)
+ in
+ apply_dest dest sexp
| Texp_match (exp, l, [], Total) ->
- let se = js_of_expression exp in
- let sb = String.concat "@," (List.map (fun x -> js_of_branch x se) l) in
+ reject_inline dest;
+ let (sintro, seobj) =
+ match exp.exp_desc with
+ | Texp_ident (_, ident, _) ->
+ "", (js_of_longident ident)
+ | _ -> (* generate var id = sexp; *)
+ let id = id_fresh "_switch_arg_" in
+ let sdecl = js_of_expression (Dest_assign id) ctx exp in
+ sdecl, id
+ in
+ let sb = String.concat "@," (List.map (fun b -> js_of_branch ctx dest b seobj) l) in
let const = exp_type_is_constant exp in
- ppf_match se sb const
+ let sexp = ppf_match se sb const in
+ apply_dest dest sexp
| Texp_tuple (tl) ->
- ppf_tuple @@ show_list_f (fun exp -> js_of_expression exp) ", " tl
+ let sexp = ppf_tuple @@ show_list_f (fun exp -> js_of_expression_inline_or_wrap ctx exp) ", " tl in
+ apply_dest dest sexp
| Texp_construct (_, cd, el) ->
let name = cd.cstr_name in
- if el = [] then (* Constructor has no parameters *)
- if is_sbool name then name (* Special case true/false to their JS natives *)
- else ppf_single_cstrs name
- else (* Constructor has parameters *)
- let expr_strs = List.map (fun exp -> js_of_expression exp) el in
- let expanded_constructors = map_cstr_fields ~loc ppf_cstr cd expr_strs in
- ppf_multiple_cstrs name (show_list ", " expanded_constructors)
+ let sexp =
+ if el = [] then (* Constructor has no parameters *)
+ if is_sbool name then name (* Special case true/false to their JS natives *)
+ else ppf_single_cstrs name
+ else (* Constructor has parameters *)
+ let expr_strs = List.map (fun exp -> js_of_expression_inline_or_wrap ctx exp) el in
+ let expanded_constructors = map_cstr_fields ~loc ppf_cstr cd expr_strs in
+ ppf_multiple_cstrs name (show_list ", " expanded_constructors)
+ in
+ apply_dest dest sexp
| Texp_array (exp_l) -> ppf_array @@ show_list_f (fun exp -> js_of_expression exp) ", " exp_l
| Texp_ifthenelse (e1, e2, None) -> ppf_ifthen (js_of_expression e1) (js_of_expression e2)
@@ -435,7 +509,7 @@ and js_of_longident loc =
and ident_of_pat pat = match pat.pat_desc with
| Tpat_var (id, _) -> ppf_ident id
- | Tpat_any -> ""
+ | 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 *)
@@ -516,17 +590,6 @@ example:
case => bound variables + name of new ctx
-----
-function(x,y) {
- [isnertEnterCode(bindings,ctx,newctx)]fdqfdsf
- }
-
-TOKEN(432423);
-
-var newctx = ctx_push(bindings);
-logEvent(LINEOF(432423), newctx, "enter")
-----
-