@@ -56,6 +56,10 @@ type app_pattern = {
56
56
args : Parsetree .expression list
57
57
}
58
58
59
+ let sane_property_name_check loc s =
60
+ if String. contains s '#' then
61
+ Location. raise_errorf ~loc
62
+ " property name (%s) can not contain speical character #" s
59
63
(* match fn as *)
60
64
let view_as_app (fn : exp ) s : app_pattern option =
61
65
match fn.pexp_desc with
@@ -90,130 +94,139 @@ let app_exp_mapper
90
94
| Some {op; loc} ->
91
95
Location. raise_errorf ~loc " %s expect f%sproperty arg0 arg2 form" op op
92
96
| None ->
93
- match view_as_app e infix_ops with
94
- | Some { op = "|." ; args = [obj_arg; fn];loc} ->
97
+ ( match view_as_app e infix_ops with
98
+ | Some { op = "|." ; args = [obj_arg; fn];loc} ->
95
99
(*
96
100
a |. f
97
101
a |. f b c [@bs] --> f a b c [@bs]
98
102
a |. M.(f b c) --> M.f a M.b M.c
99
103
a |. (g |. b)
100
104
a |. M.Some
101
105
*)
102
- let new_obj_arg = self.expr self obj_arg in
103
- let fn = self.expr self fn in
104
- begin match fn with
105
- | {pexp_desc = Pexp_apply (fn , args ); pexp_loc; pexp_attributes} ->
106
- Bs_ast_invariant. warn_discarded_unused_attributes pexp_attributes;
107
- { pexp_desc = Pexp_apply (fn, (Ast_compatible. no_label, new_obj_arg) :: args);
108
- pexp_attributes = [] ;
109
- pexp_loc = pexp_loc}
110
- | {pexp_desc = Pexp_construct (ctor ,None); pexp_loc; pexp_attributes} ->
111
- {fn with pexp_desc = Pexp_construct (ctor, Some new_obj_arg)}
112
- | _ ->
113
- begin match Ast_open_cxt. destruct fn [] with
114
- | {pexp_desc = Pexp_tuple xs ; pexp_attributes = tuple_attrs } , wholes ->
115
- Ast_open_cxt. restore_exp (bound new_obj_arg (fun bounded_obj_arg ->
116
- {
117
- pexp_desc =
118
- Pexp_tuple (
119
- Ext_list. map xs (fun fn ->
120
- match fn with
121
- | {pexp_desc = Pexp_apply (fn,args); pexp_loc; pexp_attributes }
122
- ->
123
- Bs_ast_invariant. warn_discarded_unused_attributes pexp_attributes;
124
- { Parsetree. pexp_desc = Pexp_apply (fn, (Ast_compatible. no_label, bounded_obj_arg) :: args);
125
- pexp_attributes = [] ;
126
- pexp_loc = pexp_loc}
127
- | {pexp_desc = Pexp_construct (ctor,None ); pexp_loc; pexp_attributes}
128
- ->
129
- {fn with pexp_desc = Pexp_construct (ctor, Some bounded_obj_arg)}
130
- | _ ->
131
- Ast_compatible. app1 ~loc: fn.pexp_loc fn bounded_obj_arg
132
- ));
133
- pexp_attributes = tuple_attrs;
134
- pexp_loc = fn.pexp_loc;
135
- })) wholes
136
- | {pexp_desc = Pexp_apply (e , args ); pexp_attributes} , (_ :: _ as wholes ) ->
137
- let fn = Ast_open_cxt. restore_exp e wholes in
138
- let args = Ext_list. map args (fun (lab ,exp ) -> lab, Ast_open_cxt. restore_exp exp wholes) in
139
- Bs_ast_invariant. warn_discarded_unused_attributes pexp_attributes;
140
- { pexp_desc = Pexp_apply (fn, (Ast_compatible. no_label, new_obj_arg) :: args);
141
- pexp_attributes = [] ;
142
- pexp_loc = loc}
143
- | _ -> Ast_compatible. app1 ~loc fn new_obj_arg
106
+ let new_obj_arg = self.expr self obj_arg in
107
+ let fn = self.expr self fn in
108
+ begin match fn with
109
+ | {pexp_desc = Pexp_apply (fn , args ); pexp_loc; pexp_attributes} ->
110
+ Bs_ast_invariant. warn_discarded_unused_attributes pexp_attributes;
111
+ { pexp_desc = Pexp_apply (fn, (Ast_compatible. no_label, new_obj_arg) :: args);
112
+ pexp_attributes = [] ;
113
+ pexp_loc = pexp_loc}
114
+ | {pexp_desc = Pexp_construct (ctor ,None); pexp_loc; pexp_attributes} ->
115
+ {fn with pexp_desc = Pexp_construct (ctor, Some new_obj_arg)}
116
+ | _ ->
117
+ begin match Ast_open_cxt. destruct fn [] with
118
+ | {pexp_desc = Pexp_tuple xs ; pexp_attributes = tuple_attrs } , wholes ->
119
+ Ast_open_cxt. restore_exp (bound new_obj_arg (fun bounded_obj_arg ->
120
+ {
121
+ pexp_desc =
122
+ Pexp_tuple (
123
+ Ext_list. map xs (fun fn ->
124
+ match fn with
125
+ | {pexp_desc = Pexp_apply (fn,args); pexp_loc; pexp_attributes }
126
+ ->
127
+ Bs_ast_invariant. warn_discarded_unused_attributes pexp_attributes;
128
+ { Parsetree. pexp_desc = Pexp_apply (fn, (Ast_compatible. no_label, bounded_obj_arg) :: args);
129
+ pexp_attributes = [] ;
130
+ pexp_loc = pexp_loc}
131
+ | {pexp_desc = Pexp_construct (ctor,None ); pexp_loc; pexp_attributes}
132
+ ->
133
+ {fn with pexp_desc = Pexp_construct (ctor, Some bounded_obj_arg)}
134
+ | _ ->
135
+ Ast_compatible. app1 ~loc: fn.pexp_loc fn bounded_obj_arg
136
+ ));
137
+ pexp_attributes = tuple_attrs;
138
+ pexp_loc = fn.pexp_loc;
139
+ })) wholes
140
+ | {pexp_desc = Pexp_apply (e , args ); pexp_attributes} , (_ :: _ as wholes ) ->
141
+ let fn = Ast_open_cxt. restore_exp e wholes in
142
+ let args = Ext_list. map args (fun (lab ,exp ) -> lab, Ast_open_cxt. restore_exp exp wholes) in
143
+ Bs_ast_invariant. warn_discarded_unused_attributes pexp_attributes;
144
+ { pexp_desc = Pexp_apply (fn, (Ast_compatible. no_label, new_obj_arg) :: args);
145
+ pexp_attributes = [] ;
146
+ pexp_loc = loc}
147
+ | _ -> Ast_compatible. app1 ~loc fn new_obj_arg
144
148
end
145
- end
146
- | Some { op = "##" ; loc; args = [obj; rest]} ->
147
- (* - obj##property
148
- - obj#(method a b )
149
- we should warn when we discard attributes
150
- gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
151
- first before pattern match.
152
- currently the pattern match is written in a top down style.
153
- Another corner case: f##(g a b [@bs])
154
- *)
155
- begin match rest with
156
- {pexp_desc = Pexp_apply (
157
- {pexp_desc = Pexp_ident {txt = Lident name ;_ } ; _} ,
158
- args
159
- ); pexp_attributes = attrs }
149
+ end
150
+ | Some { op = "##" ; loc; args = [obj; rest]} ->
151
+ (* - obj##property
152
+ - obj#(method a b )
153
+ we should warn when we discard attributes
154
+ gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
155
+ first before pattern match.
156
+ currently the pattern match is written in a top down style.
157
+ Another corner case: f##(g a b [@bs])
158
+ *)
159
+ begin match rest with
160
+ {pexp_desc = Pexp_apply (
161
+ {pexp_desc = Pexp_ident {txt = Lident name ;_ } ; _} ,
162
+ args
163
+ ); pexp_attributes = attrs }
164
+ ->
165
+ Bs_ast_invariant. warn_discarded_unused_attributes attrs ;
166
+ {e with pexp_desc = Ast_util. method_apply loc self obj name (check_and_discard args)}
167
+ |
168
+ {pexp_desc =
169
+ (Pexp_ident {txt = Lident name;_ }
170
+ | Pexp_constant (Const_string (name,None )))
171
+ ;
172
+ pexp_loc}
173
+ (* f##paint *)
174
+ ->
175
+ sane_property_name_check pexp_loc name ;
176
+ { e with pexp_desc =
177
+ Ast_util. js_property loc (self.expr self obj) name
178
+ }
179
+ | _ -> Location. raise_errorf ~loc " invalid ## syntax"
180
+ end
181
+
182
+ (* we can not use [:=] for precedece cases
183
+ like {[i @@ x##length := 3 ]}
184
+ is parsed as {[ (i @@ x##length) := 3]}
185
+ since we allow user to create Js objects in OCaml, it can be of
186
+ ref type
187
+ {[
188
+ let u = object (self)
189
+ val x = ref 3
190
+ method setX x = self##x := 32
191
+ method getX () = !self##x
192
+ end
193
+ ]}
194
+ *)
195
+ | Some {op = "#=" ; loc; args = [obj; arg]} ->
196
+ begin match view_as_app obj [" ##" ] with
197
+ | Some { args = [obj; {
198
+ pexp_desc =
199
+ Pexp_ident {txt = Lident name}
200
+ | Pexp_constant (Const_string (name, None )); pexp_loc
201
+ }
202
+ ]
203
+ }
160
204
->
161
- Bs_ast_invariant. warn_discarded_unused_attributes attrs ;
162
- {e with pexp_desc = Ast_util. method_apply loc self obj name (check_and_discard args)}
163
- |
164
- {pexp_desc = Pexp_ident {txt = Lident name;_ } ; _}
165
- (* f##paint *)
166
- ->
167
- { e with pexp_desc =
168
- Ast_util. js_property loc (self.expr self obj) name
169
- }
170
- | _ -> Location. raise_errorf ~loc " invalid ## syntax"
171
- end
172
-
173
- (* we can not use [:=] for precedece cases
174
- like {[i @@ x##length := 3 ]}
175
- is parsed as {[ (i @@ x##length) := 3]}
176
- since we allow user to create Js objects in OCaml, it can be of
177
- ref type
178
- {[
179
- let u = object (self)
180
- val x = ref 3
181
- method setX x = self##x := 32
182
- method getX () = !self##x
183
- end
184
- ]}
185
- *)
186
- | Some {op = "#=" ; loc; args = [obj; arg]} ->
187
- begin match view_as_app obj [" ##" ] with
188
- | Some { args = [obj; {pexp_desc = Pexp_ident {txt = Lident name}}]}
189
- ->
190
- Exp. constraint_ ~loc
191
- { e with
192
- pexp_desc =
193
- Ast_util. method_apply loc self obj
194
- (name ^ Literals. setter_suffix) [arg] }
195
- (Ast_literal. type_unit ~loc () )
196
- | _ -> assert false
197
- end
198
- | Some { op = "|." ; loc; } ->
199
- Location. raise_errorf ~loc
200
- " invalid |. syntax, it can only be used as binary operator"
201
- | Some {op = "##" ; loc } ->
202
- Location. raise_errorf ~loc
203
- " Js object ## expect syntax like obj##(paint (a,b)) "
204
- | Some {op; } -> Location. raise_errorf " invalid %s syntax" op
205
- | None ->
206
- match
207
- Ext_list. exclude_with_val
208
- e.pexp_attributes
209
- Ast_attributes. is_bs with
210
- | None -> default_expr_mapper self e
211
- | Some pexp_attributes ->
212
- #if BS_NATIVE then
213
- {e with pexp_attributes }
214
- #else
215
- {e with pexp_desc = Ast_util. uncurry_fn_apply e.pexp_loc self fn (check_and_discard args) ;
216
- pexp_attributes }
217
-
218
-
219
- #end
205
+ sane_property_name_check pexp_loc name;
206
+ Exp. constraint_ ~loc
207
+ { e with
208
+ pexp_desc =
209
+ Ast_util. method_apply loc self obj
210
+ (name ^ Literals. setter_suffix) [arg] }
211
+ (Ast_literal. type_unit ~loc () )
212
+ | _ -> assert false
213
+ end
214
+ | Some { op = "|." ; loc; } ->
215
+ Location. raise_errorf ~loc
216
+ " invalid |. syntax, it can only be used as binary operator"
217
+ | Some {op = "##" ; loc } ->
218
+ Location. raise_errorf ~loc
219
+ " Js object ## expect syntax like obj##(paint (a,b)) "
220
+ | Some {op; } -> Location. raise_errorf " invalid %s syntax" op
221
+ | None ->
222
+ match
223
+ Ext_list. exclude_with_val
224
+ e.pexp_attributes
225
+ Ast_attributes. is_bs with
226
+ | None -> default_expr_mapper self e
227
+ | Some pexp_attributes ->
228
+ if ! Clflags. bs_only then
229
+ {e with pexp_desc = Ast_util. uncurry_fn_apply e.pexp_loc self fn (check_and_discard args) ;
230
+ pexp_attributes }
231
+ else {e with pexp_attributes } (* BS_NATIVE branch*)
232
+ )
0 commit comments