From d72c822c781c1bdce8a6ea7a91ad23034c074d72 Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Wed, 3 Mar 2021 12:04:54 +0800 Subject: [PATCH 1/2] support for pattern match over modules --- jscomp/frontend/ast_tuple_pattern_flatten.ml | 20 ++++++++++++++++++-- jscomp/frontend/bs_builtin_ppx.ml | 18 +++++++++++------- 2 files changed, 29 insertions(+), 9 deletions(-) diff --git a/jscomp/frontend/ast_tuple_pattern_flatten.ml b/jscomp/frontend/ast_tuple_pattern_flatten.ml index b02cdb84b2..bd497ece78 100644 --- a/jscomp/frontend/ast_tuple_pattern_flatten.ml +++ b/jscomp/frontend/ast_tuple_pattern_flatten.ml @@ -52,8 +52,8 @@ let flattern_tuple_pattern_vb let pvb_pat = self.pat self vb.pvb_pat in let pvb_expr = self.expr self vb.pvb_expr in let pvb_attributes = self.attributes self vb.pvb_attributes in - match pvb_pat.ppat_desc with - | Ppat_tuple xs when List.for_all is_simple_pattern xs -> + match pvb_pat.ppat_desc, pvb_expr.pexp_desc with + | Ppat_tuple xs, _ when List.for_all is_simple_pattern xs -> begin match Ast_open_cxt.destruct_open_tuple pvb_expr [] with | Some (wholes, es, tuple_attributes) when @@ -77,6 +77,22 @@ let flattern_tuple_pattern_vb pvb_loc = vb.pvb_loc; pvb_attributes} :: acc end + | Ppat_record (lid_pats,_), Pexp_pack {pmod_desc= Pmod_ident id} + -> + Ext_list.map_append lid_pats acc (fun (lid,pat) -> + match lid.txt with + | Lident s -> + { + pvb_pat = pat; + pvb_expr = + Ast_helper.Exp.ident ~loc:lid.loc + ({lid with txt = Ldot(id.txt,s)}); + pvb_attributes = []; + pvb_loc = pat.ppat_loc; + } + | _ -> + Location.raise_errorf ~loc:lid.loc "Not supported pattern match on modules" + ) | _ -> {pvb_pat ; pvb_expr ; diff --git a/jscomp/frontend/bs_builtin_ppx.ml b/jscomp/frontend/bs_builtin_ppx.ml index e5cd1779f3..5d2159c188 100644 --- a/jscomp/frontend/bs_builtin_ppx.ml +++ b/jscomp/frontend/bs_builtin_ppx.ml @@ -167,13 +167,17 @@ let expr_mapper (self : mapper) (e : Parsetree.expression) = pvb_attributes; pvb_loc = _}], body) -> - default_expr_mapper self - {e with - pexp_desc = Pexp_match(pvb_expr, - [{pc_lhs = p; pc_guard = None; - pc_rhs = body}]); - pexp_attributes = e.pexp_attributes @ pvb_attributes - } + begin match pvb_expr.pexp_desc with + | Pexp_pack _ -> default_expr_mapper self e + | _ -> + default_expr_mapper self + {e with + pexp_desc = Pexp_match(pvb_expr, + [{pc_lhs = p; pc_guard = None; + pc_rhs = body}]); + pexp_attributes = e.pexp_attributes @ pvb_attributes + } + end (* let [@warning "a"] {a;b} = c in body The attribute is attached to value binding, after the transformation value binding does not exist so we attach From c641c3676167a0876064d18642943e5ec240c23a Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Wed, 3 Mar 2021 12:05:18 +0800 Subject: [PATCH 2/2] add a test case --- jscomp/test/hello_res.js | 13 ++++++++++ jscomp/test/hello_res.res | 30 ++++++++++++++++++++++- lib/4.06.1/unstable/js_compiler.ml | 38 +++++++++++++++++++++++------- lib/4.06.1/whole_compiler.ml | 38 +++++++++++++++++++++++------- 4 files changed, 100 insertions(+), 19 deletions(-) diff --git a/jscomp/test/hello_res.js b/jscomp/test/hello_res.js index c54c019784..65ba83997c 100644 --- a/jscomp/test/hello_res.js +++ b/jscomp/test/hello_res.js @@ -17,5 +17,18 @@ var a = b - 1 | 0; console.log("hello, res"); +List.length({ + hd: 1, + tl: { + hd: 2, + tl: { + hd: 3, + tl: /* [] */0 + } + } + }); + +console.log(3); + exports.a = a; /* b Not a pure module */ diff --git a/jscomp/test/hello_res.res b/jscomp/test/hello_res.res index 08b2cec5d5..dc006583bf 100644 --- a/jscomp/test/hello_res.res +++ b/jscomp/test/hello_res.res @@ -14,4 +14,32 @@ type t = { "x" : int } let u : t = {"x" : 3 } -let h = u["x"] \ No newline at end of file +let h = u["x"] + +%%private( +let {length, cons } = module (List) +) + + + +%%private(let {length, cons} = module(List)) + +%%private(let (a, b) = (1, 2)) + +let {length: len, cons: c} = module(List) + +module H = { + module H1 = { + let v = 3 + } +} +let u = { + let {length: l, cons} = module(List) + cons(l(list{1, 2, 3}), list{}) +} + +let h = { + let {v} = module(H.H1) + Js.log(v) +} + diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 6d17e3fd1f..1d44fc9da6 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -405768,8 +405768,8 @@ let flattern_tuple_pattern_vb let pvb_pat = self.pat self vb.pvb_pat in let pvb_expr = self.expr self vb.pvb_expr in let pvb_attributes = self.attributes self vb.pvb_attributes in - match pvb_pat.ppat_desc with - | Ppat_tuple xs when List.for_all is_simple_pattern xs -> + match pvb_pat.ppat_desc, pvb_expr.pexp_desc with + | Ppat_tuple xs, _ when List.for_all is_simple_pattern xs -> begin match Ast_open_cxt.destruct_open_tuple pvb_expr [] with | Some (wholes, es, tuple_attributes) when @@ -405793,6 +405793,22 @@ let flattern_tuple_pattern_vb pvb_loc = vb.pvb_loc; pvb_attributes} :: acc end + | Ppat_record (lid_pats,_), Pexp_pack {pmod_desc= Pmod_ident id} + -> + Ext_list.map_append lid_pats acc (fun (lid,pat) -> + match lid.txt with + | Lident s -> + { + pvb_pat = pat; + pvb_expr = + Ast_helper.Exp.ident ~loc:lid.loc + ({lid with txt = Ldot(id.txt,s)}); + pvb_attributes = []; + pvb_loc = pat.ppat_loc; + } + | _ -> + Location.raise_errorf ~loc:lid.loc "Not supported pattern match on modules" + ) | _ -> {pvb_pat ; pvb_expr ; @@ -406048,13 +406064,17 @@ let expr_mapper (self : mapper) (e : Parsetree.expression) = pvb_attributes; pvb_loc = _}], body) -> - default_expr_mapper self - {e with - pexp_desc = Pexp_match(pvb_expr, - [{pc_lhs = p; pc_guard = None; - pc_rhs = body}]); - pexp_attributes = e.pexp_attributes @ pvb_attributes - } + begin match pvb_expr.pexp_desc with + | Pexp_pack _ -> default_expr_mapper self e + | _ -> + default_expr_mapper self + {e with + pexp_desc = Pexp_match(pvb_expr, + [{pc_lhs = p; pc_guard = None; + pc_rhs = body}]); + pexp_attributes = e.pexp_attributes @ pvb_attributes + } + end (* let [@warning "a"] {a;b} = c in body The attribute is attached to value binding, after the transformation value binding does not exist so we attach diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index b5dead8aed..763822848c 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -408810,8 +408810,8 @@ let flattern_tuple_pattern_vb let pvb_pat = self.pat self vb.pvb_pat in let pvb_expr = self.expr self vb.pvb_expr in let pvb_attributes = self.attributes self vb.pvb_attributes in - match pvb_pat.ppat_desc with - | Ppat_tuple xs when List.for_all is_simple_pattern xs -> + match pvb_pat.ppat_desc, pvb_expr.pexp_desc with + | Ppat_tuple xs, _ when List.for_all is_simple_pattern xs -> begin match Ast_open_cxt.destruct_open_tuple pvb_expr [] with | Some (wholes, es, tuple_attributes) when @@ -408835,6 +408835,22 @@ let flattern_tuple_pattern_vb pvb_loc = vb.pvb_loc; pvb_attributes} :: acc end + | Ppat_record (lid_pats,_), Pexp_pack {pmod_desc= Pmod_ident id} + -> + Ext_list.map_append lid_pats acc (fun (lid,pat) -> + match lid.txt with + | Lident s -> + { + pvb_pat = pat; + pvb_expr = + Ast_helper.Exp.ident ~loc:lid.loc + ({lid with txt = Ldot(id.txt,s)}); + pvb_attributes = []; + pvb_loc = pat.ppat_loc; + } + | _ -> + Location.raise_errorf ~loc:lid.loc "Not supported pattern match on modules" + ) | _ -> {pvb_pat ; pvb_expr ; @@ -409090,13 +409106,17 @@ let expr_mapper (self : mapper) (e : Parsetree.expression) = pvb_attributes; pvb_loc = _}], body) -> - default_expr_mapper self - {e with - pexp_desc = Pexp_match(pvb_expr, - [{pc_lhs = p; pc_guard = None; - pc_rhs = body}]); - pexp_attributes = e.pexp_attributes @ pvb_attributes - } + begin match pvb_expr.pexp_desc with + | Pexp_pack _ -> default_expr_mapper self e + | _ -> + default_expr_mapper self + {e with + pexp_desc = Pexp_match(pvb_expr, + [{pc_lhs = p; pc_guard = None; + pc_rhs = body}]); + pexp_attributes = e.pexp_attributes @ pvb_attributes + } + end (* let [@warning "a"] {a;b} = c in body The attribute is attached to value binding, after the transformation value binding does not exist so we attach