From de153bc8531334287d606ce368e5663454a18a12 Mon Sep 17 00:00:00 2001
From: Thomas Wood <thomas.wood09@imperial.ac.uk>
Date: Wed, 23 Sep 2015 16:48:07 +0100
Subject: [PATCH] Kill off custom type attribute storage
---
generator/attributes.ml | 21 ++++----
generator/js_of_ast.ml | 103 +++++++---------------------------------
2 files changed, 28 insertions(+), 96 deletions(-)
diff --git a/generator/attributes.ml b/generator/attributes.ml
index b6ab348..55ef5bc 100644
--- a/generator/attributes.ml
+++ b/generator/attributes.ml
@@ -1,23 +1,16 @@
open Asttypes
open Parsetree
open Typedtree
+open Types
open Mytools
-let rec extract_cstr_attrs (cstr : Typedtree.constructor_declaration) =
- let cstr_name = Ident.name cstr.cd_id in
- let cstr_params = extract_attrs cstr.cd_attributes
- in (cstr_name, cstr_params)
-
-and extract_vb_attrs (vb : Typedtree.value_binding) =
- extract_attrs vb.vb_attributes
-
-and extract_attrs attrs =
+let rec extract_attrs attrs =
attrs
|> List.map extract_attr
|> List.flatten
and extract_attr (_, pl) = extract_payload pl
-
+
and extract_payload = function
| PStr s -> extract_structure s
| PTyp _ -> error "Type found. A tuple or a single value was expected"
@@ -90,3 +83,11 @@ and extract_constant = function
| Const_int32 _ -> error "A string or a char was expected but a int32 was found"
| Const_int64 _ -> error "A string or a char was expected but a int64 was found"
| Const_nativeint _ -> error "A string or a char was expected but a nativeint was found"
+
+let extract_cstr_attrs (cstr : constructor_declaration) =
+ let cstr_name = Ident.name cstr.cd_id in
+ let cstr_params = extract_attrs cstr.cd_attributes
+ in (cstr_name, cstr_params)
+
+let extract_vb_attrs (vb : Typedtree.value_binding) =
+ extract_attrs vb.vb_attributes
diff --git a/generator/js_of_ast.ml b/generator/js_of_ast.ml
index 91ddafd..2b672eb 100644
--- a/generator/js_of_ast.ml
+++ b/generator/js_of_ast.ml
@@ -14,13 +14,6 @@ open Typedtree
let hashtbl_size = 256
-(* val type_tbl : (string, string list * string list) Hashtbl.t
- * Mapping constructor names to a pair of module list and constructor names list *)
-let type_tbl = Hashtbl.create hashtbl_size
-(* Hard-code the special-syntax of the list datatype *)
-let _ = Hashtbl.add type_tbl "[]" ([], [])
-let _ = Hashtbl.add type_tbl "::" ([], ["head"; "tail"])
-
let record_tbl = Hashtbl.create hashtbl_size
let module_list = ref []
let module_code = ref []
@@ -30,28 +23,6 @@ module L = Logged (Token_generator) (struct let size = 256 end)
(**
* Debug-purpose functions
*)
-
-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 (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)
@@ -236,45 +207,6 @@ 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)
-
-
-(**
- * 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)
-
-(* string -> string list
- * Appears to return the name annotations of a type definition *)
-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 (); *)
- match candidates with
- | [] -> print_type_tbl (); failwith ("no options for constructor " ^ name)
- | c :: [] -> snd c
- | _ -> print_type_tbl (); failwith ("ambiguity when applying constructor " ^ name)
(**
* Module managment part
@@ -326,10 +258,7 @@ and js_of_structure_item ?(mod_gen=[]) old_env s =
| Tstr_type tl ->
let create_type x =
(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) -> add_type mod_gen name cstrs_name) cl;
- (* print_type_tbl () *)
+ | Ttype_variant cdl -> () (* Do nothing, now using typedtree defs *)
| Ttype_record ldl ->
(* Beware silent shadowing for record labels *)
List.iter (fun lbl -> Hashtbl.replace record_tbl (Ident.name lbl.ld_id) (Ident.name x.typ_id)) ldl
@@ -402,24 +331,26 @@ and js_of_expression ?(mod_gen=[]) old_env e =
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)
+
| Texp_match (exp, l, [], Total) ->
let se = js_of_expression ~mod_gen new_env exp in
let sb = String.concat "@," (List.map (fun x -> js_of_branch ~mod_gen old_env x se) l) in
ppf_match se sb
- | Texp_tuple (tl) -> ppf_tuple @@ show_list_f (fun exp -> js_of_expression ~mod_gen new_env exp) ", " tl
+
+ | Texp_tuple (tl) -> ppf_tuple @@ show_list_f (fun exp -> js_of_expression ~mod_gen new_env exp) ", " tl
+
| Texp_construct (loc, cd, el) ->
- let value = js_of_longident loc in
- if el = [] then
- if is_sbool value
- then value
- else ppf_single_cstrs value
- else
- let rec expand_constructor_list fields exprs = match fields, exprs with
- | [], [] -> []
- | [], x :: xs | x :: xs , [] -> error ~loc:locn "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 = 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)))
+ let name = js_of_longident loc 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 fields = extract_attrs cd.cstr_attributes in
+ let expr_strs = List.map (fun exp -> js_of_expression ~mod_gen new_env exp) el in
+ let expand_constructor_list = List.map2 ppf_cstr in
+ let expanded_constructors = expand_constructor_list fields expr_strs in
+ ppf_multiple_cstrs name (show_list ", " expanded_constructors)
+
| 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)
| Texp_ifthenelse (e1, e2, Some e3) -> ppf_ifthenelse (js_of_expression ~mod_gen new_env e1) (js_of_expression ~mod_gen new_env e2) (js_of_expression ~mod_gen new_env e3)
@@ -487,7 +418,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 = find_type c in
+ let params = extract_attrs cd.cstr_attributes in
let binders =
if List.length el = 0 then ""
else Printf.sprintf "@[<v 0>%s@]"
--
GitLab