Skip to content

Commit 46344bb

Browse files
bobzhangbobzhang
authored
Merge pull request #4154 from BuckleScript/refactor_uncurry
[refactoring] uncurry handling
2 parents fe79479 + a12ac63 commit 46344bb

22 files changed

+33910
-33066
lines changed

‎jscomp/syntax/ast_core_type_class_type.ml

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -73,15 +73,15 @@ let handle_class_type_field self
7373
match ty.ptyp_desc with
7474
| Ptyp_arrow (label, args, body)
7575
->
76-
Ast_util.to_method_type
76+
Ast_typ_uncurry.to_method_type
7777
ty.ptyp_loc self label args body
7878

7979
| Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body);
8080
ptyp_loc})
8181
->
8282
{ty with ptyp_desc =
8383
Ptyp_poly(strs,
84-
Ast_util.to_method_type
84+
Ast_typ_uncurry.to_method_type
8585
ptyp_loc self label args body )}
8686
| _ ->
8787
self.typ self ty
@@ -105,7 +105,7 @@ let handle_class_type_field self
105105
Pctf_method (name,
106106
private_flag,
107107
virtual_flag,
108-
Ast_util.to_method_type
108+
Ast_typ_uncurry.to_method_type
109109
loc self Nolabel ty
110110
(Ast_literal.type_unit ~loc ())
111111
);
@@ -147,11 +147,11 @@ let typ_mapper
147147
} ->
148148
begin match Ast_attributes.process_attributes_rev ptyp_attributes with
149149
| Uncurry _, ptyp_attributes ->
150-
Ast_util.to_uncurry_type loc self label args body
150+
Ast_typ_uncurry.to_uncurry_type loc self label args body
151151
| Meth_callback _, ptyp_attributes ->
152-
Ast_util.to_method_callback_type loc self label args body
152+
Ast_typ_uncurry.to_method_callback_type loc self label args body
153153
| Method _, ptyp_attributes ->
154-
Ast_util.to_method_type loc self label args body
154+
Ast_typ_uncurry.to_method_type loc self label args body
155155
| Nothing , _ ->
156156
Bs_ast_mapper.default_mapper.typ self ty
157157
end
@@ -190,7 +190,7 @@ let typ_mapper
190190
| Meth_callback attr, attrs ->
191191
attrs, attr +> ty
192192
in
193-
Ast_compatible.object_field name attrs (Ast_util.to_method_type loc self Nolabel core_type
193+
Ast_compatible.object_field name attrs (Ast_typ_uncurry.to_method_type loc self Nolabel core_type
194194
(Ast_literal.type_unit ~loc ())) in
195195
let not_getter_setter ty =
196196
let attrs, core_type =

‎jscomp/syntax/ast_exp_extension.ml

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -94,16 +94,16 @@ let handle_extension record_as_js_object e (self : Bs_ast_mapper.mapper)
9494
loc ~pval_prim:["#raw_function"]
9595
~pval_type:(Typ.arrow Nolabel any_type any_type)
9696
[str_exp]}
97-
| _ -> Ast_util.handle_raw ~kind:Raw_exp loc payload
97+
| _ -> Ast_exp_handle_external.handle_raw ~kind:Raw_exp loc payload
9898
end
9999
| "bs.re" | "re" ->
100100
Exp.constraint_ ~loc
101-
(Ast_util.handle_raw ~kind:Raw_re loc payload)
101+
(Ast_exp_handle_external.handle_raw ~kind:Raw_re loc payload)
102102
(Ast_comb.to_js_re_type loc)
103103
| "bs.external" | "external" ->
104104
begin match Ast_payload.as_ident payload with
105105
| Some {txt = Lident x}
106-
-> Ast_util.handle_external loc x
106+
-> Ast_exp_handle_external.handle_external loc x
107107
(* do we need support [%external gg.xx ]
108108
109109
{[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]}
@@ -224,7 +224,7 @@ let handle_extension record_as_js_object e (self : Bs_ast_mapper.mapper)
224224
| "require" as name); loc}
225225
->
226226
let exp =
227-
Ast_util.handle_external loc (strip name) in
227+
Ast_exp_handle_external.handle_external loc (strip name) in
228228
let typ =
229229
Ast_core_type.lift_option_type
230230
(
@@ -254,7 +254,7 @@ let handle_extension record_as_js_object e (self : Bs_ast_mapper.mapper)
254254

255255
end
256256
| "bs.debugger"|"debugger" ->
257-
{e with pexp_desc = Ast_util.handle_debugger loc payload}
257+
{e with pexp_desc = Ast_exp_handle_external.handle_debugger loc payload}
258258
| "bs.obj" | "obj" ->
259259
begin match payload with
260260
| PStr [{pstr_desc = Pstr_eval (e,_)}]

‎jscomp/syntax/ast_exp_handle_external.ml

Lines changed: 105 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,105 @@
1+
(* Copyright (C) 2020 Authors of BuckleScript
2+
*
3+
* This program is free software: you can redistribute it and/or modify
4+
* it under the terms of the GNU Lesser General Public License as published by
5+
* the Free Software Foundation, either version 3 of the License, or
6+
* (at your option) any later version.
7+
*
8+
* In addition to the permissions granted to you by the LGPL, you may combine
9+
* or link a "work that uses the Library" with a publicly distributed version
10+
* of this file to produce a combined library or application, then distribute
11+
* that combined work under the terms of your choosing, with no requirement
12+
* to comply with the obligations normally placed on you by section 4 of the
13+
* LGPL version 3 (or the corresponding section of a later version of the LGPL
14+
* should you choose to use a later version).
15+
*
16+
* This program is distributed in the hope that it will be useful,
17+
* but WITHOUT ANY WARRANTY; without even the implied warranty of
18+
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19+
* GNU Lesser General Public License for more details.
20+
*
21+
* You should have received a copy of the GNU Lesser General Public License
22+
* along with this program; if not, write to the Free Software
23+
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
24+
25+
open Ast_helper
26+
(*
27+
{[
28+
Js.undefinedToOption
29+
(if Js.typeof x = "undefined" then undefined
30+
else x )
31+
32+
]}
33+
*)
34+
let handle_external loc (x : string) : Parsetree.expression =
35+
let raw_exp : Ast_exp.t =
36+
let str_exp =
37+
(Ast_compatible.const_exp_string ~loc x ~delimiter:Ext_string.empty) in
38+
{str_exp with pexp_desc = Ast_external_mk.local_external_apply
39+
loc ~pval_prim:["#raw_expr"]
40+
~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Typ.any ()))
41+
[str_exp]}
42+
in
43+
let empty = (* FIXME: the empty delimiter does not make sense*)
44+
Exp.ident ~loc
45+
{txt = Ldot (Ldot(Lident"Js", "Undefined"), "empty");loc}
46+
in
47+
let undefined_typeof =
48+
Exp.ident {loc ; txt = Ldot(Lident "Js","undefinedToOption")} in
49+
let typeof =
50+
Exp.ident {loc ; txt = Ldot(Lident "Js","typeof")} in
51+
52+
Ast_compatible.app1 ~loc undefined_typeof (
53+
Exp.ifthenelse ~loc
54+
(Ast_compatible.app2 ~loc
55+
(Exp.ident ~loc {loc ; txt = Ldot (Lident "Pervasives", "=")} )
56+
(Ast_compatible.app1 ~loc typeof raw_exp)
57+
(Ast_compatible.const_exp_string ~loc "undefined")
58+
)
59+
empty
60+
(Some raw_exp)
61+
)
62+
63+
let handle_debugger loc (payload : Ast_payload.t) =
64+
match payload with
65+
| PStr [] ->
66+
Ast_external_mk.local_external_apply
67+
loc
68+
~pval_prim:["#debugger"]
69+
~pval_type:(Typ.arrow Nolabel (Typ.any ())
70+
(Ast_literal.type_unit ())
71+
)
72+
[Ast_literal.val_unit ~loc ()]
73+
| _ ->
74+
Location.raise_errorf ~loc "bs.debugger does not accept payload"
75+
76+
77+
let handle_raw ~kind loc payload =
78+
begin match Ast_payload.raw_as_string_exp_exn
79+
~kind payload with
80+
| None ->
81+
Location.raise_errorf ~loc
82+
"bs.raw can only be applied to a string"
83+
| Some exp ->
84+
{ exp with pexp_desc = Ast_external_mk.local_external_apply
85+
loc ~pval_prim:["#raw_expr"]
86+
~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Typ.any ()))
87+
[exp]}
88+
end
89+
let handle_raw_structure loc payload =
90+
begin match Ast_payload.raw_as_string_exp_exn
91+
~kind:Raw_program payload with
92+
| Some exp
93+
->
94+
Ast_helper.Str.eval
95+
{ exp with pexp_desc =
96+
Ast_external_mk.local_external_apply
97+
loc ~pval_prim:["#raw_stmt"]
98+
~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Typ.any ()))
99+
[exp]
100+
}
101+
102+
| None
103+
->
104+
Location.raise_errorf ~loc "bs.raw can only be applied to a string"
105+
end

