diff --git a/generator/js_of_ast.ml b/generator/js_of_ast.ml
index d6b15f6484a3c883a178f1d3b7789a6b8184d66e..8174cc98370439f7fb1c73c6be9a857b943bd71a 100755
--- a/generator/js_of_ast.ml
+++ b/generator/js_of_ast.ml
@@ -25,13 +25,27 @@ module L = Logged (Token_generator) (struct let size = 256 end)
*)
let print_type_tbl () =
+ let assemble (l, n) =
+ let rec aux = function
+ | [] -> n
+ | x :: xs -> x ^ "." ^ aux xs
+ in aux l in
let rec print_str_list = function
| [] -> ""
| x :: [] -> (Printf.sprintf {|"%s"|} x)
| x :: xs -> (Printf.sprintf {|"%s", |} x) ^ print_str_list xs
- in Hashtbl.iter (fun cstr elems -> Printf.printf ({|%s -> [%s]|} ^^ "\n") cstr (print_str_list elems)) type_tbl; ()
+ in Hashtbl.iter (fun cstr (mods, elems) -> Printf.printf ({|%s -> [%s]|} ^^ "\n") (assemble (mods, cstr)) (print_str_list elems)) type_tbl; ()
+let print_candidates l =
+let rec print_str_list = function
+ | [] -> ""
+ | x :: xs -> Printf.sprintf "%s " x ^ print_str_list xs in
+let rec aux = function
+ | [] -> ""
+ | (x, y) :: xs -> "[" ^ print_str_list x ^ ", " ^ print_str_list y ^ "]" ^ " ; " ^ aux xs
+in aux l
+
let env_diff_names env1 env2 =
List.map Ident.unique_name (Env.diff env1 env2)
@@ -89,6 +103,20 @@ let unzip l =
| (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
+
let is_infix f args = match args with
| _ :: [] | [] -> false
| x :: xs ->
@@ -103,7 +131,7 @@ let is_infix f args = match args with
*)
let ppf_lambda_wrap s =
- Printf.sprintf "(function () {@;<1 2>@[<v 0>%s@]@,}())" s
+ Printf.sprintf "(function () {@;<1 2>@[<v 0>%s@]@,}())@," s
let ppf_branch case binders expr =
Printf.sprintf "%s: @[<v 0>%s@,return %s;@]"
@@ -116,15 +144,15 @@ let ppf_let_in decl exp =
in ppf_lambda_wrap s
let ppf_function args body=
- Printf.sprintf "function (%s) {@;<1 2>@[<v 0>return %s;@]@,}"
+ Printf.sprintf "function (%s) {@;<1 2>@[<v 0>return %s;@]@,}@,"
args body
let ppf_apply f args =
- Printf.sprintf "@[<v 0>%s(%s)@]"
+ Printf.sprintf "%s(%s)"
f args
let ppf_apply_infix f arg1 arg2 =
- Printf.sprintf "@[<v 0>%s %s %s@]"
+ Printf.sprintf "%s %s %s"
arg1 f arg2
let ppf_match value cases =
@@ -134,26 +162,26 @@ let ppf_match value cases =
in ppf_lambda_wrap s
let ppf_array values =
- Printf.sprintf "@[<v 0>[%s]@]"
+ Printf.sprintf "[%s]"
values
let ppf_tuple = ppf_array
let ppf_ifthen cond iftrue =
- Printf.sprintf "(function () {@,@,@[<v 2>@,if (%s) {@,@[<v 2>@,return %s;@]@,}@]@,})()"
+ Printf.sprintf "(function () {@;<1 2>@[<v 2>@,if (%s) {@,return %s;@,}@]@,})()"
cond iftrue
let ppf_ifthenelse cond iftrue iffalse =
- Printf.sprintf "(function () {@,@,@[<v 2>@,if (%s) {@,@[<v 2>@,return %s;@]@,} else {@,@[<v 2>@,return %s;@]@,}@]@,})()"
+ Printf.sprintf "(function () {@;<1 2>@[<v 2>@,if (%s) {@,return %s;@,} else {@,return %s;@,}@]@,})()"
cond iftrue iffalse
let ppf_sequence exp1 exp2 =
- Printf.sprintf "return %s,@,%s"
+ Printf.sprintf "%s,@,%s"
exp1 exp2
let ppf_while cd body =
let s =
- Printf.sprintf "@[<v 0>@,while(%s) {@,@[<v 2>@,%s@]@,}@]"
+ Printf.sprintf "@[<v 2>while(%s) {@;<1 2>%s@,@]}"
cd body
in ppf_lambda_wrap s
@@ -165,7 +193,7 @@ let ppf_for id start ed flag body =
| Upto -> "<="
| Downto -> ">=" in
let s =
- Printf.sprintf "[<v 0>@,for (%s = %s ; %s %s %s ; %s%s) {@,@[<v 2>@,%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
@@ -178,33 +206,68 @@ let ppf_cstr tag value =
tag value
let ppf_single_cstrs typ =
- Printf.sprintf "@[<v 0>{type: \"%s\"}@]"
+ Printf.sprintf "@[<v 2>{type: \"%s\"}@]"
typ
let ppf_multiple_cstrs typ rest =
- Printf.sprintf "@[<v 0>{type: \"%s\", @[<v 2>%s@]}@]"
+ Printf.sprintf "@[<v 2>{type: \"%s\", %s}@]"
typ rest
let ppf_record llde =
let rec aux acc = function
- | [] -> Printf.sprintf "@[<v 0>{@,@[<v 2>@,%s@,@]}@]" acc
+ | [] -> Printf.sprintf "@[<v 2>{@;<1 2>%s@]@,}" 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_decl ?(mod_gen="") id expr =
- let assign_op, decl_kw, end_mark = if mod_gen = "" then " = ", "var ", ";" else ": ", "", "," in
- Printf.sprintf "@[<v 0>%s%s%s%s%s@,@]"
- decl_kw id assign_op expr end_mark
+let ppf_decl ?(mod_gen=[]) id expr =
+ let assign_op, decl_kw, end_mark = if mod_gen = [] then " = ", "var ", ";" else ": ", "", "," in
+ L.log_line (Printf.sprintf "@[<v 0>%s%s%s%s%s@,@]"
+ decl_kw id assign_op expr end_mark) (L.Add id)
let ppf_pat_array id_list array_expr =
- Printf.sprintf "@[<v 0>var __%s = %s;@,@]" "array" 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)
+
+(**
+ * Type managment part
+ *)
+
+let short_type_name name =
+ let len = String.length name - 1 in
+ let rec find_last_point i =
+ if i < 0 then 0
+ else if name.[i] = '.' then (succ i)
+ else find_last_point (pred i) in
+ let last_point_pos = find_last_point len in
+ String.sub name last_point_pos (len - last_point_pos + 1)
+
+let add_type mod_gen name cstrs_name =
+ Hashtbl.add type_tbl (short_type_name name) (mod_gen, cstrs_name)
+
+let find_type name =
+ let short_name = short_type_name name in
+ let find_points name =
+ let len = String.length name in
+ string_fold_righti (fun i x acc -> if x = '.' then i :: acc else
+ if i = len - 1 then i + 1 :: acc else acc) name [] in
+ let split_on_rev pos = snd @@ List.fold_left (fun (deb, acc) x -> x + 1, String.sub name deb (x - deb) :: acc) (0, []) pos in
+ let prefixes = split_on_rev @@ find_points @@ name in
+ let rec filter_on_prefixes l prefixes = match l, prefixes with
+ | _, [] -> true
+ | [], _ -> false
+ | x :: xs, y :: ys -> if x = y then filter_on_prefixes xs ys else false in
+ let tmp = Hashtbl.find_all type_tbl short_name in
+ let candidates = if List.length tmp = 1 then tmp else List.filter (fun (x, _) -> filter_on_prefixes prefixes (short_name :: x)) tmp in
+ print_string @@ print_candidates @@ (Hashtbl.find_all type_tbl short_name); print_newline ();
+ if List.length candidates = 1
+ then snd @@ List.hd candidates
+ else failwith ("ambiguity when applying constructor " ^ name)
(**
- * Module gestion part
+ * Module managment part
*)
let find_module_path mod_list =
@@ -224,37 +287,39 @@ let find_module_path mod_list =
let res = zip mod_list (prune @@ expand_names @@ mod_list)
in module_list := []; res
-let rec parse_modules = function
+let rec parse_modules ?(mod_gen=[]) = function
| [] -> []
| (name, path) :: xs ->
let ppf = Format.std_formatter in
let (opt, inputfile) = process_implementation_file ppf path in
let ((parsetree1 : Parsetree.structure), typedtree1) =
match opt with
- | None -> failwith "Could not read and typecheck input file"
+ | None -> failwith ("Could not read and typecheck " ^ inputfile)
| Some (parsetree1, (typedtree1, _)) -> parsetree1, typedtree1
in
- let (_, unlogged, _) = to_javascript ~mod_gen:name typedtree1 in
- Printf.sprintf "%s = {\n%s\n}" name unlogged :: parse_modules xs
-
+ let (_, _, pre) = to_javascript ~mod_gen:(name :: mod_gen) typedtree1 in
+ Printf.sprintf "%s = {\n%s\n}" name pre :: parse_modules ~mod_gen xs
+
(**
* Main part
*)
-and to_javascript ?(mod_gen="") typedtree =
+and to_javascript ?(mod_gen=[]) typedtree =
let pre_res = js_of_structure ~mod_gen Env.empty typedtree in
- let logged, unlogged, pre = L.logged_output pre_res, L.unlogged_output pre_res, pre_res in
- let mod_code = String.concat "\n" !module_code in
- (logged, mod_code ^ "\n" ^ unlogged, pre)
+ let mod_code = String.concat "" (List.map L.strip_log_info !module_code) in
+ let logged, unlogged, pre = L.logged_output (mod_code ^ "\n" ^ pre_res),
+ L.unlogged_output (mod_code ^ "\n" ^ pre_res),
+ (mod_code ^ "\n" ^ pre_res) in
+ (logged, unlogged, pre)
-and show_value_binding ?(mod_gen="") vb =
+and show_value_binding ?(mod_gen=[]) vb =
js_of_let_pattern ~mod_gen vb.vb_pat vb.vb_expr
-and js_of_structure ?(mod_gen="") old_env s =
+and js_of_structure ?(mod_gen=[]) old_env s =
let new_env = s.str_final_env in
show_list_f (fun strct -> js_of_structure_item ~mod_gen new_env strct) "@,@," s.str_items
-and js_of_structure_item ?(mod_gen="") old_env s =
+and js_of_structure_item ?(mod_gen=[]) old_env s =
let new_env = s.str_env in
match s.str_desc with
| Tstr_eval (e, _) -> Printf.sprintf "%s" @@ js_of_expression ~mod_gen new_env e
@@ -266,7 +331,7 @@ and js_of_structure_item ?(mod_gen="") old_env s =
(match x.typ_kind with
| Ttype_variant cdl ->
let cl = List.map (fun cstr -> extract_cstr_attrs cstr) cdl in
- List.iter (fun (name, cstrs_name) -> Hashtbl.add type_tbl (if mod_gen <> "" then mod_gen ^ "." ^ name else name) cstrs_name) cl;
+ List.iter (fun (name, cstrs_name) -> add_type mod_gen name cstrs_name) cl;
print_type_tbl ()
| Ttype_record ldl ->
(* Beware silent shadowing for record labels *)
@@ -278,7 +343,7 @@ and js_of_structure_item ?(mod_gen="") old_env s =
let name = (fun od -> if od.open_override = Fresh then js_of_longident od.open_txt else "") od in
if name <> "" then
module_list := name :: !module_list;
- module_code := parse_modules @@ find_module_path @@ !module_list @ !module_code;
+ module_code := ((fun modules -> parse_modules ~mod_gen modules) @@ find_module_path @@ !module_list) @ !module_code;
""
| Tstr_primitive _ -> out_of_scope "primitive functions"
| Tstr_typext _ -> out_of_scope "type extensions"
@@ -291,12 +356,12 @@ and js_of_structure_item ?(mod_gen="") old_env s =
| Tstr_include _ -> out_of_scope "includes"
| Tstr_attribute attrs -> out_of_scope "attributes"
-and js_of_branch ?(mod_gen="") old_env b obj =
+and js_of_branch ?(mod_gen=[]) old_env b obj =
let spat, binders = js_of_pattern ~mod_gen b.c_lhs obj in
let se = js_of_expression ~mod_gen old_env b.c_rhs in
L.log_line (ppf_branch spat binders se) (L.Add binders)
-and js_of_expression ?(mod_gen="") old_env e =
+and js_of_expression ?(mod_gen=[]) old_env e =
let new_env = e.exp_env in
match e.exp_desc with
| Texp_ident (_, loc, _) -> js_of_longident loc
@@ -339,7 +404,7 @@ and js_of_expression ?(mod_gen="") old_env e =
| [], [] -> []
| [], x :: xs | x :: xs , [] -> failwith "argument lists should have the same length."
| x :: xs, y :: ys -> (if y = "" then ppf_single_cstrs x else ppf_cstr x y) :: expand_constructor_list xs ys in
- let names = Hashtbl.find type_tbl (if mod_gen <> "" then mod_gen ^ "." ^ value else value)
+ let names = find_type value
in ppf_multiple_cstrs value (show_list ", " (expand_constructor_list names (List.map (fun exp -> js_of_expression ~mod_gen new_env exp) el)))
| Texp_array (exp_l) -> ppf_array @@ show_list_f (fun exp -> js_of_expression ~mod_gen new_env exp) ", " exp_l
| Texp_ifthenelse (e1, e2, None) -> ppf_ifthen (js_of_expression ~mod_gen new_env e1) (js_of_expression ~mod_gen new_env e2)
@@ -383,7 +448,7 @@ and ident_of_pat pat = match pat.pat_desc with
| Tpat_var (id, _) -> Ident.name id
| _ -> error "functions can't deconstruct values"
-and js_of_let_pattern ?(mod_gen="") pat expr =
+and js_of_let_pattern ?(mod_gen=[]) pat expr =
let new_env = pat.pat_env in
let sexpr = js_of_expression ~mod_gen new_env expr in
match pat.pat_desc with
@@ -399,7 +464,7 @@ and js_of_let_pattern ?(mod_gen="") pat expr =
ppf_pat_array l sexpr
| _ -> error "let can't deconstruct values"
-and js_of_pattern ?(mod_gen="") pat obj =
+and js_of_pattern ?(mod_gen=[]) pat obj =
match pat.pat_desc with
| Tpat_any -> "default", ""
| Tpat_constant c -> js_of_constant c, ""
@@ -407,7 +472,7 @@ and js_of_pattern ?(mod_gen="") pat obj =
| Tpat_construct (loc, cd, el) ->
let c = js_of_longident loc in
let spat = Printf.sprintf "%s" ("case \"" ^ c ^ "\"") in
- let params = Hashtbl.find type_tbl (if mod_gen <> "" then mod_gen ^ "." ^ c else c) in
+ let params = find_type c in
let binders =
if List.length el = 0 then ""
else Printf.sprintf "@[<v 0>%s@]"
diff --git a/generator/log.ml b/generator/log.ml
index d73439510657c33f1a79094621c54ec76b662216..94cbcc9e9e6cad66d7c5e49041fe6d3cd8ba39c6 100644
--- a/generator/log.ml
+++ b/generator/log.ml
@@ -35,6 +35,7 @@ sig
| Del of ident
val log_line : string -> ctx_operation -> string
+ val strip_log_info : string -> string
val logged_output : string -> string
val unlogged_output : string -> string
end
@@ -119,7 +120,7 @@ struct
| (None, str) :: xs -> Buffer.add_string buf str;
aux (i + 1) xs
| (Some l, str) :: xs -> let log_info = match Hashtbl.find info_tbl l with
- | Add x -> "\nprint (" ^ string_of_int i ^ " + \": Variable\" " ^ x ^ ");\n"
+ | Add x -> "\nprint (" ^ string_of_int i ^ " + \": Variable\" +" ^ x ^ ");\n"
| Redef x -> "o"
| Del x -> "a"
in Buffer.add_string buf str; Buffer.add_string buf log_info;
diff --git a/generator/main.ml b/generator/main.ml
index d5e66aae0018bf07e12e0f5f767c0ab2fd6e7449..2f78329d7c722891d5838629f2cd985ae0ba53b2 100644
--- a/generator/main.ml
+++ b/generator/main.ml
@@ -38,10 +38,12 @@ let _ =
failwith "The file name must be of the form *.ml";
let basename = Filename.chop_suffix (Filename.basename sourcefile) ".ml" in
let dirname = Filename.dirname sourcefile in
- let outputfile : string =
+ let log_output, unlog_output, pre_output =
match !outputfile with
- | None -> Filename.concat dirname (basename ^ ".js")
- | Some f -> f
+ | None -> Filename.concat dirname (basename ^ ".log.js"),
+ Filename.concat dirname (basename ^ "unlog.js"),
+ Filename.concat dirname (basename ^ ".js.pre")
+ | Some f -> f ^ ".log.js", f ^ ".unlog.js", f ^ ".js.pre"
in
(*---------------------------------------------------*)
@@ -54,4 +56,6 @@ let _ =
in
let (logged, unlogged, pre) = Js_of_ast.to_javascript typedtree1 in
- file_put_contents outputfile unlogged
+ file_put_contents log_output logged;
+ file_put_contents unlog_output unlogged;
+ file_put_contents pre_output pre;