Skip to content
Snippets Groups Projects
Commit 516425a2 authored by Paul Iannetta's avatar Paul Iannetta Committed by Thomas Wood
Browse files

Progress with module support 

1. Now, the call to ./main.byte produces three files:
        - a (buggy) logged version
        - a version without annotation
        - the Format that is being used (for debug purpose).

2. Modules are quite soapy to handle:
        - Name shadowing (supported).
        - Inclusion of opened modules (no log information is
                included)
        - Accessed but not opened modules (kind of break the
                default parameters handled with attributes).
parent d72bbae3
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
generator/js_of_ast.ml
+ 105
− 40
View file @ 516425a2
......@@ -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@]"
......
generator/log.ml
+ 2
− 1
View file @ 516425a2
......@@ -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;
......
generator/main.ml
+ 8
− 4
View file @ 516425a2
......@@ -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;
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment