@@ -127,49 +127,17 @@ let app1 = Ast_compatible.app1
127
127
128
128
let app2 = Ast_compatible. app2
129
129
130
- let app3 = Ast_compatible. app3
131
-
132
- let ( <=~ ) a b = app2 (Exp. ident { loc = noloc; txt = Lident " <=" }) a b
133
-
134
- let ( -~ ) a b =
135
- app2 (Exp. ident { loc = noloc; txt = Ldot (Lident " Pervasives" , " -" ) }) a b
136
-
137
- let ( +~ ) a b =
138
- app2 (Exp. ident { loc = noloc; txt = Ldot (Lident " Pervasives" , " +" ) }) a b
139
-
140
- let ( &&~ ) a b =
141
- app2 (Exp. ident { loc = noloc; txt = Ldot (Lident " Pervasives" , " &&" ) }) a b
142
-
143
130
let ( ->~ ) a b = Ast_compatible. arrow a b
144
131
145
132
let jsMapperRt = Longident. Ldot (Lident " Js" , " MapperRt" )
146
133
147
- let fromInt len array exp =
148
- app3
149
- (Exp. ident { loc = noloc; txt = Longident. Ldot (jsMapperRt, " fromInt" ) })
150
- len array exp
151
-
152
- let fromIntAssert len array exp =
153
- app3
154
- (Exp. ident
155
- { loc = noloc; txt = Longident. Ldot (jsMapperRt, " fromIntAssert" ) })
156
- len array exp
157
-
158
134
let raiseWhenNotFound x =
159
135
app1
160
136
(Exp. ident
161
137
{ loc = noloc; txt = Longident. Ldot (jsMapperRt, " raiseWhenNotFound" ) })
162
138
x
163
-
164
- let assertExp e = Exp. assert_ e
165
-
166
139
let derivingName = " jsConverter"
167
140
168
- (* let notApplicable loc =
169
- Location.prerr_warning
170
- loc
171
- (Warnings.Bs_derive_warning ( derivingName ^ " not applicable to this type")) *)
172
-
173
141
let init () =
174
142
Ast_derive. register derivingName (fun (x : Parsetree.expression option ) ->
175
143
let createType = handle_config x in
@@ -182,7 +150,6 @@ let init () =
182
150
let name = tdcl.ptype_name.txt in
183
151
let toJs = name ^ " ToJs" in
184
152
let fromJs = name ^ " FromJs" in
185
- let constantArray = " jsMapperConstantArray" in
186
153
let loc = tdcl.ptype_loc in
187
154
let patToJs = { Asttypes. loc; txt = toJs } in
188
155
let patFromJs = { Asttypes. loc; txt = fromJs } in
@@ -302,95 +269,9 @@ let init () =
302
269
| None ->
303
270
U. notApplicable tdcl.Parsetree. ptype_loc derivingName;
304
271
[] )
305
- | Ptype_variant ctors ->
306
- if Ast_polyvar. is_enum_constructors ctors then
307
- let xs =
308
- Ast_polyvar. map_constructor_declarations_into_ints ctors
309
- in
310
- match xs with
311
- | `New xs ->
312
- let constantArrayExp =
313
- Exp. ident { loc; txt = Lident constantArray }
314
- in
315
- let exp_len =
316
- Ast_compatible. const_exp_int (List. length ctors)
317
- in
318
- let v =
319
- [
320
- unsafeIndexGet;
321
- eraseTypeStr;
322
- Ast_comb. single_non_rec_value
323
- { loc; txt = constantArray }
324
- (Ast_compatible. const_exp_int_list_as_array xs);
325
- toJsBody
326
- (app2 unsafeIndexGetExp constantArrayExp exp_param);
327
- Ast_comb. single_non_rec_value patFromJs
328
- (Ast_compatible. fun_ (Pat. var pat_param)
329
- (if createType then
330
- fromIntAssert exp_len constantArrayExp
331
- (exp_param +: newType)
332
- +> core_type
333
- else
334
- fromInt exp_len constantArrayExp exp_param
335
- +> Ast_core_type. lift_option_type core_type));
336
- ]
337
- in
338
- if createType then newTypeStr :: v else v
339
- | `Offset offset ->
340
- let v =
341
- [
342
- eraseTypeStr;
343
- toJsBody
344
- (coerceResultToNewType
345
- (eraseType exp_param
346
- +~ Ast_compatible. const_exp_int offset));
347
- (let len = List. length ctors in
348
- let range_low =
349
- Ast_compatible. const_exp_int (offset + 0 )
350
- in
351
- let range_upper =
352
- Ast_compatible. const_exp_int (offset + len - 1 )
353
- in
354
-
355
- Ast_comb. single_non_rec_value { loc; txt = fromJs }
356
- (Ast_compatible. fun_ (Pat. var pat_param)
357
- (if createType then
358
- Exp. let_ Nonrecursive
359
- [
360
- Vb. mk (Pat. var pat_param)
361
- (exp_param +: newType);
362
- ]
363
- (Exp. sequence
364
- (assertExp
365
- (exp_param < =~ range_upper
366
- &&~ (range_low < =~ exp_param)))
367
- (exp_param
368
- -~ Ast_compatible. const_exp_int offset))
369
- +> core_type
370
- else
371
- Exp. ifthenelse
372
- (exp_param < =~ range_upper
373
- &&~ (range_low < =~ exp_param))
374
- (Exp. construct
375
- { loc; txt = Ast_literal. predef_some }
376
- (Some
377
- (exp_param
378
- -~ Ast_compatible. const_exp_int
379
- offset)))
380
- (Some
381
- (Exp. construct
382
- {
383
- loc;
384
- txt = Ast_literal. predef_none;
385
- }
386
- None ))
387
- +> Ast_core_type. lift_option_type core_type)));
388
- ]
389
- in
390
- if createType then newTypeStr :: v else v
391
- else (
392
- U. notApplicable tdcl.Parsetree. ptype_loc derivingName;
393
- [] )
272
+ | Ptype_variant _ ->
273
+ U. notApplicable tdcl.Parsetree. ptype_loc derivingName;
274
+ []
394
275
| Ptype_open ->
395
276
U. notApplicable tdcl.Parsetree. ptype_loc derivingName;
396
277
[]
@@ -452,23 +333,9 @@ let init () =
452
333
| None ->
453
334
U. notApplicable tdcl.Parsetree. ptype_loc derivingName;
454
335
[] )
455
- | Ptype_variant ctors ->
456
- if Ast_polyvar. is_enum_constructors ctors then
457
- let ty1 =
458
- if createType then newType else Ast_literal. type_int ()
459
- in
460
- let ty2 =
461
- if createType then core_type
462
- else Ast_core_type. lift_option_type core_type
463
- in
464
- newTypeStr
465
- +? [
466
- toJsType ty1;
467
- Ast_comb. single_non_rec_val patFromJs (ty1 ->~ ty2);
468
- ]
469
- else (
470
- U. notApplicable tdcl.Parsetree. ptype_loc derivingName;
471
- [] )
336
+ | Ptype_variant _ ->
337
+ U. notApplicable tdcl.Parsetree. ptype_loc derivingName;
338
+ []
472
339
| Ptype_open ->
473
340
U. notApplicable tdcl.Parsetree. ptype_loc derivingName;
474
341
[]
0 commit comments