From f4b7e5fd2e17f1a28d48c5218476f31ce074ca17 Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Tue, 9 Aug 2016 14:05:05 -0400 Subject: [PATCH 1/2] add first class js object support so people can create js object --- jscomp/syntax/ast_attributes.ml | 2 +- jscomp/syntax/ast_attributes.mli | 2 +- jscomp/syntax/ast_core_type.ml | 3 + jscomp/syntax/ast_core_type.mli | 4 + jscomp/syntax/ast_exp.ml | 25 +++++ jscomp/syntax/ast_exp.mli | 25 +++++ jscomp/syntax/ast_external.mli | 2 +- jscomp/syntax/ast_external_attributes.ml | 5 +- jscomp/syntax/ast_pat.ml | 50 +++++++++ jscomp/syntax/ast_pat.mli | 31 ++++++ jscomp/syntax/ast_util.ml | 127 ++++++++++++++++++++++- jscomp/syntax/ast_util.mli | 5 + jscomp/syntax/ppx_entry.ml | 16 ++- jscomp/syntax/syntax.mllib | 2 + jscomp/test/.depend | 4 + jscomp/test/Makefile | 3 +- jscomp/test/ppx_this_obj.js | 54 ++++++++++ jscomp/test/ppx_this_obj_test.js | 113 ++++++++++++++++++++ jscomp/test/ppx_this_obj_test.ml | 58 +++++++++++ jscomp/test/unsafe_obj_external.js | 1 - jscomp/test/unsafe_obj_external.ml | 5 +- 21 files changed, 520 insertions(+), 17 deletions(-) create mode 100644 jscomp/syntax/ast_exp.ml create mode 100644 jscomp/syntax/ast_exp.mli create mode 100644 jscomp/syntax/ast_pat.ml create mode 100644 jscomp/syntax/ast_pat.mli create mode 100644 jscomp/test/ppx_this_obj.js create mode 100644 jscomp/test/ppx_this_obj_test.js create mode 100644 jscomp/test/ppx_this_obj_test.ml diff --git a/jscomp/syntax/ast_attributes.ml b/jscomp/syntax/ast_attributes.ml index b2d15b613f..1ec17c3dea 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 486f1d1913..9636b74b72 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 312f58884c..cca12bf516 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 a0a04e64b6..1f60fde07f 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_exp.ml b/jscomp/syntax/ast_exp.ml new file mode 100644 index 0000000000..4e7e973a4f --- /dev/null +++ b/jscomp/syntax/ast_exp.ml @@ -0,0 +1,25 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type t = Parsetree.expression diff --git a/jscomp/syntax/ast_exp.mli b/jscomp/syntax/ast_exp.mli new file mode 100644 index 0000000000..4e7e973a4f --- /dev/null +++ b/jscomp/syntax/ast_exp.mli @@ -0,0 +1,25 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type t = Parsetree.expression diff --git a/jscomp/syntax/ast_external.mli b/jscomp/syntax/ast_external.mli index 9821bab55b..65aae3a691 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 7fb9baba80..1087118a7c 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_pat.ml b/jscomp/syntax/ast_pat.ml new file mode 100644 index 0000000000..274e657587 --- /dev/null +++ b/jscomp/syntax/ast_pat.ml @@ -0,0 +1,50 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + + +type t = Parsetree.pattern + + +let is_unit_cont ~yes ~no (p : t) = + match p with + | {ppat_desc = Ppat_construct({txt = Lident "()"}, None)} + -> yes + | _ -> no + + +(** [arity_of_fun pat e] tells the arity of + expression [fun pat -> e] +*) +let arity_of_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 + is_unit_cont ~yes:0 ~no:1 pat + aux e diff --git a/jscomp/syntax/ast_pat.mli b/jscomp/syntax/ast_pat.mli new file mode 100644 index 0000000000..322808fa50 --- /dev/null +++ b/jscomp/syntax/ast_pat.mli @@ -0,0 +1,31 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type t = Parsetree.pattern + +val is_unit_cont : yes:'a -> no:'a -> t -> 'a + +(** [arity_of_fun pat e] tells the arity of + expression [fun pat -> e]*) +val arity_of_fun : t -> Parsetree.expression -> int diff --git a/jscomp/syntax/ast_util.ml b/jscomp/syntax/ast_util.ml index 92a2e00b48..dcf540672b 100644 --- a/jscomp/syntax/ast_util.ml +++ b/jscomp/syntax/ast_util.ml @@ -258,11 +258,12 @@ let generic_to_uncurry_exp kind loc (self : Ast_mapper.mapper) pat body let len = List.length rev_extra_args in let arity = match kind with - | `Fn -> + | `Fn -> begin match rev_extra_args with - | [ {ppat_desc = - ( Ppat_construct ({txt = Lident "()"}, None) )}] - -> 0 + | [ p] + -> + Ast_pat.is_unit_cont ~yes:0 ~no:len p + | _ -> len end | `Method_callback -> len in @@ -369,6 +370,124 @@ let handle_raw_structure loc payload = Location.raise_errorf ~loc "bs.raw can only be applied to a string" end + +let ocaml_obj_as_js_object + loc (mapper : Ast_mapper.mapper) + (self_pat : Parsetree.pattern) + (clfs : Parsetree.class_field list) = + let self_type_lit = "self_type" in + (** 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_lit in + 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 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 + let tyvars = + Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i)) + in + 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 in + 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, + Public, + Cfk_concrete + (Fresh, e)) + -> + begin match e with + | { + pexp_desc = + Pexp_poly + (({pexp_desc = Pexp_fun ("", None, pat, e)} as f), + None)} -> + let arity = Ast_pat.arity_of_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 = Ast_pat.is_unit_cont pat ~yes:e ~no:f in + to_method_callback loc mapper self_pat f + } :: exprs) + | _ -> + Location.raise_errorf ~loc:x.pcf_loc + "polymorphic type annotation not supported" + end + | Pcf_method (_, _, Cfk_concrete(Override, _) ) -> + Location.raise_errorf ~loc:x.pcf_loc + "override flag not supported" + + | Pcf_method (_, _, Cfk_virtual _ ) + -> + Location.raise_errorf ~loc:x.pcf_loc + "virtural method not supported" + + | Pcf_method (_, Private,_ ) + -> (** TODO: support Private *) + Location.raise_errorf ~loc:x.pcf_loc + "Private method not supported yet" + | 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_lit 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 diff --git a/jscomp/syntax/ast_util.mli b/jscomp/syntax/ast_util.mli index d037004970..479fdab681 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 e7e0e4c68f..85651e38a7 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/syntax/syntax.mllib b/jscomp/syntax/syntax.mllib index 9c4c5e619c..1c8098bc96 100644 --- a/jscomp/syntax/syntax.mllib +++ b/jscomp/syntax/syntax.mllib @@ -13,3 +13,5 @@ ast_derive ast_signature ast_core_type ast_external_attributes +ast_pat +ast_exp \ No newline at end of file diff --git a/jscomp/test/.depend b/jscomp/test/.depend index ddb1511ba9..d53611f6e4 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_test.cmj : mt.cmi +ppx_this_obj_test.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_test.cmo : mt.cmi +ppx_this_obj_test.cmj : mt.cmj pq_test.cmo : pq_test.cmj : pr6726.cmo : diff --git a/jscomp/test/Makefile b/jscomp/test/Makefile index 340ee58862..58de2d711d 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_test unsafe_obj_external 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 0000000000..2b645bd72a --- /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_test.js b/jscomp/test/ppx_this_obj_test.js new file mode 100644 index 0000000000..5fb134250f --- /dev/null +++ b/jscomp/test/ppx_this_obj_test.js @@ -0,0 +1,113 @@ +'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; + } +}; + +var v2 = { + hi: function (x, y) { + var self = this ; + return self.say(x) + y; + }, + say: function (x) { + var self = this ; + return x * self.x(); + }, + x: function () { + return 3; + } +}; + +var v3 = { + hi: function (x, y) { + var self = this ; + var u = { + x: 3 + }; + return self.say(u.x) + y + x; + }, + say: function (x) { + var self = this ; + return x * self.x(); + }, + x: function () { + return 3; + } +}; + +var v4 = { + hi: function (_, y) { + return x + y; + }, + say: function () { + return x; + }, + x: function () { + return 1; + } +}; + +var collection = /* array */[ + v, + v2, + v3, + v4 +]; + +eq('File "ppx_this_obj_test.ml", line 55, characters 5-12', /* tuple */[ + 11, + v.hi(3, 2) + ]); + +eq('File "ppx_this_obj_test.ml", line 56, characters 5-12', /* tuple */[ + 11, + v2.hi(3, 2) + ]); + +Mt.from_pair_suites("ppx_this_obj_test.ml", suites[0]); + +exports.suites = suites; +exports.test_id = test_id; +exports.eq = eq; +exports.v = v; +exports.v2 = v2; +exports.v3 = v3; +exports.v4 = v4; +exports.collection = collection; +/* v Not a pure module */ diff --git a/jscomp/test/ppx_this_obj_test.ml b/jscomp/test/ppx_this_obj_test.ml new file mode 100644 index 0000000000..35647b26c5 --- /dev/null +++ b/jscomp/test/ppx_this_obj_test.ml @@ -0,0 +1,58 @@ +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 v2 = + let x = 3. in + object (self) + method hi x = fun y -> self##say x +. y + method say = fun x -> x *. self## x () + method x () = x + end [@bs] + + +let v3 = + let x = 3. in + object (self) + method hi x y = + let u = [%bs.obj{ x = 3. }] in + self##say u##x +. y +.x + method say = fun x -> x *. self## x () + method x () = x + end [@bs] + +let v4 = + object + method hi x y = x +. y + method say x = x + method x () = 1. + end [@bs] + + +(** guarantee they have the same type *) +let collection = [| v ; v2 ; v3 ; v4 |] + +let () = + eq __LOC__ (11., v##hi 3. 2.); + eq __LOC__ (11., v2##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 c48bf05109..a97beabc75 100644 --- a/jscomp/test/unsafe_obj_external.js +++ b/jscomp/test/unsafe_obj_external.js @@ -1,4 +1,3 @@ -// GENERATED CODE BY BUCKLESCRIPT VERSION 0.9.0 , PLEASE EDIT WITH CARE 'use strict'; diff --git a/jscomp/test/unsafe_obj_external.ml b/jscomp/test/unsafe_obj_external.ml index 010823b358..251999f09b 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] *) From 4412f8ed2c68267f9731dee406a1fe38594921d4 Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Tue, 9 Aug 2016 15:02:15 -0400 Subject: [PATCH 2/2] improve error message --- jscomp/syntax/ast_util.ml | 21 ++++++++++++++------- jscomp/test/ppx_this_obj_test.js | 4 ++-- jscomp/test/ppx_this_obj_test.ml | 6 +++++- 3 files changed, 21 insertions(+), 10 deletions(-) diff --git a/jscomp/syntax/ast_util.ml b/jscomp/syntax/ast_util.ml index dcf540672b..63d4da7606 100644 --- a/jscomp/syntax/ast_util.ml +++ b/jscomp/syntax/ast_util.ml @@ -416,12 +416,10 @@ let ocaml_obj_as_js_object Cfk_concrete (Fresh, e)) -> - begin match e with - | { - pexp_desc = - Pexp_poly - (({pexp_desc = Pexp_fun ("", None, pat, e)} as f), - None)} -> + begin match e.pexp_desc with + | Pexp_poly + (({pexp_desc = Pexp_fun ("", None, pat, e)} as f), + None) -> let arity = Ast_pat.arity_of_fun pat e in let method_type, label_type = generate_callback_method_pair x.pcf_loc mapper label.txt arity in @@ -433,9 +431,18 @@ let ocaml_obj_as_js_object let f = Ast_pat.is_unit_cont pat ~yes:e ~no:f in to_method_callback loc mapper self_pat f } :: exprs) + | Pexp_poly( _, Some _) + -> + Location.raise_errorf ~loc:x.pcf_loc + "polymorphic type annotation not supported yet" + + | Pexp_poly (_, None) -> + Location.raise_errorf + ~loc:x.pcf_loc + "Unsupported syntax, expect syntax like `method x () = x ` " | _ -> Location.raise_errorf ~loc:x.pcf_loc - "polymorphic type annotation not supported" + "Unsupported syntax in js object" end | Pcf_method (_, _, Cfk_concrete(Override, _) ) -> Location.raise_errorf ~loc:x.pcf_loc diff --git a/jscomp/test/ppx_this_obj_test.js b/jscomp/test/ppx_this_obj_test.js index 5fb134250f..12db61f2e4 100644 --- a/jscomp/test/ppx_this_obj_test.js +++ b/jscomp/test/ppx_this_obj_test.js @@ -90,12 +90,12 @@ var collection = /* array */[ v4 ]; -eq('File "ppx_this_obj_test.ml", line 55, characters 5-12', /* tuple */[ +eq('File "ppx_this_obj_test.ml", line 59, characters 5-12', /* tuple */[ 11, v.hi(3, 2) ]); -eq('File "ppx_this_obj_test.ml", line 56, characters 5-12', /* tuple */[ +eq('File "ppx_this_obj_test.ml", line 60, characters 5-12', /* tuple */[ 11, v2.hi(3, 2) ]); diff --git a/jscomp/test/ppx_this_obj_test.ml b/jscomp/test/ppx_this_obj_test.ml index 35647b26c5..c856217a13 100644 --- a/jscomp/test/ppx_this_obj_test.ml +++ b/jscomp/test/ppx_this_obj_test.ml @@ -47,7 +47,11 @@ let v4 = method x () = 1. end [@bs] - +(* let v5 = *) +(* object *) +(* method x = x *) +(* end [@bs] *) + (** guarantee they have the same type *) let collection = [| v ; v2 ; v3 ; v4 |]