diff --git a/jscomp/syntax/ast_attributes.ml b/jscomp/syntax/ast_attributes.ml index b2d15b613f7..1ec17c3dea7 100644 --- a/jscomp/syntax/ast_attributes.ml +++ b/jscomp/syntax/ast_attributes.ml @@ -101,7 +101,7 @@ let process_attributes_rev (attrs : t) = st, attr::acc ) ( `Nothing, []) attrs -let process_class_type_decl_rev attrs = +let process_bs attrs = List.fold_left (fun (st, acc) (({txt; loc}, _) as attr : attr) -> match txt, st with | "bs", _ diff --git a/jscomp/syntax/ast_attributes.mli b/jscomp/syntax/ast_attributes.mli index 486f1d19131..9636b74b720 100644 --- a/jscomp/syntax/ast_attributes.mli +++ b/jscomp/syntax/ast_attributes.mli @@ -35,7 +35,7 @@ val process_method_attributes_rev : val process_attributes_rev : t -> [ `Meth_callback | `Nothing | `Uncurry | `Method ] * t -val process_class_type_decl_rev : +val process_bs : t -> [ `Nothing | `Has] * t val process_external : t -> bool diff --git a/jscomp/syntax/ast_core_type.ml b/jscomp/syntax/ast_core_type.ml index 312f58884c5..cca12bf516b 100644 --- a/jscomp/syntax/ast_core_type.ml +++ b/jscomp/syntax/ast_core_type.ml @@ -150,3 +150,6 @@ let from_labels ~loc tyvars (labels : string list) (fun label tyvar acc -> Typ.arrow ~loc label tyvar acc) labels tyvars result_type +let make_obj ~loc xs = + Ast_comb.to_js_type loc @@ + Ast_helper.Typ.object_ ~loc xs Closed diff --git a/jscomp/syntax/ast_core_type.mli b/jscomp/syntax/ast_core_type.mli index a0a04e64b69..1f60fde07fa 100644 --- a/jscomp/syntax/ast_core_type.mli +++ b/jscomp/syntax/ast_core_type.mli @@ -57,3 +57,7 @@ val string_type : t -> arg_type val from_labels : loc:Location.t -> t list -> string list -> t +val make_obj : + loc:Location.t -> + (string * Parsetree.attributes * t) list -> + t diff --git a/jscomp/syntax/ast_external.mli b/jscomp/syntax/ast_external.mli index 9821bab55b6..65aae3a6914 100644 --- a/jscomp/syntax/ast_external.mli +++ b/jscomp/syntax/ast_external.mli @@ -29,7 +29,7 @@ val create_local_external : Location.t -> pval_type:Parsetree.core_type -> ?local_module_name:string -> ?local_fun_name:string -> - (Asttypes.label * Parsetree.expression) list -> Parsetree.expression_desc + (string * Parsetree.expression) list -> Parsetree.expression_desc val local_extern_cont : Location.t -> diff --git a/jscomp/syntax/ast_external_attributes.ml b/jscomp/syntax/ast_external_attributes.ml index 7fb9baba80e..1087118a7c9 100644 --- a/jscomp/syntax/ast_external_attributes.ml +++ b/jscomp/syntax/ast_external_attributes.ml @@ -433,8 +433,7 @@ let handle_attributes | Obj_create arg_labels , {ptyp_desc = Ptyp_any; _} -> let result = - Ast_comb.to_js_type loc @@ - Ast_helper.Typ.object_ ~loc ( + Ast_core_type.make_obj ~loc ( List.fold_right2 (fun arg label acc -> match arg, label with | (_, ty), Ast_core_type.Label s @@ -451,7 +450,7 @@ let handle_attributes | _ -> assert false end | (_, _), Ast_core_type.Empty -> acc - ) arg_types_ty arg_labels []) Closed in + ) arg_types_ty arg_labels []) in Ast_core_type.replace_result type_annotation result | _, _ -> type_annotation) , (match ffi , prim_name with diff --git a/jscomp/syntax/ast_util.ml b/jscomp/syntax/ast_util.ml index 92a2e00b484..19ae1b4e5f9 100644 --- a/jscomp/syntax/ast_util.ml +++ b/jscomp/syntax/ast_util.ml @@ -370,6 +370,135 @@ let handle_raw_structure loc payload = end +(* let method_type_of_method (e : Parsetree.expression) = *) +(* match e.pexp_desc with *) +(* | Pexp_function (arg, body) -> *) +(* arrow ~loc *) +(* | Pexp_fun *) + +(* | _ -> *) +(** Attention: we should avoid type variable conflict for each method *) +(* Since the method name is unique, there would be no conflict *) +(* Note mapper is only for API compatible *) +let self_type loc = Typ.var ~loc "self_type" + +let generate_callback_method_pair loc + (mapper : Ast_mapper.mapper) method_name arity + : (Ast_core_type.t * Ast_core_type.t) = + let result = Typ.var ~loc method_name in + let tyvars = + Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i)) + in + let self_type = self_type loc in + if arity = 0 then + to_method_type loc mapper "" (Ast_literal.type_unit ~loc ()) result , + to_method_callback_type loc mapper "" self_type result + else + begin match tyvars with + | x :: rest -> + let method_rest = + List.fold_right (fun v acc -> Typ.arrow ~loc "" v acc) rest result in + (to_method_type loc mapper "" x method_rest, + to_method_callback_type loc mapper "" self_type + (Typ.arrow ~loc "" x method_rest)) + | _ -> assert false + end + +let arity_of_method_fun + (pat : Parsetree.pattern) + (e : Parsetree.expression) = + let rec aux (e : Parsetree.expression) = + match e.pexp_desc with + | Pexp_fun ("", None, pat, e) -> + 1 + aux e + | Pexp_fun _ + -> Location.raise_errorf ~loc:e.pexp_loc "Lable is not allowed in JS object" + | _ -> 0 in + (match pat.ppat_desc with + | Ppat_construct ({txt = Lident "()"}, None) + -> 0 + | _ -> 1 ) + aux e + +let ocaml_obj_as_js_object + loc (mapper : Ast_mapper.mapper) + (self_pat : Parsetree.pattern) + (clfs : Parsetree.class_field list) = + + let (labels, label_types, method_types, exprs) = + List.fold_right + (fun (x : Parsetree.class_field) + (labels, + label_types, + method_types, + exprs) -> + match x.pcf_desc with + | Pcf_method ( + label, + _private_flag, + Cfk_concrete + (_override_flag, + ( + { + pexp_desc = + Pexp_poly + (({pexp_desc = Pexp_fun ("", None, pat, e)} as f), + None)})) + ) + -> + let arity = arity_of_method_fun pat e in + let method_type, label_type = + generate_callback_method_pair x.pcf_loc mapper label.txt arity in + (label::labels, + label_type::label_types, + method_type :: method_types, + {f with + pexp_desc = + let f = + match pat.ppat_desc with + | Ppat_construct ({txt = Lident "()"}, None) -> e + | _ -> f in + to_method_callback loc mapper self_pat f + } :: exprs) + | Pcf_method _ + | Pcf_inherit _ + | Pcf_val _ + | Pcf_initializer _ + | Pcf_attribute _ + | Pcf_extension _ + | Pcf_constraint _ -> + Location.raise_errorf + ~loc:x.pcf_loc "Only method support currently" + ) clfs ([], [], [], []) in + let result_type = + Typ.alias ~loc (Ast_core_type.make_obj ~loc + (List.map2 (fun label method_type -> + label.Asttypes.txt , [], method_type + ) labels method_types)) "self_type" in + let pval_type = + List.fold_right2 + (fun label label_type acc -> + Typ.arrow + ~loc:label.Asttypes.loc + label.Asttypes.txt + label_type acc + ) labels label_types result_type in + let pval_attributes = Ast_attributes.bs_obj pval_type in + let local_fun_name = "mk" in + let pval_type, pval_prim = + Ast_external_attributes.handle_attributes_as_string + loc + local_fun_name + pval_type pval_attributes "" in + Ast_external.local_extern_cont + loc + ~pval_attributes + ~pval_prim + ~local_fun_name + (fun e -> + Exp.apply ~loc e + (List.map2 (fun l expr -> l.Asttypes.txt, expr) labels exprs) ) + ~pval_type + let record_as_js_object loc (self : Ast_mapper.mapper) diff --git a/jscomp/syntax/ast_util.mli b/jscomp/syntax/ast_util.mli index d0370049709..479fdab6816 100644 --- a/jscomp/syntax/ast_util.mli +++ b/jscomp/syntax/ast_util.mli @@ -118,3 +118,8 @@ val handle_raw : val handle_raw_structure : loc -> Ast_payload.t -> Parsetree.structure_item + +val ocaml_obj_as_js_object : + (Parsetree.pattern -> + Parsetree.class_field list -> + Parsetree.expression_desc) cxt diff --git a/jscomp/syntax/ppx_entry.ml b/jscomp/syntax/ppx_entry.ml index e7e0e4c68fb..85651e38a79 100644 --- a/jscomp/syntax/ppx_entry.ml +++ b/jscomp/syntax/ppx_entry.ml @@ -446,13 +446,25 @@ let rec unsafe_mapper : Ast_mapper.mapper = } else Ast_mapper.default_mapper.expr self e + | Pexp_object {pcstr_self; pcstr_fields} -> + begin match Ast_attributes.process_bs e.pexp_attributes with + | `Has, pexp_attributes + -> + {e with + pexp_desc = + Ast_util.ocaml_obj_as_js_object + loc self pcstr_self pcstr_fields; + pexp_attributes + } + | `Nothing , _ -> + Ast_mapper.default_mapper.expr self e + end | _ -> Ast_mapper.default_mapper.expr self e ); typ = (fun self typ -> handle_typ Ast_mapper.default_mapper self typ); class_type = (fun self ({pcty_attributes} as ctd) -> - match Ast_attributes.process_class_type_decl_rev - pcty_attributes with + match Ast_attributes.process_bs pcty_attributes with | `Nothing, _ -> Ast_mapper.default_mapper.class_type self ctd diff --git a/jscomp/test/.depend b/jscomp/test/.depend index ddb1511ba95..7f92a7b1b40 100644 --- a/jscomp/test/.depend +++ b/jscomp/test/.depend @@ -434,6 +434,8 @@ polyvar_test.cmj : ../runtime/js.cmj polyvar_test.cmx : ../runtime/js.cmx ppx_apply_test.cmj : mt.cmi ppx_apply_test.cmx : mt.cmx +ppx_this_obj.cmj : mt.cmi +ppx_this_obj.cmx : mt.cmx pq_test.cmj : pq_test.cmx : pr6726.cmj : @@ -1182,6 +1184,8 @@ polyvar_test.cmo : ../runtime/js.cmo polyvar_test.cmj : ../runtime/js.cmj ppx_apply_test.cmo : mt.cmi ppx_apply_test.cmj : mt.cmj +ppx_this_obj.cmo : mt.cmi +ppx_this_obj.cmj : mt.cmj pq_test.cmo : pq_test.cmj : pr6726.cmo : diff --git a/jscomp/test/Makefile b/jscomp/test/Makefile index 340ee58862d..b90a6fc4c1a 100644 --- a/jscomp/test/Makefile +++ b/jscomp/test/Makefile @@ -58,7 +58,8 @@ OTHERS := a test_ari test_export2 test_internalOO test_obj_simple_ffi test_scope mutual_non_recursive_type external_ppx \ optional_ffi_test poly_variant_test \ bs_rest_test infer_type_test fs_test module_as_function\ - test_case_set test_mutliple string_bound_get_test inline_string_test + test_case_set test_mutliple string_bound_get_test inline_string_test\ + ppx_this_obj SOURCE_LIST := js_dyn $(OTHERS) diff --git a/jscomp/test/ppx_this_obj.js b/jscomp/test/ppx_this_obj.js new file mode 100644 index 00000000000..2b645bd72a9 --- /dev/null +++ b/jscomp/test/ppx_this_obj.js @@ -0,0 +1,54 @@ +'use strict'; + +var Mt = require("./mt"); +var Block = require("../../lib/js/block"); + +var suites = [/* [] */0]; + +var test_id = [0]; + +function eq(loc, param) { + var y = param[1]; + var x = param[0]; + test_id[0] = test_id[0] + 1 | 0; + suites[0] = /* :: */[ + /* tuple */[ + loc + (" id " + test_id[0]), + function () { + return /* Eq */Block.__(0, [ + x, + y + ]); + } + ], + suites[0] + ]; + return /* () */0; +} + +var v = { + x: function () { + return 3; + }, + say: function (x) { + var self = this ; + return x * self.x(); + }, + hi: function (x, y) { + var self = this ; + return self.say(x) + y; + } +}; + +eq('File "ppx_this_obj.ml", line 25, characters 5-12', /* tuple */[ + 11, + v.hi(3, 2) + ]); + +Mt.from_pair_suites("ppx_this_obj.ml", suites[0]); + +exports.suites = suites; +exports.test_id = test_id; +exports.eq = eq; +exports.v = v; +/* v Not a pure module */ diff --git a/jscomp/test/ppx_this_obj.ml b/jscomp/test/ppx_this_obj.ml new file mode 100644 index 00000000000..8465eefbc5c --- /dev/null +++ b/jscomp/test/ppx_this_obj.ml @@ -0,0 +1,27 @@ +let suites : Mt.pair_suites ref = ref [] +let test_id = ref 0 +let eq loc (x, y) = + incr test_id ; + suites := + (loc ^" id " ^ (string_of_int !test_id), (fun _ -> Mt.Eq(x,y))) :: !suites + +let v = + let x = 3. in + object (self) + method x () = x + method say x = x *. self## x () + method hi x y = self##say x +. y + end [@bs] +(** compile infer +class type js_obj = object + method x : unit -> float + method say : float -> float + method hi : float -> float -> float +end [@bs] +val js_obj : js_obj Js.t +*) + +let () = + eq __LOC__ (11., v##hi 3. 2.) + +let () = Mt.from_pair_suites __FILE__ !suites diff --git a/jscomp/test/unsafe_obj_external.js b/jscomp/test/unsafe_obj_external.js index c48bf051090..ebe601800a5 100644 --- a/jscomp/test/unsafe_obj_external.js +++ b/jscomp/test/unsafe_obj_external.js @@ -1,4 +1,4 @@ -// GENERATED CODE BY BUCKLESCRIPT VERSION 0.9.0 , PLEASE EDIT WITH CARE +// GENERATED CODE BY BUCKLESCRIPT VERSION 0.9.1 , PLEASE EDIT WITH CARE 'use strict'; diff --git a/jscomp/test/unsafe_obj_external.ml b/jscomp/test/unsafe_obj_external.ml index 010823b3588..251999f09b6 100644 --- a/jscomp/test/unsafe_obj_external.ml +++ b/jscomp/test/unsafe_obj_external.ml @@ -4,7 +4,6 @@ external config : x : ('self_type -> 'x [@bs.this]) -> say :('self_type -> 'x -> 'say [@bs.this]) -> - unit -> (< x : unit -> 'x [@bs.meth]; say : 'x -> 'say [@bs.meth] @@ -16,12 +15,12 @@ let v = config ~x:(fun [@bs.this] _ -> x ) ~say:(fun [@bs.this] self x -> self##x () + x) - () + (** let x = 3 in object (self : 'self_type) - method x = x + method x () = x method say x = self##x + x end [@bs] *)