« back to all changes in this revision
Viewing changes to lib/type_generic.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
lib/type_generic.ml
1
open Std_internal
2
3
module Variant_and_record_intf = Variant_and_record_intf
4
5
module Helper (A : Variant_and_record_intf.S) (B : Variant_and_record_intf.S) = struct
6
7
type map = { map : 'a. 'a A.t -> 'a B.t }
8
9
let map_variant (type variant) { map } (variant : variant A.Variant.t) =
10
let map_create = function
11
| A.Tag.Args fct -> B.Tag_internal.Args fct
12
| A.Tag.Const k -> B.Tag_internal.Const k
13
in
14
let map_tag tag =
15
match tag with
16
| A.Variant.Tag tag ->
17
let label = A.Tag.label tag in
18
let rep = map (A.Tag.traverse tag) in
19
let arity = A.Tag.arity tag in
20
let index = A.Tag.index tag in
21
let ocaml_repr = A.Tag.ocaml_repr tag in
22
let tyid = A.Tag.tyid tag in
23
let create = map_create (A.Tag.create tag) in
24
B.Variant_internal.Tag (B.Tag.internal_use_only {
25
B.Tag_internal.label; rep; arity; index; ocaml_repr; tyid; create;
26
})
27
in
28
let typename = A.Variant.typename_of_t variant in
29
let polymorphic = A.Variant.is_polymorphic variant in
30
let tags = Array.init (A.Variant.length variant)
31
(fun index -> map_tag (A.Variant.tag variant index))
32
in
33
let value (a : variant) =
34
match A.Variant.value variant a with
35
| A.Variant.Value (atag, a) ->
36
(fun (type args) (atag : (variant, args) A.Tag.t) (a : args) ->
37
let (B.Variant_internal.Tag btag) = tags.(A.Tag.index atag) in
38
(fun (type ex) (btag : (variant, ex) B.Tag.t) ->
39
let Type_equal.T =
40
Typename.same_witness_exn (A.Tag.tyid atag) (B.Tag.tyid btag)
41
in
42
let btag = (btag : (variant, args) B.Tag.t) in
43
B.Variant_internal.Value (btag, a)
44
) btag
45
) atag a
46
in
47
B.Variant.internal_use_only {
48
B.Variant_internal.typename; tags; polymorphic; value;
49
}
50
51
let map_record (type record) { map } (record : record A.Record.t) =
52
let map_field field =
53
match field with
54
| A.Record.Field field ->
55
let label = A.Field.label field in
56
let rep = map (A.Field.traverse field) in
57
let index = A.Field.index field in
58
let tyid = A.Field.tyid field in
59
let get = A.Field.get field in
60
B.Record_internal.Field (B.Field.internal_use_only {
61
B.Field_internal.label; rep; index; tyid; get;
62
})
63
in
64
let typename = A.Record.typename_of_t record in
65
let has_double_array_tag = A.Record.has_double_array_tag record in
66
let fields = Array.init (A.Record.length record)
67
(fun index -> map_field (A.Record.field record index))
68
in
69
let create { B.Record_internal.get } =
70
let get (type a) (afield : (_, a) A.Field.t) =
71
match fields.(A.Field.index afield) with
72
| B.Record_internal.Field bfield ->
73
(fun (type ex) (bfield : (record, ex) B.Field.t) ->
74
let Type_equal.T =
75
Typename.same_witness_exn (A.Field.tyid afield) (B.Field.tyid bfield)
76
in
77
let bfield = (bfield : (record, a) B.Field.t) in
78
get bfield
79
) bfield
80
in
81
A.Record.create record { A.Record.get }
82
in
83
B.Record.internal_use_only {
84
B.Record_internal.typename; fields; has_double_array_tag; create;
85
}
86
end
87
88
module type Named = sig
89
type 'a computation
90
module Context : sig
91
type t
92
val create : unit -> t
93
end
94
type 'a t
95
val init : Context.t -> 'a Typename.t -> 'a t
96
val get_wip_computation : 'a t -> 'a computation
97
val set_final_computation : 'a t -> 'a computation -> 'a computation
98
val share : _ Typerep.t -> bool
99
end
100
101
module type Computation = sig
102
type 'a t
103
104
include Variant_and_record_intf.S with type 'a t := 'a t
105
106
val int : int t
107
val int32 : int32 t
108
val int64 : int64 t
109
val nativeint : nativeint t
110
val char : char t
111
val float : float t
112
val string : string t
113
val bool : bool t
114
val unit : unit t
115
val option : 'a t -> 'a option t
116
val list : 'a t -> 'a list t
117
val array : 'a t -> 'a array t
118
val lazy_t : 'a t -> 'a lazy_t t
119
val ref_ : 'a t -> 'a ref t
120
val function_ : 'a t -> 'b t -> ('a -> 'b) t
121
val tuple2 : 'a t -> 'b t -> ('a * 'b) t
122
val tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
123
val tuple4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
124
val tuple5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t
125
val record : 'a Record.t -> 'a t
126
val variant : 'a Variant.t -> 'a t
127
128
module Named : Named with type 'a computation := 'a t
129
end
130
131
(* special functor application for computation as closure of the form [a -> b] *)
132
module Make_named_for_closure (X : sig
133
type 'a input
134
type 'a output
135
type 'a t = 'a input -> 'a output
136
end) = struct
137
138
module Context = struct
139
type t = unit
140
let create = ignore
141
end
142
143
type 'a t = {
144
runtime_dereference : 'a X.t;
145
runtime_reference : 'a X.t ref;
146
compiletime_dereference : 'a X.t option ref;
147
}
148
149
exception Undefined of string
150
151
let init () name =
152
let path = Typename.Uid.name (Typename.uid name) in
153
let r = ref (fun _ -> raise (Undefined path)) in
154
{
155
runtime_dereference = (fun input -> !r input);
156
runtime_reference = r;
157
compiletime_dereference = ref None;
158
}
159
160
let get_wip_computation shared =
161
match shared.compiletime_dereference.contents with
162
| Some clos -> clos
163
| None -> shared.runtime_dereference
164
165
let set_final_computation shared computation =
166
let compiletime_dereference = shared.compiletime_dereference in
167
match compiletime_dereference.contents with
168
| Some _ -> assert false
169
| None ->
170
if Pervasives.(==) shared.runtime_dereference computation then assert false;
171
compiletime_dereference := Some computation;
172
shared.runtime_reference := computation;
173
computation
174
175
let share _ = true
176
end
177
178
module Ident = struct
179
type t = {
180
name : string;
181
implements : Typename.Uid.t -> bool;
182
}
183
exception Broken_dependency of string
184
let check_dependencies name required =
185
match required with
186
| [] -> (fun _ -> ())
187
| _ ->
188
(fun uid ->
189
List.iter (fun { name = name'; implements } ->
190
if not (implements uid) then begin
191
(* something is wrong with the set up, this is an error during the
192
initialization of the program, we rather fail with a human
193
readable output *)
194
let message =
195
Printf.sprintf "Type_generic %S requires %S for uid %S\n"
196
name name' (Typename.Uid.name uid)
197
in
198
prerr_endline message;
199
raise (Broken_dependency message)
200
end
201
) required)
202
end
203
204
(* Extending an existing generic *)
205
module type Extending = sig
206
207
type 'a t
208
type 'a computation = 'a t
209
210
val ident : Ident.t
211
212
(* generic_ident * typename or info *)
213
exception Not_implemented of string * string
214
215
module type S0 = sig
216
type t
217
include Typerepable.S0 with type t := t
218
val compute : t computation
219
end
220
221
module type S1 = sig
222
type 'a t
223
include Typerepable.S1 with type 'a t := 'a t
224
val compute : 'a computation -> 'a t computation
225
end
226
227
module type S2 = sig
228
type ('a, 'b) t
229
include Typerepable.S2 with type ('a, 'b) t := ('a, 'b) t
230
val compute : 'a computation -> 'b computation -> ('a, 'b) t computation
231
end
232
233
module type S3 = sig
234
type ('a, 'b, 'c) t
235
include Typerepable.S3 with type ('a, 'b, 'c) t := ('a, 'b, 'c) t
236
val compute :
237
'a computation
238
-> 'b computation
239
-> 'c computation
240
-> ('a, 'b, 'c) t computation
241
end
242
243
module type S4 = sig
244
type ('a, 'b, 'c, 'd) t
245
include Typerepable.S4 with type ('a, 'b, 'c, 'd) t := ('a, 'b, 'c, 'd) t
246
val compute :
247
'a computation
248
-> 'b computation
249
-> 'c computation
250
-> 'd computation
251
-> ('a, 'b, 'c, 'd) t computation
252
end
253
254
module type S5 = sig
255
type ('a, 'b, 'c, 'd, 'e) t
256
include Typerepable.S5 with type ('a, 'b, 'c, 'd, 'e) t := ('a, 'b, 'c, 'd, 'e) t
257
val compute :
258
'a computation
259
-> 'b computation
260
-> 'c computation
261
-> 'd computation
262
-> 'e computation
263
-> ('a, 'b, 'c, 'd, 'e) t computation
264
end
265
266
val register0 : (module S0) -> unit
267
val register1 : (module S1) -> unit
268
val register2 : (module S2) -> unit
269
val register3 : (module S3) -> unit
270
val register4 : (module S4) -> unit
271
val register5 : (module S5) -> unit
272
273
(* special less scary type when the type has no parameters *)
274
val register : 'a Typerep.t -> 'a computation -> unit
275
276
(*
277
Essentially because we cannot talk about a variable of kind * -> k
278
val register1 : 'a 't Typerep.t -> ('a computation -> 'a 't computation) -> unit
279
...
280
*)
281
end
282
283
(* Implementing a new generic *)
284
module type S_implementation = sig
285
286
include Extending
287
288
(* raise using the current ident *)
289
val raise_not_implemented : string -> 'a
290
291
type implementation = {
292
generic : 'a. 'a Typerep.t -> 'a computation;
293
}
294
295
(*
296
Standard case, find a extended_implementation, or look in the content
297
*)
298
val _using_extended_implementation :
299
implementation
300
-> 'a Typerep.Named.t
301
-> 'a Typerep.t Lazy.t option
302
-> 'a computation
303
304
(*
305
This function allows you more control on what you want to do
306
*)
307
val find_extended_implementation :
308
implementation -> 'a Typerep.Named.t -> 'a computation option
309
end
310
311
module type S = sig
312
include Extending
313
val of_typerep : 'a Typerep.t -> [ `generic of 'a computation ]
314
module Computation : Computation with type 'a t = 'a t
315
end
316
317
module Make_S_implementation(X : sig
318
type 'a t
319
val name : string
320
val required : Ident.t list
321
end) : S_implementation with type 'a t = 'a X.t = struct
322
type 'a t = 'a X.t
323
type 'a computation = 'a t
324
325
include Type_generic_intf.M(struct type 'a t = 'a computation end)
326
327
(* we do not use core since we are earlier in the dependencies graph *)
328
module Uid_table = struct
329
include Hashtbl.Make(Typename.Uid)
330
let find table key =
331
if Lazy.lazy_is_val table then
332
let table = Lazy.force table in
333
try Some (find table key) with Not_found -> None
334
else None
335
let check_dependencies = Ident.check_dependencies X.name X.required
336
let replace table key value =
337
check_dependencies key;
338
replace (Lazy.force table) key value
339
let mem table key =
340
if Lazy.lazy_is_val table then
341
let table = Lazy.force table in
342
mem table key
343
else false
344
end
345
346
let size = 256
347
let table0 = lazy (Uid_table.create size)
348
let table1 = lazy (Uid_table.create size)
349
let table2 = lazy (Uid_table.create size)
350
let table3 = lazy (Uid_table.create size)
351
let table4 = lazy (Uid_table.create size)
352
let table5 = lazy (Uid_table.create size)
353
354
let is_registered uid =
355
Uid_table.mem table0 uid
356
|| Uid_table.mem table1 uid
357
|| Uid_table.mem table2 uid
358
|| Uid_table.mem table3 uid
359
|| Uid_table.mem table4 uid
360
|| Uid_table.mem table5 uid
361
362
let ident = { Ident.
363
name = X.name;
364
implements = is_registered;
365
}
366
367
module Find0(T : Typerep.Named.T0) : sig
368
val compute : unit -> T.named computation option
369
end = struct
370
let compute () =
371
match Uid_table.find table0 (Typename.uid T.typename_of_t) with
372
| None -> None
373
| Some rep ->
374
let module S0 = (val rep : S0) in
375
let witness = Typename.same_witness_exn S0.typename_of_t T.typename_of_named in
376
let module L = Type_equal.Lift(struct
377
type 'a t = 'a computation
378
end) in
379
Some (Type_equal.conv (L.lift witness) S0.compute)
380
end
381
382
module Find1(T : Typerep.Named.T1) : sig
383
val compute : unit -> (T.a computation -> T.a T.named computation) option
384
end = struct
385
let compute () =
386
match Uid_table.find table1 (Typename.uid T.typename_of_t) with
387
| None -> None
388
| Some rep ->
389
let module S1 = (val rep : S1) in
390
let module Conv = Typename.Same_witness_exn_1(S1)(struct
391
type 'a t = 'a T.named
392
let typename_of_t = T.typename_of_named
393
end) in
394
let module L = Type_equal.Lift(struct
395
type 'a t = T.a computation -> 'a computation
396
end) in
397
Some (Type_equal.conv (L.lift Conv.(witness.eq)) S1.compute)
398
end
399
400
module Find2(T : Typerep.Named.T2) : sig
401
val compute : unit
402
-> (T.a computation
403
-> T.b computation
404
-> (T.a, T.b) T.named computation) option
405
end = struct
406
let compute () =
407
match Uid_table.find table2 (Typename.uid T.typename_of_t) with
408
| None -> None
409
| Some rep ->
410
let module S2 = (val rep : S2) in
411
let module Conv = Typename.Same_witness_exn_2(S2)(struct
412
type ('a, 'b) t = ('a, 'b) T.named
413
let typename_of_t = T.typename_of_named
414
end) in
415
let module L = Type_equal.Lift(struct
416
type 'a t =
417
T.a computation
418
-> T.b computation
419
-> 'a computation
420
end) in
421
Some (Type_equal.conv (L.lift Conv.(witness.eq)) S2.compute)
422
end
423
424
module Find3(T : Typerep.Named.T3) : sig
425
val compute : unit
426
-> (T.a computation
427
-> T.b computation
428
-> T.c computation
429
-> (T.a, T.b, T.c) T.named computation) option
430
end = struct
431
let compute () =
432
match Uid_table.find table3 (Typename.uid T.typename_of_t) with
433
| None -> None
434
| Some rep ->
435
let module S3 = (val rep : S3) in
436
let module Conv = Typename.Same_witness_exn_3(S3)(struct
437
type ('a, 'b, 'c) t = ('a, 'b, 'c) T.named
438
let typename_of_t = T.typename_of_named
439
end) in
440
let module L = Type_equal.Lift(struct
441
type 'a t =
442
T.a computation
443
-> T.b computation
444
-> T.c computation
445
-> 'a computation
446
end) in
447
Some (Type_equal.conv (L.lift Conv.(witness.eq)) S3.compute)
448
end
449
450
module Find4(T : Typerep.Named.T4) : sig
451
val compute : unit
452
-> (T.a computation
453
-> T.b computation
454
-> T.c computation
455
-> T.d computation
456
-> (T.a, T.b, T.c, T.d) T.named computation) option
457
end = struct
458
let compute () =
459
match Uid_table.find table4 (Typename.uid T.typename_of_t) with
460
| None -> None
461
| Some rep ->
462
let module S4 = (val rep : S4) in
463
let module Conv = Typename.Same_witness_exn_4(S4)(struct
464
type ('a, 'b, 'c, 'd) t = ('a, 'b, 'c, 'd) T.named
465
let typename_of_t = T.typename_of_named
466
end) in
467
let module L = Type_equal.Lift(struct
468
type 'a t =
469
T.a computation
470
-> T.b computation
471
-> T.c computation
472
-> T.d computation
473
-> 'a computation
474
end) in
475
Some (Type_equal.conv (L.lift Conv.(witness.eq)) S4.compute)
476
end
477
478
module Find5(T : Typerep.Named.T5) : sig
479
val compute : unit
480
-> (T.a computation
481
-> T.b computation
482
-> T.c computation
483
-> T.d computation
484
-> T.e computation
485
-> (T.a, T.b, T.c, T.d, T.e) T.named computation) option
486
end = struct
487
let compute () =
488
match Uid_table.find table5 (Typename.uid T.typename_of_t) with
489
| None -> None
490
| Some rep ->
491
let module S5 = (val rep : S5) in
492
let module Conv = Typename.Same_witness_exn_5(S5)(struct
493
type ('a, 'b, 'c, 'd, 'e) t = ('a, 'b, 'c, 'd, 'e) T.named
494
let typename_of_t = T.typename_of_named
495
end) in
496
let module L = Type_equal.Lift(struct
497
type 'a t =
498
T.a computation
499
-> T.b computation
500
-> T.c computation
501
-> T.d computation
502
-> T.e computation
503
-> 'a computation
504
end) in
505
Some (Type_equal.conv (L.lift Conv.(witness.eq)) S5.compute)
506
end
507
508
let unit = Typename.static
509
510
let register0 compute =
511
let module S0 = (val compute : S0) in
512
let uid = Typename.uid S0.typename_of_t in
513
Uid_table.replace table0 uid compute
514
515
let register1 compute =
516
let module S1 = (val compute : S1) in
517
let uid = Typename.uid (S1.typename_of_t unit) in
518
Uid_table.replace table1 uid compute
519
520
let register2 compute =
521
let module S2 = (val compute : S2) in
522
let uid = Typename.uid (S2.typename_of_t unit unit) in
523
Uid_table.replace table2 uid compute
524
525
let register3 compute =
526
let module S3 = (val compute : S3) in
527
let uid = Typename.uid (S3.typename_of_t unit unit unit) in
528
Uid_table.replace table3 uid compute
529
530
let register4 compute =
531
let module S4 = (val compute : S4) in
532
let uid = Typename.uid (S4.typename_of_t unit unit unit unit) in
533
Uid_table.replace table4 uid compute
534
535
let register5 compute =
536
let module S5 = (val compute : S5) in
537
let uid = Typename.uid (S5.typename_of_t unit unit unit unit unit) in
538
Uid_table.replace table5 uid compute
539
540
let register (type a) typerep_of_a compute =
541
let module S0 = struct
542
type t = a
543
let typename_of_t = Typerep.typename_of_t typerep_of_a
544
let typerep_of_t = typerep_of_a
545
let compute = compute
546
end in
547
register0 (module S0 : S0)
548
549
(* IMPLEMENTATION *)
550
551
type implementation = {
552
generic : 'a. 'a Typerep.t -> 'a computation;
553
}
554
555
let find_extended_implementation (type a) aux = function
556
| Typerep.Named.T0 rep -> begin
557
let module T = (val rep : Typerep.Named.T0 with type t = a) in
558
let module Custom = Find0(T) in
559
match Custom.compute () with
560
| Some custom ->
561
let Type_equal.T = T.witness in
562
Some (custom : a computation)
563
| None -> None
564
end
565
566
| Typerep.Named.T1 rep -> begin
567
let module T = (val rep : Typerep.Named.T1 with type t = a) in
568
let module Custom = Find1(T) in
569
match Custom.compute () with
570
| Some custom ->
571
let custom = (custom (aux.generic T.a) : T.a T.named computation) in
572
let Type_equal.T = T.witness in
573
Some (custom : a computation)
574
| None -> None
575
end
576
577
| Typerep.Named.T2 rep -> begin
578
let module T = (val rep : Typerep.Named.T2 with type t = a) in
579
let module Custom = Find2(T) in
580
match Custom.compute () with
581
| Some custom ->
582
let custom =
583
(custom
584
(aux.generic T.a)
585
(aux.generic T.b)
586
: (T.a, T.b) T.named computation) in
587
let Type_equal.T = T.witness in
588
Some (custom : a computation)
589
| None -> None
590
end
591
592
| Typerep.Named.T3 rep -> begin
593
let module T = (val rep : Typerep.Named.T3 with type t = a) in
594
let module Custom = Find3(T) in
595
match Custom.compute () with
596
| Some custom ->
597
let custom =
598
(custom
599
(aux.generic T.a)
600
(aux.generic T.b)
601
(aux.generic T.c)
602
: (T.a, T.b, T.c) T.named computation) in
603
let Type_equal.T = T.witness in
604
Some (custom : a computation)
605
| None -> None
606
end
607
608
| Typerep.Named.T4 rep -> begin
609
let module T = (val rep : Typerep.Named.T4 with type t = a) in
610
let module Custom = Find4(T) in
611
match Custom.compute () with
612
| Some custom ->
613
let custom =
614
(custom
615
(aux.generic T.a)
616
(aux.generic T.b)
617
(aux.generic T.c)
618
(aux.generic T.d)
619
: (T.a, T.b, T.c, T.d) T.named computation) in
620
let Type_equal.T = T.witness in
621
Some (custom : a computation)
622
| None -> None
623
end
624
625
| Typerep.Named.T5 rep -> begin
626
let module T = (val rep : Typerep.Named.T5 with type t = a) in
627
let module Custom = Find5(T) in
628
match Custom.compute () with
629
| Some custom ->
630
let custom =
631
(custom
632
(aux.generic T.a)
633
(aux.generic T.b)
634
(aux.generic T.c)
635
(aux.generic T.d)
636
(aux.generic T.e)
637
: (T.a, T.b, T.c, T.d, T.e) T.named computation) in
638
let Type_equal.T = T.witness in
639
Some (custom : a computation)
640
| None -> None
641
end
642
643
exception Not_implemented of string * string
644
645
let raise_not_implemented string = raise (Not_implemented (X.name, string))
646
647
let _using_extended_implementation aux rep content =
648
match find_extended_implementation aux rep with
649
| Some computation -> computation
650
| None -> begin
651
match content with
652
| Some (lazy content) -> aux.generic content
653
| None ->
654
let typename = Typerep.Named.typename_of_t rep in
655
let name = Typename.Uid.name (Typename.uid typename) in
656
raise_not_implemented name
657
end
658
end
659
660
module Key_table = Hashtbl.Make(Typename.Key)
661
662
module Make(X : sig
663
type 'a t
664
val name : string
665
val required : Ident.t list
666
include Computation with type 'a t := 'a t
667
end) = struct
668
669
module Computation = X
670
671
include Make_S_implementation(X)
672
673
module Memo = Typename.Table(struct type 'a t = 'a X.Named.t end)
674
675
module Helper = Helper(Typerep)(Computation)
676
677
let of_typerep rep =
678
let context = X.Named.Context.create () in
679
let memo_table = Memo.create 32 in
680
let rec of_typerep : type a. a Typerep.t -> a t = function
681
| Typerep.Int -> X.int
682
| Typerep.Int32 -> X.int32
683
| Typerep.Int64 -> X.int64
684
| Typerep.Nativeint -> X.nativeint
685
| Typerep.Char -> X.char
686
| Typerep.Float -> X.float
687
| Typerep.String -> X.string
688
| Typerep.Bool -> X.bool
689
| Typerep.Unit -> X.unit
690
| Typerep.Option rep -> X.option (of_typerep rep)
691
| Typerep.List rep -> X.list (of_typerep rep)
692
| Typerep.Array rep -> X.array (of_typerep rep)
693
| Typerep.Lazy rep -> X.lazy_t (of_typerep rep)
694
| Typerep.Ref rep -> X.ref_ (of_typerep rep)
695
| Typerep.Function (dom, rng) ->
696
X.function_ (of_typerep dom) (of_typerep rng)
697
| Typerep.Tuple tuple -> begin
698
(* do NOT write [X.tuple2 (of_typerep a) (of_typerep b)]
699
because of_typerep can contain a side effect and [a] should be executed
700
before [b] *)
701
match tuple with
702
| Typerep.Tuple.T2 (a, b) ->
703
let ra = of_typerep a in
704
let rb = of_typerep b in
705
X.tuple2 ra rb
706
| Typerep.Tuple.T3 (a, b, c) ->
707
let ra = of_typerep a in
708
let rb = of_typerep b in
709
let rc = of_typerep c in
710
X.tuple3 ra rb rc
711
| Typerep.Tuple.T4 (a, b, c, d) ->
712
let ra = of_typerep a in
713
let rb = of_typerep b in
714
let rc = of_typerep c in
715
let rd = of_typerep d in
716
X.tuple4 ra rb rc rd
717
| Typerep.Tuple.T5 (a, b, c, d, e) ->
718
let ra = of_typerep a in
719
let rb = of_typerep b in
720
let rc = of_typerep c in
721
let rd = of_typerep d in
722
let re = of_typerep e in
723
X.tuple5 ra rb rc rd re
724
end
725
| Typerep.Record record ->
726
X.record (Helper.map_record { Helper.map = of_typerep } record)
727
| Typerep.Variant variant ->
728
X.variant (Helper.map_variant { Helper.map = of_typerep } variant)
729
| Typerep.Named (named, content) -> begin
730
let typename = Typerep.Named.typename_of_t named in
731
match Memo.find memo_table typename with
732
| Some shared ->
733
X.Named.get_wip_computation shared
734
| None -> begin
735
match find_extended_implementation { generic = of_typerep } named with
736
| Some computation -> computation
737
| None -> begin
738
match content with
739
| None ->
740
let name = Typename.Uid.name (Typename.uid typename) in
741
raise_not_implemented name
742
| Some (lazy content) ->
743
if X.Named.share content
744
then
745
let shared = X.Named.init context typename in
746
Memo.set memo_table typename shared;
747
let computation = of_typerep content in
748
X.Named.set_final_computation shared computation
749
else
750
of_typerep content
751
end
752
end
753
end
754
in
755
let computation = of_typerep rep in
756
`generic computation
757
end
Loggerhead is a web-based interface for Breezy
Version: 2.0.1