« back to all changes in this revision
Viewing changes to syntax/with_typerep/pa_typerep_conv.ml
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Package Import Robot
- Author(s): Hilko Bengen
- Date: 2014-09-24 23:51:02 UTC
- Revision ID: package-import@ubuntu.com-20140924235102-0qeq851f02otnnxp
Tags: upstream-111.17.00
Import upstream version 111.17.00
- files added:
- dev
- dev/with_typerep_pp
- experimental
- experimental/lib
- extended
- extended/lib
- generics
- generics/binrep
- generics/binrep/benchmarks
- generics/binrep/lib
- generics/binrep/test
- generics/jsonrep
- generics/jsonrep/benchmarks
- generics/jsonrep/lib
- generics/jsonrep/test
- generics/sexprep
- generics/sexprep/benchmarks
- generics/sexprep/lib
- generics/sexprep/test
- lib
- syntax
- syntax/with_bin_proj
- syntax/with_typerep
added
removed
syntax/with_typerep/pa_typerep_conv.ml
1
open StdLabels
2
open Camlp4
3
open PreCast
4
5
module Rewrite_tds = Pa_type_conv.Rewrite_tds
6
7
module Gen = struct
8
include Pa_type_conv.Gen
9
let idp loc id = <:patt< $lid:id$ >>
10
let ide loc id = <:expr< $lid:id$ >>
11
let let_in loc list_lid_expr body =
12
List.fold_right list_lid_expr ~init:body ~f:(fun (lid, expr) body ->
13
<:expr< let $lid:lid$ = $expr$ in $body$ >>)
14
end
15
16
module List = struct
17
include List
18
let init ~f n =
19
let rec aux acc index =
20
if index < 0 then acc else
21
let acc = f index :: acc in
22
aux acc (pred index)
23
in
24
aux [] (pred n)
25
26
let fold_righti list ~f ~init =
27
let length = length list in
28
let (acc, _) =
29
fold_right
30
~f:(fun el (acc, index) -> let acc = f index el acc in (acc, pred index))
31
~init:(init, pred length)
32
list
33
in
34
acc
35
36
let mapi ~f list =
37
let rev, _ =
38
fold_left
39
~f:(fun (acc, index) el -> f index el :: acc, succ index)
40
~init:([], 0)
41
list
42
in
43
List.rev rev
44
end
45
46
(* camlp4 is very confusing with its tuple representation *)
47
module Tuple : sig
48
val expr : Ast.loc -> Ast.expr list -> Ast.expr
49
val patt : Ast.loc -> Ast.patt list -> Ast.patt
50
val ctyp : Ast.loc -> Ast.ctyp list -> Ast.ctyp
51
end = struct
52
let make fct = function
53
| [] -> assert false
54
| [ hd ] -> hd
55
| (_ :: _) as list -> fct list
56
let expr loc = make (fun list -> <:expr< ($tup:Ast.exCom_of_list list$) >>)
57
let patt loc = make (fun list -> <:patt< ($tup:Ast.paCom_of_list list$) >>)
58
let ctyp loc = make (fun list -> <:ctyp< ($tup:Ast.tyCom_of_list list$) >>)
59
end
60
61
module Field_case = struct
62
type t = {
63
label : string;
64
ctyp : Ast.ctyp;
65
index : int;
66
}
67
end
68
69
module Variant_case = struct
70
type t = {
71
label : string;
72
ctyp : Ast.ctyp option;
73
poly : bool;
74
arity : int;
75
index : int;
76
arity_index : int;
77
}
78
79
let patt ~loc t =
80
let label = t.label in
81
if t.poly then <:patt< `$label$ >> else <:patt< $uid:label$ >>
82
83
let expr ~loc t =
84
let label = t.label in
85
if t.poly then <:expr< `$label$ >> else <:expr< $uid:label$ >>
86
87
let ocaml_repr ~loc { label ; poly ; arity_index ; _ } =
88
if poly
89
then <:expr< Typerep_lib.Std.Typerep_obj.repr_of_poly_variant `$label$ >>
90
else <:expr< $`int:arity_index$ >>
91
end
92
93
module Branches = struct
94
let fields fields =
95
let fields = Ast.list_of_ctyp fields [] in
96
let mapi index = function
97
| <:ctyp< $lid:label$ : mutable $ctyp$ >>
98
| <:ctyp< $lid:label$ : $ctyp$ >>
99
->
100
{ Field_case.label ; ctyp ; index }
101
| ctyp -> Gen.unknown_type ctyp "Util.branches(record)"
102
in
103
List.mapi fields ~f:mapi
104
105
let variants alts =
106
(* duplicates like [ `A | `B | `A ] cause warnings in the generated code (duplicated
107
patterns), so we don't have to deal with them. *)
108
let rec extract = function
109
| <:ctyp< [ $row_fields$ ] >>
110
| <:ctyp< [< $row_fields$ ] >>
111
| <:ctyp< [> $row_fields$ ] >>
112
| <:ctyp< [= $row_fields$ ] >> ->
113
extract row_fields
114
| <:ctyp< $tp1$ | $tp2$ >> -> extract tp1 @ extract tp2
115
| ctyp -> [ctyp]
116
in
117
let cases = extract alts in
118
let no_arg = let r = ref (-1) in fun () -> incr r; !r in
119
let with_arg = let r = ref (-1) in fun () -> incr r; !r in
120
let mapi index = function
121
| <:ctyp< `$label$ >> ->
122
{ Variant_case.
123
label;
124
ctyp = None;
125
poly = true;
126
arity = 0;
127
index;
128
arity_index = no_arg ();
129
}
130
| <:ctyp< `$label$ of $ctyp$ >> ->
131
{ Variant_case.
132
label;
133
ctyp = Some ctyp;
134
poly = true;
135
arity = 1;
136
index;
137
arity_index = with_arg ();
138
}
139
| <:ctyp< $uid:label$ >> ->
140
{ Variant_case.
141
label;
142
ctyp = None;
143
poly = false;
144
arity = 0;
145
index;
146
arity_index = no_arg ();
147
}
148
| <:ctyp@loc< $uid:label$ of $ctyp$ >> ->
149
let args = Ast.list_of_ctyp ctyp [] in
150
let arity = List.length args in
151
let ctyp = Tuple.ctyp loc args in
152
{ Variant_case.
153
label;
154
ctyp = Some ctyp;
155
poly = false;
156
arity;
157
index;
158
arity_index = with_arg ();
159
}
160
| ctyp -> Gen.unknown_type ctyp "Util.branches(variant)"
161
in
162
List.mapi cases ~f:mapi
163
end
164
165
module Typerep_signature = struct
166
let sig_of_type_definitions ~sig_of_one_def ~ctyp =
167
let rec aux = function
168
| Ast.TyDcl (loc, type_name, params, rhs, cl) ->
169
sig_of_one_def ~loc ~type_name ~params ~rhs ~cl
170
| Ast.TyAnd (loc, tp1, tp2) ->
171
<:sig_item<
172
$aux tp1$;
173
$aux tp2$
174
>>
175
| _ -> assert false
176
in
177
aux ctyp
178
179
let sig_of_of_t make_ty ~loc ~type_name ~params =
180
let t_with_params =
181
let fold acc param =
182
<:ctyp< $acc$ $param$ >>
183
in
184
List.fold_left ~f:fold ~init:<:ctyp< $lid:type_name$ >> params
185
in
186
let returned = <:ctyp< $make_ty t_with_params$ >> in
187
let fold param acc =
188
let param = Gen.drop_variance_annotations param in
189
let loc = Ast.loc_of_ctyp param in
190
<:ctyp< $make_ty param$ -> $acc$ >>
191
in
192
List.fold_right ~f:fold ~init:returned params
193
194
let sig_of_typerep_of_t ~loc =
195
let make_ty params = <:ctyp< Typerep_lib.Std.Typerep.t $params$ >> in
196
sig_of_of_t make_ty ~loc
197
198
let sig_of_typename_of_t ~loc =
199
let make_ty params = <:ctyp< Typerep_lib.Std.Typename.t $params$ >> in
200
sig_of_of_t make_ty ~loc
201
202
let sig_of_one_def ~loc ~type_name ~params ~rhs:_ ~cl:_ =
203
let typerep_of = sig_of_typerep_of_t ~loc ~type_name ~params in
204
let typename_of = sig_of_typename_of_t ~loc ~type_name ~params in
205
<:sig_item<
206
value $lid: "typerep_of_" ^ type_name$ : $typerep_of$;
207
value $lid: "typename_of_" ^ type_name$ : $typename_of$;
208
>>
209
210
let sig_generator _rec ctyp =
211
sig_of_type_definitions ~sig_of_one_def ~ctyp
212
213
let () =
214
Pa_type_conv.add_sig_generator "typerep" sig_generator
215
end
216
217
module Typerep_implementation = struct
218
219
module Util : sig
220
221
val typename_field : loc:Ast.loc -> type_name:string option -> Ast.expr
222
223
val arg_of_param : string -> string
224
225
val params_names : params:Ast.ctyp list -> string list
226
val params_patts : loc:Ast.loc -> params_names:string list -> Ast.patt list
227
228
val type_name_module_definition :
229
loc:Ast.loc -> type_name:string -> params_names:string list -> Ast.str_item
230
231
val with_named :
232
loc:Ast.loc -> type_name:string -> params_names:string list -> Ast.expr -> Ast.expr
233
234
val typerep_of_t_coerce :
235
loc:Ast.loc -> type_name:string -> params_names:string list -> Ast.ctyp option
236
237
val typerep_abstract :
238
loc:Ast.loc -> type_name:string -> params_names:string list -> Ast.str_item
239
240
module Record : sig
241
242
val field_n_ident : fields:(Field_case.t list) -> int -> string
243
244
val fields :
245
loc:Ast.loc
246
-> typerep_of_type:(Ast.ctyp -> Ast.expr)
247
-> fields:Field_case.t list
248
-> (int * string * Ast.expr) list
249
250
val create : loc:Ast.loc -> fields:Field_case.t list -> Ast.expr
251
252
val has_double_array_tag : loc:Ast.loc -> fields:Field_case.t list -> Ast.expr
253
end
254
255
module Variant : sig
256
257
val tag_n_ident : variants:(Variant_case.t list) -> int -> string
258
259
val tags :
260
loc:Ast.loc
261
-> typerep_of_type:(Ast.ctyp -> Ast.expr)
262
-> variants:Variant_case.t list
263
-> (int * Ast.expr) list
264
265
val value : loc:Ast.loc -> variants:Variant_case.t list -> Ast.expr
266
267
val polymorphic : loc:Ast.loc -> variants:Variant_case.t list -> Ast.expr
268
end
269
270
end = struct
271
272
let str_item_type_and_name loc ~params_names ~type_name =
273
let params =
274
List.map params_names
275
~f:(fun name -> <:ctyp< '$lid:name$ >>)
276
in
277
let prototype =
278
let fold acc name = <:ctyp< $acc$ '$lid:name$ >> in
279
let init = <:ctyp< $lid:type_name$ >> in
280
List.fold_left ~f:fold ~init params_names
281
in
282
let tds = Ast.TyDcl (loc, "t", params, prototype, []) in
283
let type_t = Rewrite_tds.str_ loc false tds in
284
let name_def =
285
let full_type_name = Printf.sprintf "%s.%s"
286
(Pa_type_conv.get_conv_path ()) type_name
287
in
288
<:str_item< value name = $str:full_type_name$ >>
289
in
290
<:module_expr< struct $type_t$; $name_def$; end >>
291
292
let arg_of_param name = "_of_" ^ name
293
let name_of_t ~type_name = "name_of_" ^ type_name
294
295
let typename_field ~loc ~type_name =
296
match type_name with
297
| None ->
298
<:expr< Typerep_lib.Std.Typename.create () >>
299
| Some type_name ->
300
<:expr< Typerep_lib.Std.Typerep.Named.typename_of_t
301
$lid:name_of_t ~type_name$ >>
302
303
let params_names ~params =
304
List.map params ~f:(fun ty -> Gen.get_tparam_id ty)
305
306
let params_patts ~loc ~params_names =
307
List.map params_names ~f:(fun s -> Gen.idp loc (arg_of_param s))
308
309
let type_name_module_name ~type_name = "Typename_of_" ^ type_name
310
311
let with_named ~loc ~type_name ~params_names expr =
312
let name_t =
313
let init = <:expr< $uid:type_name_module_name ~type_name$.named >> in
314
List.fold_left params_names ~init ~f:(fun acc name ->
315
let arg = arg_of_param name in
316
<:expr< $acc$ $lid:arg$>>
317
)
318
in
319
let name_of_t = name_of_t ~type_name in
320
let args = <:expr< ( $lid:name_of_t$, Some (lazy $expr$) ) >> in
321
<:expr< let $lid:name_of_t$ = $name_t$ in
322
Typerep_lib.Std.Typerep.Named $args$ >>
323
324
let typerep_of_t_coerce ~loc ~type_name ~params_names =
325
match params_names with
326
| [] -> None
327
| hd :: tl ->
328
let returned =
329
let fold acc name = <:ctyp< $acc$ '$lid:name$ >> in
330
let init = <:ctyp< $lid:type_name$ >> in
331
let t = List.fold_left ~f:fold ~init params_names in
332
<:ctyp< Typerep_lib.Std.Typerep.t $t$ >>
333
in
334
let coerce =
335
let fold name acc =
336
let arg = <:ctyp< Typerep_lib.Std.Typerep.t '$lid:name$ >> in
337
<:ctyp< $arg$ -> $acc$ >>
338
in
339
List.fold_right ~init:returned ~f:fold params_names
340
in
341
let f name = <:ctyp< '$name$ >> in
342
let typevars =
343
List.fold_left ~f:(fun a b -> <:ctyp< $a$ $f b$>>) ~init:(f hd) tl
344
in
345
Some <:ctyp< ! $typevars$ . $coerce$ >> (* forall *)
346
347
let type_name_module_definition ~loc ~type_name ~params_names =
348
let name = type_name_module_name ~type_name in
349
let type_arity = List.length params_names in
350
let make = <:module_expr< Typerep_lib.Std.Make_typename.$uid:"Make"
351
^ (string_of_int type_arity)$ >>
352
in
353
let type_name_struct =
354
str_item_type_and_name loc ~params_names ~type_name
355
in
356
let type_name_module = <:module_expr< $make$ $type_name_struct$ >> in
357
let module_def =
358
<:str_item< module $uid:name$ = $type_name_module$ >>
359
in
360
let typename_of_t =
361
let lid = "typename_of_" ^ type_name in
362
<:str_item< value $lid:lid$ = $uid:name$.typename_of_t >>
363
in
364
<:str_item<
365
$module_def$;
366
$typename_of_t$;
367
>>
368
369
let typerep_abstract ~loc ~type_name ~params_names =
370
let type_name_struct =
371
str_item_type_and_name loc ~params_names ~type_name
372
in
373
let type_arity = List.length params_names in
374
let make =
375
<:module_expr< Typerep_lib.Std.Type_abstract.$uid:"Make"
376
^ (string_of_int type_arity)$ >>
377
in
378
<:str_item< include $make$ $type_name_struct$ >>
379
380
let field_or_tag_n_ident prefix ~list n =
381
if n < 0 || n > List.length list then assert false;
382
prefix ^ string_of_int n
383
384
module Record = struct
385
let field_n_ident ~fields:list = field_or_tag_n_ident "field" ~list
386
387
let fields ~loc ~typerep_of_type ~fields =
388
let map { Field_case.ctyp ; label ; index } =
389
let rep = typerep_of_type ctyp in
390
index, label, <:expr<
391
Typerep_lib.Std.Typerep.Field.internal_use_only
392
{ Typerep_lib.Std.Typerep.Field_internal.
393
label = $str:label$;
394
index = $`int:index$;
395
rep = $rep$;
396
tyid = Typerep_lib.Std.Typename.create ();
397
get = (fun t -> t.$lid:label$);
398
}
399
>>
400
in
401
List.map ~f:map fields
402
403
let has_double_array_tag ~loc ~fields =
404
let fields_binding =
405
let map { Field_case.label ; _ } =
406
(* The value must be a float else this segfaults. This is tested by the
407
unit tests in case this property changes. *)
408
<:rec_binding< $lid:label$ =
409
Typerep_lib.Std.Typerep_obj.double_array_value >>
410
in
411
List.map ~f:map fields
412
in
413
<:expr< Typerep_lib.Std.Typerep_obj.has_double_array_tag
414
{ $list:fields_binding$ } >>
415
416
let create ~loc ~fields =
417
let record =
418
(* Calling [get] on the fields from left to right matters, so that iteration
419
goes left to right too. *)
420
let fields_binding =
421
let map { Field_case.label ; _ } = <:rec_binding< $lid:label$ >> in
422
List.map ~f:map fields
423
in
424
let record = <:expr< { $list:fields_binding$ } >> in
425
let foldi index' { Field_case.label ; index; _ } acc =
426
if index <> index' then assert false;
427
let rhs = <:expr< get $lid:field_n_ident ~fields index$ >> in
428
<:expr< let $lid:label$ = $rhs$ in $acc$ >>
429
in
430
List.fold_righti fields ~f:foldi ~init:record
431
in
432
<:expr< fun { Typerep_lib.Std.Typerep.Record_internal.get = get }
433
-> $record$ >>
434
end
435
436
module Variant = struct
437
(* tag_0, tag_1, etc. *)
438
let tag_n_ident ~variants:list = field_or_tag_n_ident "tag" ~list
439
440
let polymorphic ~loc ~variants =
441
let polymorphic =
442
match variants with
443
| [] -> true
444
| hd :: _ -> hd.Variant_case.poly
445
in
446
<:expr< $`bool:polymorphic$ >>
447
448
let tags ~loc ~typerep_of_type ~variants =
449
let create ({ Variant_case.arity ; _ } as variant) =
450
let constructor = Variant_case.expr ~loc variant in
451
if arity = 0
452
then
453
<:expr< Typerep_lib.Std.Typerep.Tag_internal.Const $constructor$ >>
454
else
455
let arg_tuple i = "v" ^ string_of_int i in
456
let patt, expr =
457
let patt =
458
let f i = <:patt< $lid:arg_tuple i$ >> in
459
Tuple.patt loc (List.init arity ~f)
460
in
461
let expr =
462
let f i = <:expr< $lid:arg_tuple i$ >> in
463
let args = Tuple.expr loc (List.init arity ~f) in
464
<:expr< $constructor$ $args$ >>
465
in
466
patt, expr
467
in
468
<:expr< Typerep_lib.Std.Typerep.Tag_internal.Args
469
(fun $patt$ -> $expr$) >>
470
in
471
let mapi index' ({ Variant_case.ctyp ; label ; arity ; index ; _ } as variant) =
472
if index <> index' then assert false;
473
let rep, tyid =
474
match ctyp with
475
| Some ctyp ->
476
typerep_of_type ctyp, <:expr< Typerep_lib.Std.Typename.create () >>
477
| None ->
478
<:expr< typerep_of_tuple0 >>, <:expr< typename_of_tuple0 >>
479
in
480
let label_string = Pa_type_conv.Gen.regular_constr_of_revised_constr label in
481
index, <:expr<
482
Typerep_lib.Std.Typerep.Tag.internal_use_only
483
{ Typerep_lib.Std.Typerep.Tag_internal.
484
label = $str:label_string$;
485
rep = $rep$;
486
arity = $`int:arity$;
487
index = $`int:index$;
488
ocaml_repr = $Variant_case.ocaml_repr ~loc variant$;
489
tyid = $tyid$;
490
create = $create variant$;
491
}
492
>>
493
in
494
List.mapi ~f:mapi variants
495
496
let value ~loc ~variants =
497
let match_cases =
498
let arg_tuple i = "v" ^ string_of_int i in
499
let mapi index' ({ Variant_case.arity ; index ; _ } as variant) =
500
if index <> index' then assert false;
501
let constructor = Variant_case.patt ~loc variant in
502
let patt, value =
503
if arity = 0 then constructor, <:expr< value_tuple0 >>
504
else
505
let patt =
506
let f i = <:patt< $lid:arg_tuple i$ >> in
507
let args = Tuple.patt loc (List.init arity ~f) in
508
<:patt< $constructor$ $args$ >>
509
in
510
let expr =
511
let f i = <:expr< $lid:arg_tuple i$ >> in
512
Tuple.expr loc (List.init arity ~f)
513
in
514
patt, expr
515
in
516
let tag = <:expr< $lid:tag_n_ident ~variants index$ >> in
517
let prod = <:expr< Typerep_lib.Std.Typerep.Variant_internal.Value
518
($tag$, $value$) >>
519
in
520
<:match_case< $patt$ -> $prod$ >>
521
in
522
List.mapi ~f:mapi variants
523
in
524
<:expr< fun [ $list:match_cases$ ] >>
525
end
526
end
527
528
let mk_abst_call loc tn rev_path =
529
<:expr< $id:Gen.ident_of_rev_path loc (("typerep_of_" ^ tn) :: rev_path)$ >>
530
531
(* Conversion of type paths *)
532
let typerep_of_path_fun loc id =
533
match Gen.get_rev_id_path id [] with
534
| tn :: rev_path -> mk_abst_call loc tn rev_path
535
| [] -> assert false
536
537
let rec typerep_of_type = function
538
| <:ctyp@loc< $ty$ $param$ >> ->
539
typerep_of_type_app loc ~ty ~param
540
| <:ctyp@loc< '$parm$ >> -> Gen.ide loc (Util.arg_of_param parm)
541
| <:ctyp@loc< $id:id$ >> -> typerep_of_path_fun loc id
542
| <:ctyp< [< $row_fields$ ] >>
543
| <:ctyp< [> $row_fields$ ] >>
544
| <:ctyp< [= $row_fields$ ] >> -> typerep_of_variant ~type_name:None row_fields
545
| <:ctyp< ( $tup:tuple$ ) >> -> typerep_of_tuple tuple
546
| ctyp -> Gen.unknown_type ctyp "typerep_of_type"
547
548
and typerep_of_type_app loc ~ty ~param =
549
let typerep_of_ty = typerep_of_type ty in
550
let typerep_of_param = typerep_of_type param in
551
<:expr< $typerep_of_ty$ $typerep_of_param$ >>
552
553
and typerep_of_tuple tuple =
554
let loc = Ast.loc_of_ctyp tuple in
555
let typereps = List.map (Ast.list_of_ctyp tuple []) ~f:typerep_of_type in
556
let typerep_of_tuple =
557
let len = List.length typereps in
558
if len < 2 || len > 5
559
then
560
Gen.error tuple ~fn:"typerep impl_gen"
561
~msg:(Printf.sprintf "unsupported tuple arity %d. must be in {2,3,4,5}" len)
562
else
563
Gen.ide loc ("typerep_of_tuple" ^ string_of_int len)
564
in
565
Gen.apply loc typerep_of_tuple typereps
566
567
568
and typerep_of_record ~type_name ctyp =
569
let loc = Ast.loc_of_ctyp ctyp in
570
let fields = Branches.fields ctyp in
571
let field_ident i = Util.Record.field_n_ident ~fields i in
572
let indexed_fields = Util.Record.fields ~loc ~typerep_of_type ~fields in
573
let fields_array =
574
let fields =
575
List.map ~f:(fun (index,_,_) ->
576
<:expr< Typerep_lib.Std.Typerep.Record_internal.Field
577
$lid:field_ident index$ >>
578
) indexed_fields
579
in
580
<:expr< [| $list:fields$ |] >>
581
in
582
let bindings = [
583
"typename", Util.typename_field ~loc ~type_name:(Some type_name);
584
"has_double_array_tag", Util.Record.has_double_array_tag ~loc ~fields;
585
"fields", fields_array;
586
"create", Util.Record.create ~loc ~fields;
587
] in
588
let fields_binding =
589
let map (name, _) =
590
<:rec_binding< Typerep_lib.Std.Typerep.Record_internal.$lid:name$ >>
591
in
592
List.map ~f:map bindings
593
in
594
let record =
595
let fields =
596
<:expr< Typerep_lib.Std.Typerep.Record.internal_use_only
597
{ $list:fields_binding$ } >>
598
in
599
<:expr< Typerep_lib.Std.Typerep.Record $fields$ >>
600
in
601
let record = Gen.let_in loc bindings record in
602
let record = List.fold_right indexed_fields ~f:(fun (index, _, expr) acc ->
603
<:expr< let $lid:field_ident index$ = $expr$ in $acc$ >>
604
) ~init:record
605
in
606
record
607
608
and typerep_of_variant ~type_name ctyp =
609
let loc = Ast.loc_of_ctyp ctyp in
610
let variants = Branches.variants ctyp in
611
let tags = Util.Variant.tags ~loc ~typerep_of_type ~variants in
612
let tag_ident i = Util.Variant.tag_n_ident ~variants i in
613
let tags_array =
614
let tags =
615
List.map ~f:(fun (index,_) ->
616
<:expr< Typerep_lib.Std.Typerep.Variant_internal.Tag $lid:tag_ident index$ >>
617
) tags
618
in
619
<:expr< [| $list:tags$ |] >>
620
in
621
let bindings = [
622
"typename", Util.typename_field ~loc ~type_name;
623
"tags", tags_array;
624
"polymorphic", Util.Variant.polymorphic ~loc ~variants;
625
"value", Util.Variant.value ~loc ~variants;
626
] in
627
let tags_binding =
628
let map (name, _) =
629
<:rec_binding< Typerep_lib.Std.Typerep.Variant_internal.
630
$lid:name$ = $lid:name$ >>
631
in
632
List.map ~f:map bindings
633
in
634
let variant =
635
let tags = <:expr< Typerep_lib.Std.Typerep.Variant.internal_use_only
636
{ $list:tags_binding$ } >> in
637
<:expr< Typerep_lib.Std.Typerep.Variant $tags$ >>
638
in
639
let variant = Gen.let_in loc bindings variant in
640
let variant = List.fold_right tags ~f:(fun (index, expr) acc ->
641
<:expr< let $lid:tag_ident index$ = $expr$ in $acc$ >>
642
) ~init:variant
643
in
644
variant
645
646
let impl_of_one_def ~loc ~type_name ~params ~rhs:ctyp =
647
let rec body ctyp =
648
Gen.switch_tp_def ctyp
649
~alias:(fun (_:Loc.t) ctyp -> typerep_of_type ctyp)
650
~sum:(fun (_:Loc.t) -> typerep_of_variant ~type_name:(Some type_name))
651
~record:(fun (_:Loc.t) -> typerep_of_record ~type_name)
652
~variants:(fun (_:Loc.t) -> typerep_of_variant ~type_name:(Some type_name))
653
~mani:(fun (_:Loc.t) _tp1 ctyp -> body ctyp)
654
~nil:(fun loc ->
655
Loc.raise loc (Failure "typerep cannot be applied on abstract types, except \
656
like 'type t with typerep(abstract)'")
657
)
658
in
659
let body = body ctyp in
660
let params_names = Util.params_names ~params in
661
let params_patts = Util.params_patts ~loc ~params_names in
662
let body = Util.with_named ~loc ~type_name ~params_names body in
663
let arguments = List.map2 params_names params_patts ~f:(fun name patt ->
664
(* Add type annotations to parameters, at least to avoid the unused type warning. *)
665
let loc = Ast.loc_of_patt patt in
666
<:patt< ($patt$ : Typerep_lib.Std.Typerep.t $lid:name$) >>)
667
in
668
let body = Gen.abstract loc arguments body in
669
let body = List.fold_right params_names ~init:body ~f:(fun name acc ->
670
<:expr< fun (type $name$) -> $acc$ >> )
671
in
672
let body =
673
match Util.typerep_of_t_coerce ~loc ~type_name ~params_names with
674
| Some coerce ->
675
<:expr< ($body$ : $coerce$) >>
676
| None -> body
677
in
678
let bnd = Gen.idp loc ("typerep_of_" ^ type_name) in
679
let binding = <:binding< $bnd$ = $body$ >> in
680
Util.type_name_module_definition ~loc ~type_name ~params_names, binding
681
682
let rec with_typerep_aux = function
683
| Ast.TyDcl (loc, type_name, params, rhs, _cl) ->
684
[impl_of_one_def ~loc ~type_name ~params ~rhs]
685
| <:ctyp< $ctyp1$ and $ctyp2$ >> ->
686
with_typerep_aux ctyp1 @ with_typerep_aux ctyp2
687
| _ -> assert false
688
689
let with_typerep rec_ ctyp =
690
let loc, rec_ =
691
match ctyp with
692
| Ast.TyDcl (loc, type_name, _, rhs, _) ->
693
loc, rec_ && Gen.type_is_recursive type_name rhs
694
| <:ctyp@loc< $_$ and $_$ >> ->
695
loc, rec_
696
| _ -> assert false
697
in
698
let rec_flag =
699
match rec_ with
700
| true -> <:rec_flag< rec >>
701
| false -> <:rec_flag< >>
702
in
703
let prelude, bindings = List.split (with_typerep_aux ctyp) in
704
<:str_item<
705
$list:prelude$;
706
value $rec:rec_flag$ $list:bindings$;
707
>>
708
709
let rec with_typerep_abstract rec_ ctyp =
710
match ctyp with
711
| Ast.TyDcl (loc, type_name, params, _ctyp, _cl) ->
712
ignore rec_;
713
let params_names = Util.params_names ~params in
714
Util.typerep_abstract ~loc ~type_name ~params_names
715
| <:ctyp@loc< $ctyp1$ and $ctyp2$ >> ->
716
<:str_item<
717
$with_typerep_abstract rec_ ctyp1$;
718
$with_typerep_abstract rec_ ctyp2$;
719
>>
720
| _ ->
721
Gen.error ctyp ~fn:"typerep impl_gen" ~msg:"unsupported type def"
722
723
module Config = struct
724
type t = {
725
abstract : bool;
726
warn_23_field : unit;
727
}
728
729
let default = {
730
abstract = false;
731
warn_23_field = ();
732
}
733
734
let gram_entry : t Gram.Entry.t = Gram.Entry.mk "typerep_arguments"
735
736
EXTEND Gram
737
GLOBAL: gram_entry;
738
typerep_arg: [[
739
LIDENT "abstract" -> (fun acc -> { acc with abstract = true })
740
| id = LIDENT ->
741
Loc.raise loc (Failure (Printf.sprintf "Unknown typerep argument %S" id));
742
]];
743
gram_entry: [[
744
v = LIST0 typerep_arg SEP "," ; `EOI ->
745
ignore loc; (* don't know how to ignore it otherwise *)
746
List.fold_left v
747
~f:(fun acc f -> f acc)
748
~init:default
749
]];
750
END
751
752
end
753
754
let () = Pa_type_conv.add_generator_with_arg "typerep" Config.gram_entry
755
(fun conf rec_ ctyp ->
756
let config = match conf with None -> Config.default | Some conf -> conf in
757
if config.Config.abstract
758
then with_typerep_abstract rec_ ctyp
759
else with_typerep rec_ ctyp
760
)
761
762
let typerep_of_quote (loc : Ast.loc) (_loc_name_opt : string option) (cnt_str : string) =
763
Pa_type_conv.set_conv_path_if_not_set loc;
764
let ctyp = Gram.parse_string Syntax.ctyp_quot loc cnt_str in
765
typerep_of_type ctyp
766
767
let () =
768
Quotation.add "typerep_of" Quotation.DynAst.expr_tag typerep_of_quote
769
end
Loggerhead is a web-based interface for Breezy
Version: 2.0.1