Skip to content

Commit 5108323

Browse files
bobzhangbobzhang
committed
tweak
1 parent 8869b21 commit 5108323

File tree

4 files changed

+295
-284
lines changed

4 files changed

+295
-284
lines changed

‎jscomp/syntax/ast_derive_abstract.ml

Lines changed: 73 additions & 71 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
(* Copyright (C) 2017 Authors of BuckleScript
2-
*
2+
*
33
* This program is free software: you can redistribute it and/or modify
44
* it under the terms of the GNU Lesser General Public License as published by
55
* the Free Software Foundation, either version 3 of the License, or
@@ -17,7 +17,7 @@
1717
* but WITHOUT ANY WARRANTY; without even the implied warranty of
1818
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1919
* GNU Lesser General Public License for more details.
20-
*
20+
*
2121
* You should have received a copy of the GNU Lesser General Public License
2222
* along with this program; if not, write to the Free Software
2323
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
@@ -26,110 +26,112 @@
2626
let derivingName = "abstract"
2727
module U = Ast_derive_util
2828
open Ast_helper
29-
type tdcls = Parsetree.type_declaration list
29+
type tdcls = Parsetree.type_declaration list
3030

31-
let handle_config (config : Parsetree.expression option) =
32-
match config with
33-
| Some config ->
31+
let handle_config (config : Parsetree.expression option) =
32+
match config with
33+
| Some config ->
3434
U.invalid_config config
3535
| None -> ()
3636

37-
(* see #2337
37+
(* see #2337
3838
TODO: relax it to allow (int -> int [@bs])
39-
*)
40-
let rec checkNotFunciton (ty : Parsetree.core_type) =
41-
match ty.ptyp_desc with
42-
| Ptyp_poly (_,ty) -> checkNotFunciton ty
43-
| Ptyp_alias (ty,_) -> checkNotFunciton ty
44-
| Ptyp_arrow _ ->
45-
Location.raise_errorf
46-
~loc:ty.ptyp_loc
39+
*)
40+
let rec checkNotFunciton (ty : Parsetree.core_type) =
41+
match ty.ptyp_desc with
42+
| Ptyp_poly (_,ty) -> checkNotFunciton ty
43+
| Ptyp_alias (ty,_) -> checkNotFunciton ty
44+
| Ptyp_arrow _ ->
45+
Location.raise_errorf
46+
~loc:ty.ptyp_loc
4747
"syntactic function type is not allowed when working with abstract bs.deriving, create a named type as work around"
48-
| Ptyp_any
48+
| Ptyp_any
4949
| Ptyp_var _
50-
| Ptyp_tuple _
50+
| Ptyp_tuple _
5151
| Ptyp_constr _
52-
| Ptyp_object _
53-
| Ptyp_class _
52+
| Ptyp_object _
53+
| Ptyp_class _
5454
| Ptyp_variant _
5555
| Ptyp_package _
56-
| Ptyp_extension _ -> ()
57-
let handleTdcl (tdcl : Parsetree.type_declaration) =
58-
let core_type = U.core_type_of_type_declaration tdcl in
59-
let loc = tdcl.ptype_loc in
60-
let name = tdcl.ptype_name.txt in
56+
| Ptyp_extension _ -> ()
57+
58+
59+
let handleTdcl (tdcl : Parsetree.type_declaration) =
60+
let core_type = U.core_type_of_type_declaration tdcl in
61+
let loc = tdcl.ptype_loc in
62+
let type_name = tdcl.ptype_name.txt in
6163
let newTdcl = {
62-
tdcl with
64+
tdcl with
6365
ptype_kind = Ptype_abstract;
6466
ptype_attributes = [];
6567
(* avoid non-terminating*)
66-
} in
67-
match tdcl.ptype_kind with
68-
| Ptype_record label_declarations ->
69-
let ty =
70-
Ext_list.fold_right (fun (label_declaration : Parsetree.label_declaration) acc ->
71-
Typ.arrow
72-
label_declaration.pld_name.txt label_declaration.pld_type acc
73-
) label_declarations core_type in
74-
let setter_accessor =
75-
Ext_list.fold_right (fun (x: Parsetree.label_declaration) acc ->
76-
let pld_name = x.pld_name.txt in
77-
let pld_loc = x.pld_name.loc in
68+
} in
69+
match tdcl.ptype_kind with
70+
| Ptype_record label_declarations ->
71+
let setter_accessor =
72+
Ext_list.fold_right (fun (x: Parsetree.label_declaration) acc ->
73+
let pld_name = x.pld_name.txt in
74+
let pld_loc = x.pld_name.loc in
7875
let pld_type = x.pld_type in
79-
let () = checkNotFunciton pld_type in
80-
let setter =
81-
Val.mk
76+
let () = checkNotFunciton pld_type in
77+
let setter =
78+
Val.mk
8279
{loc = pld_loc; txt = pld_name}
8380
~attrs:[Ast_attributes.bs_get]
8481
~prim:[pld_name]
85-
(Typ.arrow "" core_type pld_type) :: acc in
86-
match x.pld_mutable with
87-
| Mutable ->
88-
Val.mk
82+
(Typ.arrow "" core_type pld_type) :: acc in
83+
match x.pld_mutable with
84+
| Mutable ->
85+
Val.mk
8986
{loc = pld_loc; txt = pld_name ^ "Set"}
9087
~attrs:[Ast_attributes.bs_set]
9188
~prim:[pld_name]
9289
(Typ.arrow "" core_type (Typ.arrow "" pld_type (Ast_literal.type_unit ()))) :: setter
93-
| Immutable -> setter
90+
| Immutable -> setter
9491
) label_declarations []
95-
in
92+
in
9693

97-
newTdcl,
98-
(match tdcl.ptype_private with
94+
newTdcl,
95+
(match tdcl.ptype_private with
9996
| Private -> setter_accessor
100-
| Public ->
101-
let maker =
102-
Val.mk {loc; txt = name}
97+
| Public ->
98+
let ty =
99+
Ext_list.fold_right (fun (label_declaration : Parsetree.label_declaration) acc ->
100+
Typ.arrow
101+
label_declaration.pld_name.txt label_declaration.pld_type acc
102+
) label_declarations core_type in
103+
let maker =
104+
Val.mk {loc; txt = type_name}
103105
~attrs:[Ast_attributes.bs_obj]
104-
~prim:[""] ty in
106+
~prim:[""] ty in
105107
(maker :: setter_accessor))
106108

107-
| Ptype_abstract
108-
| Ptype_variant _
109-
| Ptype_open ->
109+
| Ptype_abstract
110+
| Ptype_variant _
111+
| Ptype_open ->
110112
(* Looks obvious that it does not make sense to warn *)
111113
(* U.notApplicable tdcl.ptype_loc derivingName; *)
112114
tdcl, []
113115

114-
let handleTdclsInStr tdcls =
115-
let tdcls, code =
116-
List.fold_right (fun tdcl (tdcls, sts) ->
117-
match handleTdcl tdcl with
118-
ntdcl, value_descriptions ->
119-
ntdcl::tdcls,
116+
let handleTdclsInStr tdcls =
117+
let tdcls, code =
118+
List.fold_right (fun tdcl (tdcls, sts) ->
119+
match handleTdcl tdcl with
120+
ntdcl, value_descriptions ->
121+
ntdcl::tdcls,
120122
Ext_list.map_append (fun x -> Str.primitive x) value_descriptions sts
121123

122-
) tdcls ([],[]) in
123-
Str.type_ tdcls :: code
124+
) tdcls ([],[]) in
125+
Str.type_ tdcls :: code
124126
(* still need perform transformation for non-abstract type*)
125127

126-
let handleTdclsInSig tdcls =
127-
let tdcls, code =
128-
List.fold_right (fun tdcl (tdcls, sts) ->
129-
match handleTdcl tdcl with
130-
ntdcl, value_descriptions ->
131-
ntdcl::tdcls,
128+
let handleTdclsInSig tdcls =
129+
let tdcls, code =
130+
List.fold_right (fun tdcl (tdcls, sts) ->
131+
match handleTdcl tdcl with
132+
ntdcl, value_descriptions ->
133+
ntdcl::tdcls,
132134
Ext_list.map_append (fun x -> Sig.value x) value_descriptions sts
133135

134-
) tdcls ([],[]) in
135-
Sig.type_ tdcls :: code
136+
) tdcls ([],[]) in
137+
Sig.type_ tdcls :: code

0 commit comments

Comments
 (0)