‎jscomp/syntax/ast_exp_handle_external.mli

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
(* Copyright (C) 2020 Authors of BuckleScript
2+
*
3+
* This program is free software: you can redistribute it and/or modify
4+
* it under the terms of the GNU Lesser General Public License as published by
5+
* the Free Software Foundation, either version 3 of the License, or
6+
* (at your option) any later version.
7+
*
8+
* In addition to the permissions granted to you by the LGPL, you may combine
9+
* or link a "work that uses the Library" with a publicly distributed version
10+
* of this file to produce a combined library or application, then distribute
11+
* that combined work under the terms of your choosing, with no requirement
12+
* to comply with the obligations normally placed on you by section 4 of the
13+
* LGPL version 3 (or the corresponding section of a later version of the LGPL
14+
* should you choose to use a later version).
15+
*
16+
* This program is distributed in the hope that it will be useful,
17+
* but WITHOUT ANY WARRANTY; without even the implied warranty of
18+
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19+
* GNU Lesser General Public License for more details.
20+
*
21+
* You should have received a copy of the GNU Lesser General Public License
22+
* along with this program; if not, write to the Free Software
23+
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
24+
25+
26+
val handle_external:
27+
Location.t ->
28+
string ->
29+
Parsetree.expression
30+
31+
val handle_debugger :
32+
Location.t -> Ast_payload.t -> Parsetree.expression_desc
33+
34+
val handle_raw :
35+
kind : Js_raw_exp_info.raw_kind ->
36+
Location.t ->
37+
Ast_payload.t ->
38+
Parsetree.expression
39+
40+
val handle_raw_structure :
41+
Location.t -> Ast_payload.t -> Parsetree.structure_item

‎jscomp/syntax/ast_typ_uncurry.ml

Lines changed: 125 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,125 @@
1+
(* Copyright (C) 2020 Authors of BuckleScript
2+
*
3+
* This program is free software: you can redistribute it and/or modify
4+
* it under the terms of the GNU Lesser General Public License as published by
5+
* the Free Software Foundation, either version 3 of the License, or
6+
* (at your option) any later version.
7+
*
8+
* In addition to the permissions granted to you by the LGPL, you may combine
9+
* or link a "work that uses the Library" with a publicly distributed version
10+
* of this file to produce a combined library or application, then distribute
11+
* that combined work under the terms of your choosing, with no requirement
12+
* to comply with the obligations normally placed on you by section 4 of the
13+
* LGPL version 3 (or the corresponding section of a later version of the LGPL
14+
* should you choose to use a later version).
15+
*
16+
* This program is distributed in the hope that it will be useful,
17+
* but WITHOUT ANY WARRANTY; without even the implied warranty of
18+
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19+
* GNU Lesser General Public License for more details.
20+
*
21+
* You should have received a copy of the GNU Lesser General Public License
22+
* along with this program; if not, write to the Free Software
23+
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
24+
25+
26+
let uncurry_type_id =
27+
Ast_literal.Lid.js_fn
28+
29+
let method_id =
30+
Ast_literal.Lid.js_meth
31+
32+
let method_call_back_id =
33+
Ast_literal.Lid.js_meth_callback
34+
35+
type typ = Parsetree.core_type
36+
37+
type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
38+
39+
type uncurry_type_gen =
40+
(Asttypes.arg_label ->
41+
typ ->
42+
typ ->
43+
typ) cxt
44+
45+
module Typ = Ast_helper.Typ
46+
let generic_lift txt loc (args : typ list) (result : typ) =
47+
let mk_args loc (n : int) (tys : typ list) : typ =
48+
Typ.variant ~loc
49+
[ Rtag (
50+
{loc; txt = "Arity_" ^ string_of_int n}
51+
,
52+
[], (n = 0), tys)] Closed None
53+
in
54+
let xs =
55+
match args with
56+
| [ ] -> [mk_args loc 0 [] ; result ]
57+
| [ x ] -> [ mk_args loc 1 [x] ; result ]
58+
| _ ->
59+
[mk_args loc (List.length args ) [Typ.tuple ~loc args] ; result ]
60+
in
61+
Typ.constr ~loc {txt ; loc} xs
62+
63+
let lift_curry_type loc (args_type : typ list) (result_type : typ) =
64+
generic_lift uncurry_type_id loc args_type result_type
65+
66+
let lift_method_type loc args_type result_type =
67+
generic_lift method_id loc args_type result_type
68+
69+
let lift_js_method_callback loc args_type result_type
70+
=
71+
generic_lift method_call_back_id loc args_type result_type
72+
73+
74+
let generic_to_uncurry_type kind loc (mapper : Bs_ast_mapper.mapper) (label : Asttypes.arg_label)
75+
(first_arg : Parsetree.core_type)
76+
(typ : Parsetree.core_type) =
77+
if label <> Nolabel then
78+
Bs_syntaxerr.err loc Label_in_uncurried_bs_attribute;
79+
80+
let rec aux (acc : typ list) (typ : typ) : typ * typ list =
81+
(* in general,
82+
we should collect [typ] in [int -> typ] before transformation,
83+
however: when attributes [bs] and [bs.this] found in typ,
84+
we should stop
85+
*)
86+
match Ast_attributes.process_attributes_rev typ.ptyp_attributes with
87+
| Nothing, _ ->
88+
begin match typ.ptyp_desc with
89+
| Ptyp_arrow (label, arg, body)
90+
->
91+
if label <> Nolabel then
92+
Bs_syntaxerr.err typ.ptyp_loc Label_in_uncurried_bs_attribute;
93+
aux (mapper.typ mapper arg :: acc) body
94+
| _ -> mapper.typ mapper typ, acc
95+
end
96+
| _, _ -> mapper.typ mapper typ, acc
97+
in
98+
let first_arg = mapper.typ mapper first_arg in
99+
let result, rev_extra_args = aux [first_arg] typ in
100+
let args = List.rev rev_extra_args in
101+
let filter_args (args : typ list) =
102+
match args with
103+
| [{ptyp_desc =
104+
(Ptyp_constr ({txt = Lident "unit"}, [])
105+
)}]
106+
-> []
107+
| _ -> args in
108+
match kind with
109+
| `Fn ->
110+
let args = filter_args args in
111+
lift_curry_type loc args result
112+
| `Method ->
113+
let args = filter_args args in
114+
lift_method_type loc args result
115+
116+
| `Method_callback
117+
-> lift_js_method_callback loc args result
118+
119+
120+
let to_uncurry_type =
121+
generic_to_uncurry_type `Fn
122+
let to_method_type =
123+
generic_to_uncurry_type `Method
124+
let to_method_callback_type =
125+
generic_to_uncurry_type `Method_callback

0 commit comments

Comments
 (0)