From ecf5362716cee629a4b71d4d19127562d0f0dc9f Mon Sep 17 00:00:00 2001
From: lithrein <lithrein.site@gmail.com>
Date: Wed, 17 Jun 2015 17:55:04 +0200
Subject: [PATCH] Eventually the hashtable contains only the constructors, the
type is still accessible in the second part of the stored tuple
---
generator/js_of_ast.ml | 45 ++++++++++++++++++++++--------------------
1 file changed, 24 insertions(+), 21 deletions(-)
diff --git a/generator/js_of_ast.ml b/generator/js_of_ast.ml
index b173972..4c17c4c 100644
--- a/generator/js_of_ast.ml
+++ b/generator/js_of_ast.ml
@@ -12,19 +12,13 @@ open Lexing
let hashtlb_size = 256
let default_value = ["", [""]]
let type_tbl = Hashtbl.create hashtlb_size;;
-(*Hashtbl.add type_tbl "" default_value;;*)
let print_tbl () =
- let rec print_elem = function
- | [] -> ""
- | (cstr, params) :: [] -> Format.sprintf {|"%s": [%s]|} cstr (print_str_list params)
- | (cstr, params) :: xs -> (Format.sprintf {|"%s": [%s], |} cstr (print_str_list params)) ^ print_elem xs
- and print_str_list = function
+ let rec print_str_list = function
| [] -> ""
| x :: [] -> (Format.sprintf {|"%s"|} x)
| x :: xs -> (Format.sprintf {|"%s", |} x) ^ print_str_list xs
- in Hashtbl.iter (fun key elem -> Printf.printf {|"%s" -> [%s]
-|} key (print_elem elem)) type_tbl; ()
+ in Hashtbl.iter (fun cstr elems -> Printf.printf ({|"%s" : %s -> [%s]|} ^^ "\n") cstr (snd elems) (print_str_list (fst elems))) type_tbl; ()
let unsupported s =
failwith ("unsupported language construction: " ^ s ^ ".")
@@ -67,11 +61,15 @@ let ident_of_pat pat = match pat.pat_desc with
let rec js_of_let_pattern pat expr =
let expr_type pat expr = match expr.exp_desc with
| Texp_construct (loc, cd, el) ->
+ let value = js_of_longident loc in
if el = [] then
- let value = js_of_longident loc in
- if value = "true" || value = "false" then value
- else Format.sprintf "{tag: \"%s\", val: \"%s\"}" value value
- else out_of_scope "Constructor with more than one value"
+ if value = "true" || value = "false" then value else Format.sprintf {|{tag: "%s"}|} value
+ else let rec expand_constructor_list fields exprs = match fields, exprs with
+ | [], [] -> []
+ | [], x :: xs | x :: xs , [] -> failwith "argument lists should have the same length."
+ | x :: xs, y :: ys -> Format.sprintf {|%s: %s|} x y :: expand_constructor_list xs ys
+ in let names, typ = Hashtbl.find type_tbl value
+ in Format.sprintf {|{tag: "%s", %s}|} value (show_list ", " (expand_constructor_list names (List.map js_of_expression el)))
| _ -> string_of_type_exp pat.pat_type in
let sexpr = js_of_expression expr in
match pat.pat_desc with
@@ -158,10 +156,15 @@ and js_of_expression (e:expression) =
| Texp_tuple (tl) ->
"[" ^ show_list_f js_of_expression ", " tl ^ "]"
| Texp_construct (loc, cd, el) -> (*TODO: Modifs*)
- let c = js_of_longident loc in
- if el = [] then "\"" ^ c ^ "\""
- else if List.length el = 1 then (js_of_expression (List.hd el))
- else Format.sprintf "%s (%s)" c @@ show_list_f js_of_expression ", " el
+ let value = js_of_longident loc in
+ if el = [] then
+ if value = "true" || value = "false" then value else Format.sprintf {|{tag: "%s"}|} value
+ else let rec expand_constructor_list fields exprs = match fields, exprs with
+ | [], [] -> []
+ | [], x :: xs | x :: xs , [] -> failwith "argument lists should have the same length."
+ | x :: xs, y :: ys -> (if y = "" then Format.sprintf {|%s|} x else Format.sprintf {|%s: %s|} x y) :: expand_constructor_list xs ys
+ in let names, typ = Hashtbl.find type_tbl value
+ in Format.sprintf {|{tag: "%s", %s}|} value (show_list ", " (expand_constructor_list names (List.map js_of_expression el)))
| Texp_variant (_,_) -> ""(* Nothing to do *)
| Texp_record (_, _) -> failwith "not implemented yet"
| Texp_field (_,_,_) -> failwith "not implemented yet"
@@ -225,14 +228,14 @@ and js_of_structure_item s = match s.str_desc with
| Ttype_variant cdl ->
let rec explore_cstrs = function
| [] -> []
- | x :: xs -> let extract_attrs = function
+ | y :: ys -> let extract_attrs = function
| [] -> [""]
- | x :: [] -> extract_payload (snd x)
- | x :: xs -> out_of_scope "multiples attributes on type declarations" in
- (Ident.name x.cd_id, extract_attrs x.cd_attributes) :: explore_cstrs xs
+ | z :: [] -> extract_payload (snd z)
+ | z :: zs -> out_of_scope "multiples attributes on type declarations" in
+ Hashtbl.add type_tbl (Ident.name y.cd_id) ((extract_attrs y.cd_attributes), Ident.name x.typ_id); explore_cstrs ys;
in explore_cstrs cdl
| _ -> unsupported "records") in
- List.iter (fun elt -> Hashtbl.add type_tbl (Ident.name elt.typ_id) (explore_type tl)) tl; print_tbl (); ""
+ explore_type tl; print_tbl (); ""
| Tstr_primitive _ -> out_of_scope "primitive functions"
| Tstr_typext _ -> out_of_scope "type extensions"
| Tstr_exception _ -> out_of_scope "exceptions"
--
GitLab