« back to all changes in this revision
Viewing changes to extended/lib/type_struct.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
extended/lib/type_struct.ml
1
open Typerep_lib.Std
2
open Pre_core.Std
3
4
5
6
module Name = struct
7
include Int
8
let typerep_of_t = typerep_of_int
9
let make_fresh () =
10
let index = ref (-1) in
11
(fun () -> incr index; !index)
12
let incompatible = (-1)
13
end
14
15
module Variant = struct
16
module Kind = struct
17
type t =
18
| Polymorphic
19
| Usual
20
with sexp, typerep, bin_io
21
22
let is_polymorphic = function
23
| Polymorphic -> true
24
| Usual -> false
25
let equal a b =
26
match a with
27
| Polymorphic -> b = Polymorphic
28
| Usual -> b = Usual
29
end
30
module V1 = struct
31
type t = {
32
name : string;
33
repr : int;
34
} with sexp, bin_io, typerep
35
end
36
module V2 = struct
37
type t = {
38
label : string;
39
index : int;
40
ocaml_repr : int;
41
} with sexp, bin_io, typerep
42
end
43
include V2
44
let label t = t.label
45
let index t = t.index
46
let ocaml_repr t = t.ocaml_repr
47
let to_v1 kind t =
48
let name = t.label in
49
let repr = if Kind.is_polymorphic kind then t.ocaml_repr else t.index in
50
{ V1.name ; repr }
51
let of_v1 kind index this all v1 =
52
if Kind.is_polymorphic kind
53
then
54
{ label = v1.V1.name;
55
index;
56
ocaml_repr = v1.V1.repr; }
57
else
58
let ocaml_repr =
59
let no_arg = Farray.is_empty this in
60
let rec count pos acc =
61
if pos = index then acc
62
else
63
let _, args = Farray.get all pos in
64
let acc = if no_arg = Farray.is_empty args then succ acc else acc in
65
count (succ pos) acc
66
in
67
count 0 0
68
in
69
{ label = v1.V1.name;
70
index = (if index <> v1.V1.repr then assert false; index);
71
ocaml_repr;
72
}
73
74
module Option = struct
75
let none = {
76
index = 0;
77
ocaml_repr = 0;
78
label = "None";
79
}
80
let some = {
81
index = 1;
82
ocaml_repr = 0;
83
label = "Some";
84
}
85
end
86
end
87
88
module Variant_infos = struct
89
module V1 = struct
90
type t = {
91
kind : Variant.Kind.t;
92
} with sexp, bin_io, typerep
93
end
94
include V1
95
let equal t t' = Variant.Kind.equal t.kind t'.kind
96
end
97
98
module Field = struct
99
module V1 = struct
100
type t = string with sexp, bin_io, typerep
101
end
102
module V2 = struct
103
type t = {
104
label : string;
105
index : int;
106
} with sexp, bin_io, typerep
107
end
108
(* module V3 = struct
109
* type t = {
110
* label : string;
111
* index : int;
112
* is_mutable : bool;
113
* etc...
114
* }
115
* end *)
116
include V2
117
let label t = t.label
118
let index t = t.index
119
let to_v1 t = t.label
120
let of_v1 index label = {
121
label;
122
index;
123
}
124
end
125
126
module Record_infos = struct
127
module V1 = struct
128
type t = {
129
has_double_array_tag : bool;
130
} with sexp, bin_io, typerep
131
end
132
include V1
133
let equal t t' = t.has_double_array_tag = t'.has_double_array_tag
134
end
135
136
module T = struct
137
type t =
138
| Int
139
| Int32
140
| Int64
141
| Nativeint
142
| Char
143
| Float
144
| String
145
| Bool
146
| Unit
147
| Option of t
148
| List of t
149
| Array of t
150
| Lazy of t
151
| Ref of t
152
| Tuple of t Farray.t
153
| Record of Record_infos.t * (Field.t * t) Farray.t
154
| Variant of Variant_infos.t * (Variant.t * t Farray.t) Farray.t
155
| Named of Name.t * t option
156
with sexp, typerep
157
end
158
include T
159
160
type type_struct = t with sexp
161
162
let incompatible () = Named (Name.incompatible, None)
163
164
let get_variant_by_repr {Variant_infos.kind} cases repr =
165
if Variant.Kind.is_polymorphic kind
166
then
167
Farray.findi cases ~f:(fun _ ((variant, _) as case) ->
168
if Int.equal variant.Variant.ocaml_repr repr then Some case else None)
169
else
170
let length = Farray.length cases in
171
if repr < 0 || repr >= length then None else
172
let (variant, _) as case = Farray.get cases repr in
173
(if variant.Variant.index <> repr then assert false);
174
Some case
175
176
let get_variant_by_label _infos cases label =
177
Farray.findi cases ~f:(fun _ ((variant, _) as case) ->
178
if String.equal variant.Variant.label label then Some case else None)
179
180
let rec is_polymorphic_variant = function
181
| Named (_, Some content) -> is_polymorphic_variant content
182
| Variant ({Variant_infos.kind}, _) -> Variant.Kind.is_polymorphic kind
183
| _ -> false
184
185
let variant_args_of_type_struct ~arity str =
186
match arity with
187
| 0 ->
188
if str = Unit
189
then Farray.empty ()
190
else assert false
191
| 1 -> Farray.make1 str
192
| _ ->
193
match str with
194
| Tuple args -> args
195
| _ -> assert false (* ill formed ast *)
196
197
let type_struct_of_variant_args args =
198
match Farray.length args with
199
| 0 -> Unit
200
| 1 -> Farray.get args 0
201
| _ -> Tuple args
202
203
module Option_as_variant = struct
204
open Variant
205
let kind = Kind.Usual
206
let infos = {
207
Variant_infos.
208
kind;
209
}
210
let make some_type =
211
infos, Farray.make2
212
(Option.none, Farray.empty ())
213
(Option.some, Farray.make1 some_type)
214
end
215
216
let option_as_variant ~some = Option_as_variant.make some
217
218
class traverse =
219
object(self)
220
method iter t =
221
let f t = self#iter t in
222
match t with
223
| Int
224
| Int32
225
| Int64
226
| Nativeint
227
| Char
228
| Float
229
| String
230
| Bool
231
| Unit
232
-> ()
233
| Option t -> f t
234
| List t -> f t
235
| Array t -> f t
236
| Lazy t -> f t
237
| Ref t -> f t
238
| Tuple args ->
239
Farray.iter ~f args
240
| Record ((_:Record_infos.t), fields) ->
241
Farray.iter ~f:(fun ((_:Field.t), t) -> f t) fields
242
| Variant ((_:Variant_infos.t), cases) ->
243
Farray.iter ~f:(fun ((_:Variant.t), args) -> Farray.iter ~f args) cases
244
| Named (_, link) -> Option.iter link ~f
245
246
method map t =
247
let map_stable_snd ~f ((a, b) as t) =
248
let b' = f b in
249
if phys_equal b b' then t else (a, b')
250
in
251
let f t = self#map t in
252
match t with
253
| Int
254
| Int32
255
| Int64
256
| Nativeint
257
| Char
258
| Float
259
| String
260
| Bool
261
| Unit
262
-> t
263
| Option arg ->
264
let arg' = f arg in
265
if phys_equal arg arg' then t else Option arg'
266
| List arg ->
267
let arg' = f arg in
268
if phys_equal arg arg' then t else List arg'
269
| Array arg ->
270
let arg' = f arg in
271
if phys_equal arg arg' then t else Array arg'
272
| Lazy arg ->
273
let arg' = f arg in
274
if phys_equal arg arg' then t else Lazy arg'
275
| Ref arg ->
276
let arg' = f arg in
277
if phys_equal arg arg' then t else Ref arg'
278
| Tuple args ->
279
let args' = Farray.map_stable ~f args in
280
if phys_equal args args' then t else Tuple args'
281
| Record (infos, fields) ->
282
let fields' = Farray.map_stable ~f:(map_stable_snd ~f) fields in
283
if phys_equal fields fields' then t else Record (infos, fields')
284
| Variant (infos, cases) ->
285
let cases' = Farray.map_stable cases
286
~f:(map_stable_snd ~f:(Farray.map_stable ~f))
287
in
288
if phys_equal cases cases' then t else Variant (infos, cases')
289
| Named (name, link) ->
290
let link' = Option.map_stable ~f link in
291
if phys_equal link link' then t else Named (name, link')
292
end
293
294
module Raw = struct
295
module T = struct
296
type nonrec t = t with sexp
297
let compare = Pervasives.compare
298
let hash = Hashtbl.hash
299
end
300
include Hashable.Make(T)
301
end
302
303
module Named_utils(X:sig
304
type t with sexp_of
305
class traverse : object
306
method iter : t -> unit
307
method map : t -> t
308
end
309
val match_named : t -> [ `Named of Name.t * t option | `Other of t ]
310
val cons_named : Name.t -> t option -> t
311
end) = struct
312
let has_named t =
313
let module M = struct
314
exception Exists
315
end in
316
let exists = object
317
inherit X.traverse as super
318
method! iter t =
319
match X.match_named t with
320
| `Named _ -> raise M.Exists
321
| `Other t -> super#iter t
322
end in
323
try exists#iter t; false with M.Exists -> true
324
325
let remove_dead_links t =
326
let used = Name.Hash_set.create () in
327
let has_named = ref false in
328
let collect = object
329
inherit X.traverse as super
330
method! iter t =
331
super#iter t;
332
match X.match_named t with
333
| `Named (name, link) ->
334
has_named := true;
335
if Option.is_none link then Name.Hash_set.add used name
336
| `Other _ -> ()
337
end in
338
collect#iter t;
339
if not !has_named then t else begin
340
let map = object
341
inherit X.traverse as super
342
method! map t =
343
let t = super#map t in
344
match X.match_named t with
345
| `Named (name, Some arg) ->
346
if Name.Hash_set.mem used name then t else arg
347
| `Named (_, None) | `Other _ -> t
348
end in
349
map#map t
350
end
351
352
let alpha_conversion t =
353
if not (has_named t) then t else (* allocation optimization *)
354
let fresh_name = Name.make_fresh () in
355
let table = Name.Table.create () in
356
let rename i =
357
match Name.Table.find table i with
358
| Some i -> i
359
| None ->
360
let name = fresh_name () in
361
Name.Table.set table ~key:i ~data:name;
362
name
363
in
364
let rename = object
365
inherit X.traverse as super
366
method! map t =
367
match X.match_named t with
368
| `Named (name, arg) ->
369
let name' = rename name in
370
let t =
371
if Name.equal name name' then t else X.cons_named name' arg
372
in
373
super#map t
374
| `Other t -> super#map t
375
end in
376
rename#map t
377
378
exception Invalid_recursive_name of Name.t * X.t with sexp
379
380
let standalone_exn ~readonly (t:X.t) =
381
if not (has_named t) then t else (* allocation optimization *)
382
let local_table = Name.Table.create () in
383
let or_lookup name content =
384
match content with
385
| Some data ->
386
Name.Table.set local_table ~key:name ~data;
387
content
388
| None ->
389
match Name.Table.find local_table name with
390
| Some _ as content -> content
391
| None ->
392
match Name.Table.find readonly name with
393
| (Some data) as content ->
394
Name.Table.set local_table ~key:name ~data;
395
content
396
| None -> raise (Invalid_recursive_name (name, t))
397
in
398
let seen = Name.Hash_set.create () in
399
let enrich = object
400
inherit X.traverse as super
401
method! map t =
402
let t =
403
match X.match_named t with
404
| `Named (name, content) ->
405
if Name.Hash_set.mem seen name then begin
406
if Option.is_none content then t else
407
X.cons_named name None
408
end else begin
409
Name.Hash_set.add seen name;
410
let content' = or_lookup name content in
411
if phys_equal content content'
412
then t
413
else X.cons_named name content'
414
end
415
| `Other t -> t
416
in
417
super#map t
418
end in
419
enrich#map t
420
end
421
422
include Named_utils(struct
423
type t = type_struct with sexp_of
424
class traverse_non_rec = traverse
425
class traverse = traverse_non_rec
426
let match_named = function
427
| Named (name, link) -> `Named (name, link)
428
| t -> `Other t
429
let cons_named name contents = Named (name, contents)
430
end)
431
432
let reduce t =
433
let fresh_name = Name.make_fresh () in
434
let alias = Name.Table.create () in
435
let consing = Raw.Table.create () in
436
let share t =
437
match t with
438
| Named (name, None) -> begin
439
match Name.Table.find alias name with
440
| Some shared_name ->
441
if Name.equal name shared_name then t else Named (shared_name, None)
442
| None -> t
443
end
444
| Named (name, Some key) -> begin
445
match Raw.Table.find consing key with
446
| Some (shared_name, shared) ->
447
if not (Name.equal name shared_name) then
448
Name.Table.set alias ~key:name ~data:shared_name;
449
shared
450
| None ->
451
let shared = Named (name, None) in
452
let data = name, shared in
453
Raw.Table.set consing ~key ~data;
454
t
455
end
456
| (Record _ | Variant _) as key -> begin
457
match Raw.Table.find consing key with
458
| Some (_, shared) ->
459
shared
460
| None -> begin
461
let shared_name = fresh_name () in
462
let shared = Named (shared_name, None) in
463
let data = shared_name, shared in
464
Raw.Table.set consing ~key ~data;
465
Named (shared_name, Some key)
466
end
467
end
468
| Int
469
| Int32
470
| Int64
471
| Nativeint
472
| Char
473
| Float
474
| String
475
| Bool
476
| Unit
477
| Option _
478
| List _
479
| Array _
480
| Lazy _
481
| Ref _
482
| Tuple _
483
-> t
484
in
485
let share = object
486
inherit traverse as super
487
method! map t =
488
let t = super#map t in (* deep first *)
489
share t
490
end in
491
let shared = share#map t in
492
let reduced = remove_dead_links shared in
493
reduced
494
495
exception Invalid_recursive_typestruct of Name.t * t with sexp
496
497
let sort_variant_cases cases =
498
let cmp (variant, _) (variant', _) =
499
String.compare variant.Variant.label variant'.Variant.label
500
in
501
Farray.sort ~cmp cases
502
503
module Pairs = struct
504
module T = struct
505
type t = Name.t * Name.t with sexp
506
let compare (a, b) (a', b') =
507
let cmp = Name.compare a a' in
508
if cmp <> 0 then cmp else Name.compare b b'
509
let hash = Hashtbl.hash
510
end
511
include Hashable.Make(T)
512
end
513
514
let equivalent_array f a b =
515
let len_a = Farray.length a in
516
let len_b = Farray.length b in
517
if len_a <> len_b then false else
518
let rec aux index = if index = len_a then true else
519
f (Farray.get a index) (Farray.get b index) && aux (succ index)
520
in
521
aux 0
522
523
let are_equivalent a b =
524
let wip = Pairs.Table.create () in
525
let start_pair name name' =
526
Pairs.Table.set wip ~key:(name, name') ~data:`started
527
in
528
let finish_pair name name' result =
529
Pairs.Table.set wip ~key:(name, name') ~data:(`finished result)
530
in
531
let status name name' =
532
match Pairs.Table.find wip (name, name') with
533
| Some ((`started | `finished _) as status) -> status
534
| None -> `unknown
535
in
536
let table_a = Name.Table.create () in
537
let table_b = Name.Table.create () in
538
let or_lookup table name = function
539
| (Some data) as str -> Name.Table.set table ~key:name ~data ; str
540
| None -> Name.Table.find table name
541
in
542
let rec aux a b =
543
match a, b with
544
| Named (name, struct_a), Named (name', struct_b) -> begin
545
match status name name' with
546
| `unknown -> begin
547
let struct_a = or_lookup table_a name struct_a in
548
let struct_b = or_lookup table_b name struct_b in
549
match struct_a, struct_b with
550
| Some struct_a, Some struct_b ->
551
start_pair name name';
552
let res = aux struct_a struct_b in
553
finish_pair name name' res;
554
res
555
| Some _, None
556
| None, Some _
557
| None, None
558
-> false
559
end
560
| `started -> true
561
| `finished res -> res
562
end
563
564
| Named (name, struct_a), struct_b -> begin
565
let struct_a = or_lookup table_a name struct_a in
566
match struct_a with
567
| None -> false
568
| Some struct_a ->
569
aux struct_a struct_b
570
end
571
572
| struct_a, Named (name, struct_b) -> begin
573
let struct_b = or_lookup table_b name struct_b in
574
match struct_b with
575
| None -> false
576
| Some struct_b ->
577
aux struct_a struct_b
578
end
579
580
| Int, Int
581
| Int32, Int32
582
| Int64, Int64
583
| Nativeint, Nativeint
584
| Char, Char
585
| Float, Float
586
| String, String
587
| Bool, Bool
588
| Unit, Unit
589
-> true
590
591
| Option t, Option t'
592
| List t, List t'
593
| Array t, Array t'
594
| Lazy t, Lazy t'
595
| Ref t, Ref t'
596
-> aux t t'
597
598
| Tuple tys, Tuple tys' ->
599
equivalent_array aux tys tys'
600
601
| Record (infos, fields), Record (infos', fields') ->
602
Record_infos.equal infos infos' &&
603
let eq (field, t) (field', t') =
604
String.equal field.Field.label field'.Field.label
605
&& Int.equal field.Field.index field'.Field.index
606
&& aux t t'
607
in
608
equivalent_array eq fields fields'
609
610
| Variant (infos, cases), Variant (infos', cases') ->
611
Variant_infos.equal infos infos' &&
612
let is_polymorphic = Variant.Kind.is_polymorphic infos.Variant_infos.kind in
613
let cases = if is_polymorphic then sort_variant_cases cases else cases in
614
let cases' = if is_polymorphic then sort_variant_cases cases' else cases' in
615
let eq (variant, args) (variant', args') =
616
Int.equal variant.Variant.ocaml_repr variant'.Variant.ocaml_repr
617
&& String.equal variant.Variant.label variant'.Variant.label
618
&& equivalent_array aux args args'
619
in
620
equivalent_array eq cases cases'
621
622
| Int, _
623
| Int32, _
624
| Int64, _
625
| Nativeint, _
626
| Char, _
627
| Float, _
628
| String, _
629
| Bool, _
630
| Unit, _
631
| Option _, _
632
| List _, _
633
| Array _, _
634
| Lazy _, _
635
| Ref _, _
636
| Record _, _
637
| Variant _, _
638
| Tuple _, _
639
-> false
640
in
641
aux a b
642
643
let combine_array ~fail combine a b =
644
let len = Farray.length a in
645
if Farray.length b <> len then fail () else
646
Farray.init len ~f:(fun index ->
647
combine
648
(Farray.get a index)
649
(Farray.get b index)
650
)
651
652
module Incompatible_types = struct
653
(* these exception are used to create human readable error messages for
654
least_upper_bound. we use exception with sexp rather than an error monad because
655
this library does not depend on core, and dealing with exception is the easiest way
656
to plunge this library in a world using a error monad, as soon as there exists a
657
[try_with] function *)
658
exception Invalid_recursive_structure of t * t with sexp
659
exception Field_conflict of t * t * (Field.t * Field.t) with sexp
660
exception Types_conflict of t * t with sexp
661
end
662
663
let least_upper_bound_exn a b =
664
let open Incompatible_types in
665
let wip = Pairs.Table.create () in
666
let fresh_name = Name.make_fresh () in
667
let merge_named_pair name name' =
668
let merged_name = fresh_name () in
669
Pairs.Table.set wip ~key:(name, name') ~data:(`name merged_name);
670
merged_name
671
in
672
let status name name' =
673
match Pairs.Table.find wip (name, name') with
674
| Some ((`name _) as status) -> status
675
| None -> `unknown
676
in
677
let table_a = Name.Table.create () in
678
let table_b = Name.Table.create () in
679
let or_lookup table name = function
680
| (Some data) as str -> Name.Table.set table ~key:name ~data ; str
681
| None -> Name.Table.find table name
682
in
683
let rec aux a b =
684
let fail () = raise (Types_conflict (a, b)) in
685
match a, b with
686
| Named (name, struct_a), Named (name', struct_b) -> begin
687
match status name name' with
688
| `unknown -> begin
689
let struct_a = or_lookup table_a name struct_a in
690
let struct_b = or_lookup table_b name struct_b in
691
match struct_a, struct_b with
692
| Some struct_a, Some struct_b -> begin
693
let name = merge_named_pair name name' in
694
let content = aux struct_a struct_b in
695
Named (name, Some content)
696
end
697
| Some _, None
698
| None, Some _
699
| None, None
700
-> raise (Invalid_recursive_structure (a, b))
701
end
702
| `name name -> Named (name, None)
703
end
704
705
| Named (name, struct_a), struct_b -> begin
706
let struct_a = or_lookup table_a name struct_a in
707
match struct_a with
708
| None -> raise (Invalid_recursive_structure (a, b))
709
| Some struct_a ->
710
aux struct_a struct_b
711
end
712
713
| struct_a, Named (name, struct_b) -> begin
714
let struct_b = or_lookup table_b name struct_b in
715
match struct_b with
716
| None -> raise (Invalid_recursive_structure (a, b))
717
| Some struct_b ->
718
aux struct_a struct_b
719
end
720
721
| Int, Int
722
| Int32, Int32
723
| Int64, Int64
724
| Nativeint, Nativeint
725
| Char, Char
726
| Float, Float
727
| String, String
728
| Bool, Bool
729
| Unit, Unit
730
-> a
731
732
| Option t, Option t' -> Option (aux t t')
733
| List t, List t' -> List (aux t t')
734
| Array t, Array t' -> Array (aux t t')
735
| Lazy t, Lazy t' -> Lazy (aux t t')
736
| Ref t, Ref t' -> Ref (aux t t')
737
738
| Tuple tys, Tuple tys' ->
739
let args = combine_array ~fail aux tys tys' in
740
Tuple args
741
742
| Record (infos, fields), Record (infos', fields') ->
743
if Record_infos.equal infos infos'
744
then
745
let combine (field, t) (field', t') =
746
if
747
String.equal field.Field.label field'.Field.label
748
&& Int.equal field.Field.index field'.Field.index
749
then (field, (aux t t'))
750
else raise (Field_conflict (a, b, (field, field')))
751
in
752
let fields = combine_array ~fail combine fields fields' in
753
Record (infos, fields)
754
else fail ()
755
756
| Variant (infos_a, cases_a), Variant (infos_b, cases_b) ->
757
if Variant_infos.equal infos_a infos_b
758
then
759
match infos_a.Variant_infos.kind with
760
| Variant.Kind.Polymorphic -> begin
761
(* polymorphic variant may be merged if there is no conflict in hashing and
762
arguments are compatible *)
763
let repr_table = Int.Table.create () in
764
let iter_variants variants =
765
let len = Farray.length variants in
766
let rec iter index =
767
if index >= len then true
768
else begin
769
let (({Variant.label=name; ocaml_repr; index=_}, args) as init) =
770
(Farray.get variants index)
771
in
772
match Int.Table.find repr_table ocaml_repr with
773
| None ->
774
Int.Table.set repr_table ~key:ocaml_repr ~data:init;
775
iter (succ index)
776
| Some (({Variant.label=name'; ocaml_repr=_ ; index=_ } as variant)
777
, args') ->
778
if name <> name' then false else begin
779
let args = combine_array ~fail aux args args' in
780
let data = variant, args in
781
Int.Table.set repr_table ~key:ocaml_repr ~data;
782
iter (succ index)
783
end
784
end
785
in iter 0
786
in
787
if iter_variants cases_a && iter_variants cases_b then begin
788
let cases_merged =
789
Int.Table.to_init Farray.init repr_table ~f:(fun _ case -> case)
790
in
791
Variant (infos_a, cases_merged)
792
end else fail ()
793
end
794
| Variant.Kind.Usual -> begin
795
(* usual variant may be merged only if one is a prefix of the other and
796
arguments are compatible *)
797
let len_a = Farray.length cases_a in
798
let len_b = Farray.length cases_b in
799
let cases_merged = Farray.init (max len_a len_b) ~f:(fun index ->
800
let var_a =
801
if index < len_a then Some (Farray.get cases_a index) else None
802
in
803
let var_b =
804
if index < len_b then Some (Farray.get cases_b index) else None
805
in
806
match var_a, var_b with
807
| Some (variant_a, args_a), Some (variant_b, args_b) ->
808
if
809
Int.equal variant_a.Variant.ocaml_repr variant_b.Variant.ocaml_repr
810
&& String.equal variant_a.Variant.label variant_b.Variant.label
811
then
812
let args = combine_array ~fail aux args_a args_b in
813
variant_a, args
814
else
815
fail ()
816
| Some (variant, args), None ->
817
variant, args
818
| None, Some (variant, args) ->
819
variant, args
820
| None, None -> assert false
821
) in
822
Variant (infos_a, cases_merged)
823
end
824
else fail ()
825
826
| Int, _
827
| Int32, _
828
| Int64, _
829
| Nativeint, _
830
| Char, _
831
| Float, _
832
| String, _
833
| Bool, _
834
| Unit, _
835
| Option _, _
836
| List _, _
837
| Array _, _
838
| Lazy _, _
839
| Ref _, _
840
| Record _, _
841
| Variant _, _
842
| Tuple _, _
843
-> fail ()
844
in
845
aux a b
846
847
module type Typestructable = sig
848
type t
849
val typestruct_of_t : type_struct
850
end
851
852
module Internal_generic = Type_generic.Make(struct
853
type 'a t = type_struct
854
module Type_struct_variant = Variant
855
module Type_struct_field = Field
856
include Type_generic.Variant_and_record_intf.M(struct type nonrec 'a t = 'a t end)
857
858
let name = "typestruct"
859
let required = []
860
861
let int = Int
862
let int32 = Int32
863
let int64 = Int64
864
let nativeint = Nativeint
865
let char = Char
866
let float = Float
867
let string = String
868
let bool = Bool
869
let unit = Unit
870
let option str = Option str
871
let list str = List str
872
let array str = Array str
873
let lazy_t str = Lazy str
874
let ref_ str = Ref str
875
let tuple2 a b = Tuple (Farray.make2 a b)
876
let tuple3 a b c = Tuple (Farray.make3 a b c)
877
let tuple4 a b c d = Tuple (Farray.make4 a b c d)
878
let tuple5 a b c d e = Tuple (Farray.make5 a b c d e)
879
880
let function_ _ = assert false
881
882
let record record =
883
let infos =
884
let has_double_array_tag = Record.has_double_array_tag record in
885
{ Record_infos.
886
has_double_array_tag;
887
}
888
in
889
let fields = Farray.init (Record.length record) ~f:(fun index ->
890
match Record.field record index with
891
| Record.Field field ->
892
let label = Field.label field in
893
let type_struct = (Field.traverse field : type_struct) in
894
{ Type_struct_field.label ; index }, type_struct
895
)
896
in
897
Record (infos, fields)
898
899
let variant variant =
900
let infos =
901
let polymorphic = Variant.is_polymorphic variant in
902
let kind =
903
Type_struct_variant.Kind.(if polymorphic then Polymorphic else Usual)
904
in
905
{ Variant_infos.
906
kind;
907
}
908
in
909
let tags = Farray.init (Variant.length variant) ~f:(fun index ->
910
match Variant.tag variant index with
911
| Variant.Tag tag ->
912
let label = Tag.label tag in
913
let index = Tag.index tag in
914
let ocaml_repr = Tag.ocaml_repr tag in
915
let arity = Tag.arity tag in
916
let variant = {
917
Type_struct_variant.
918
label;
919
ocaml_repr;
920
index;
921
} in
922
let str = Tag.traverse tag in
923
let args = variant_args_of_type_struct ~arity str in
924
variant, args
925
)
926
in
927
Variant (infos, tags)
928
929
module Named = struct
930
module Context = struct
931
type t = {
932
fresh_name : unit -> Name.t;
933
}
934
let create () = {
935
fresh_name = Name.make_fresh ();
936
}
937
end
938
939
type 'a t = Name.t
940
941
let init context _name =
942
context.Context.fresh_name ()
943
944
let get_wip_computation shared_name = Named (shared_name, None)
945
946
let set_final_computation shared_name str = Named (shared_name, Some str)
947
948
let share : type a. a Typerep.t -> bool = function
949
| Typerep.Int -> false
950
| Typerep.Int32 -> false
951
| Typerep.Int64 -> false
952
| Typerep.Nativeint -> false
953
| Typerep.Char -> false
954
| Typerep.Float -> false
955
| Typerep.String -> false
956
| Typerep.Bool -> false
957
| Typerep.Unit -> false
958
| Typerep.Option _ -> false
959
| Typerep.List _ -> false
960
| Typerep.Array _ -> false
961
| Typerep.Lazy _ -> false
962
| Typerep.Ref _ -> false
963
964
| Typerep.Function _ -> true
965
| Typerep.Tuple _ -> true
966
| Typerep.Record _ -> true
967
| Typerep.Variant _ -> true
968
969
| Typerep.Named _ -> false
970
end
971
end)
972
973
module Generic = struct
974
include Internal_generic
975
let of_typerep_fct rep =
976
let `generic str = Internal_generic.of_typerep rep in
977
remove_dead_links str
978
let of_typerep rep = `generic (of_typerep_fct rep)
979
end
980
let of_typerep = Generic.of_typerep_fct
981
982
let sexp_of_typerep rep = sexp_of_t (of_typerep rep)
983
984
module Diff = struct
985
986
module Path = struct
987
(* the path leading to the variant. succession of field names, variant names,
988
or string representation of base types. for tuple with use 'f0', 'f1', etc. *)
989
type t = string list with sexp
990
end
991
992
module Compatibility = struct
993
type t = [
994
| `Backward_compatible
995
| `Break
996
] with sexp
997
end
998
999
module Atom = struct
1000
(* [str * str] means [old * new] *)
1001
type t =
1002
| Update of type_struct * type_struct
1003
| Add_field of (Field.t * type_struct)
1004
| Remove_field of (Field.t * type_struct)
1005
| Update_field of (Field.t * type_struct) * (Field.t * type_struct)
1006
| Add_variant of (Compatibility.t * Variant.t * type_struct Farray.t)
1007
| Remove_variant of (Variant.t * type_struct Farray.t)
1008
| Update_variant of
1009
(Variant.t * type_struct Farray.t)
1010
* (Variant.t * type_struct Farray.t)
1011
with sexp
1012
end
1013
1014
type t = (Path.t * Atom.t) list with sexp
1015
1016
let is_empty = List.is_empty
1017
1018
(*
1019
The diff is done such as the length of the path associated with atoms is maximal
1020
*)
1021
let compute a b =
1022
let wip = Pairs.Table.create () in
1023
let start_pair name name' =
1024
Pairs.Table.set wip ~key:(name, name') ~data:`started
1025
in
1026
let status name name' =
1027
match Pairs.Table.find wip (name, name') with
1028
| Some (`started as status) -> status
1029
| None -> `unknown
1030
in
1031
let table_a = Name.Table.create () in
1032
let table_b = Name.Table.create () in
1033
let or_lookup table name = function
1034
| (Some data) as str -> Name.Table.set table ~key:name ~data ; str
1035
| None -> Name.Table.find table name
1036
in
1037
let diffs = Queue.create () in
1038
let enqueue path diff = Queue.push (path, diff) diffs in
1039
let rec aux_list :
1040
'a. add:('a -> unit)
1041
-> remove:('a -> unit)
1042
-> compute:(('a * 'a list) -> ('a * 'a list) -> 'a list * 'a list)
1043
-> 'a list -> 'a list -> unit
1044
= fun ~add ~remove ~compute a b ->
1045
match a, b with
1046
| [], [] -> ()
1047
| [], _::_ -> List.iter ~f:add b
1048
| _::_, [] -> List.iter ~f:remove a
1049
| hd::tl, hd'::tl' ->
1050
let tl, tl' = compute (hd, tl) (hd', tl') in
1051
aux_list ~add ~remove ~compute tl tl'
1052
in
1053
let aux_farray :
1054
'a. add:('a -> unit)
1055
-> remove:('a -> unit)
1056
-> compute:(('a * 'a list) -> ('a * 'a list) -> 'a list * 'a list)
1057
-> 'a Farray.t -> 'a Farray.t -> unit
1058
= fun ~add ~remove ~compute a b ->
1059
aux_list ~add ~remove ~compute (Farray.to_list a) (Farray.to_list b)
1060
in
1061
let rec aux path a b =
1062
match a, b with
1063
| Named (name_a, struct_a), Named (name_b, struct_b) -> begin
1064
match status name_a name_b with
1065
| `unknown -> begin
1066
let struct_a = or_lookup table_a name_a struct_a in
1067
let struct_b = or_lookup table_b name_b struct_b in
1068
match struct_a, struct_b with
1069
| Some struct_a, Some struct_b ->
1070
start_pair name_a name_b;
1071
aux path struct_a struct_b
1072
| Some _, None
1073
| None, Some _
1074
| None, None -> enqueue path (Atom.Update (a, b))
1075
end
1076
| `started -> ()
1077
end
1078
1079
| Named (name, struct_a), struct_b -> begin
1080
let struct_a = or_lookup table_a name struct_a in
1081
match struct_a with
1082
| None -> enqueue path (Atom.Update (a, b))
1083
| Some struct_a ->
1084
aux path struct_a struct_b
1085
end
1086
1087
| struct_a, Named (name, struct_b) -> begin
1088
let struct_b = or_lookup table_b name struct_b in
1089
match struct_b with
1090
| None -> enqueue path (Atom.Update (a, b))
1091
| Some struct_b ->
1092
aux path struct_a struct_b
1093
end
1094
1095
| Int, Int
1096
| Int32, Int32
1097
| Int64, Int64
1098
| Nativeint, Nativeint
1099
| Char, Char
1100
| Float, Float
1101
| String, String
1102
| Bool, Bool
1103
| Unit, Unit
1104
-> ()
1105
1106
| Option a, Option b -> aux ("option"::path) a b
1107
| List a, List b -> aux ("list"::path) a b
1108
| Array a, Array b -> aux ("array"::path) a b
1109
| Lazy a, Lazy b -> aux ("lazy"::path) a b
1110
| Ref a, Ref b -> aux ("ref"::path) a b
1111
1112
| Tuple tys, Tuple tys' ->
1113
let arity = Farray.length tys in
1114
let arity' = Farray.length tys' in
1115
if arity <> arity'
1116
then enqueue path (Atom.Update (a, b))
1117
else
1118
(* since arity = arity', add and remove are never called *)
1119
let add _ = assert false in
1120
let remove _ = assert false in
1121
let index = ref 0 in
1122
let compute (ty, tl) (ty', tl') =
1123
let path = ("f"^(string_of_int !index)) :: path in
1124
aux path ty ty';
1125
incr index;
1126
tl, tl'
1127
in
1128
aux_farray ~add ~remove ~compute tys tys'
1129
1130
| Record (infos, fields), Record (infos', fields') ->
1131
if not (Record_infos.equal infos infos')
1132
then enqueue path (Atom.Update (a, b)) else begin
1133
let add hd = enqueue path (Atom.Add_field hd) in
1134
let remove hd = enqueue path (Atom.Remove_field hd) in
1135
let update a b = enqueue path (Atom.Update_field (a, b)) in
1136
let labels fields =
1137
let set = String.Hash_set.create () in
1138
let iter (field, _) = String.Hash_set.add set field.Field.label in
1139
Farray.iter ~f:iter fields;
1140
set
1141
in
1142
let labels_a = labels fields in
1143
let labels_b = labels fields' in
1144
let compute ((field, str) as hd, tl) ((field', str') as hd', tl') =
1145
let field = field.Field.label in
1146
let field' = field'.Field.label in
1147
if String.equal field field'
1148
then begin
1149
aux (field::path) str str';
1150
tl, tl'
1151
end else begin
1152
match
1153
String.Hash_set.mem labels_b field,
1154
String.Hash_set.mem labels_a field' with
1155
| false, false
1156
| true, true -> update hd hd'; tl, tl'
1157
| true, false -> add hd'; (hd::tl), tl'
1158
| false, true -> remove hd; tl, (hd'::tl')
1159
end
1160
in
1161
aux_farray ~add ~remove ~compute fields fields'
1162
end
1163
1164
| Variant ({Variant_infos.kind} as infos, cases), Variant (infos', cases') ->
1165
if not (Variant_infos.equal infos infos')
1166
then enqueue path (Atom.Update (a, b)) else begin
1167
let is_polymorphic = Variant.Kind.is_polymorphic kind in
1168
let cases = if is_polymorphic then sort_variant_cases cases else cases in
1169
let cases' = if is_polymorphic then sort_variant_cases cases' else cases' in
1170
let add compatible (a,b) = enqueue path (Atom.Add_variant (compatible, a, b)) in
1171
let remove hd = enqueue path (Atom.Remove_variant hd) in
1172
let update a b = enqueue path (Atom.Update_variant (a, b)) in
1173
let labels cases =
1174
let set = String.Hash_set.create () in
1175
let iter (variant, _) = String.Hash_set.add set variant.Variant.label in
1176
Farray.iter ~f:iter cases;
1177
set
1178
in
1179
let labels_a = labels cases in
1180
let labels_b = labels cases' in
1181
let compute ((variant, args) as hd, tl) ((variant', args') as hd', tl') =
1182
let label = variant.Variant.label in
1183
let label' = variant'.Variant.label in
1184
let arity = Farray.length args in
1185
let arity' = Farray.length args' in
1186
match String.equal label label', arity = arity' with
1187
| true, true -> begin
1188
Farray.iter2_exn args args'
1189
~f:(let path = label::path in fun str str' -> aux path str str');
1190
tl, tl'
1191
end
1192
| true, false -> begin
1193
update hd hd';
1194
tl, tl'
1195
end
1196
| false, (true | false) -> begin
1197
match
1198
String.Hash_set.mem labels_b label,
1199
String.Hash_set.mem labels_a label' with
1200
| false, false
1201
| true, true -> update hd hd'; tl, tl'
1202
| true, false ->
1203
let compatible =
1204
if is_polymorphic || List.is_empty tl'
1205
then `Backward_compatible
1206
else `Break
1207
in
1208
add compatible hd'; (hd::tl), tl'
1209
| false, true -> remove hd; tl, (hd'::tl')
1210
end
1211
in
1212
aux_farray ~add:(add `Backward_compatible) ~remove ~compute cases cases'
1213
end
1214
1215
| Int, _
1216
| Int32, _
1217
| Int64, _
1218
| Nativeint, _
1219
| Char, _
1220
| Float, _
1221
| String, _
1222
| Bool, _
1223
| Unit, _
1224
| Option _, _
1225
| List _, _
1226
| Array _, _
1227
| Lazy _, _
1228
| Ref _, _
1229
| Tuple _, _
1230
| Record _, _
1231
| Variant _, _
1232
-> enqueue path (Atom.Update (a, b))
1233
in
1234
aux [] a b;
1235
let diffs = Queue.fold (fun acc x -> x::acc) [] diffs in
1236
let f (path, diff) = List.rev path, diff in
1237
List.rev_map ~f diffs
1238
1239
let is_bin_prot_subtype ~subtype:a ~supertype:b =
1240
let diffs = compute a b in
1241
let for_all = function
1242
| _, Atom.Add_variant (compatible, _, _) -> compatible = `Backward_compatible
1243
| _ -> false
1244
in
1245
List.for_all ~f:for_all diffs
1246
1247
let incompatible_changes t =
1248
let filter (_, atom) =
1249
let open Atom in
1250
match atom with
1251
| Add_variant (compatible, _, _) -> compatible = `Break
1252
| Update _
1253
| Add_field _
1254
| Remove_field _
1255
| Update_field _
1256
| Remove_variant _
1257
| Update_variant _
1258
-> true
1259
in
1260
List.rev_filter ~f:filter t
1261
end
1262
1263
module To_typerep = struct
1264
exception Unbound_name of t * Name.t with sexp
1265
exception Unsupported_tuple of t with sexp
1266
1267
let to_typerep : t -> Typerep.packed = fun type_struct ->
1268
let table = Name.Table.create () in
1269
let rec aux = function
1270
| Int -> Typerep.T typerep_of_int
1271
| Int32 -> Typerep.T typerep_of_int32
1272
| Int64 -> Typerep.T typerep_of_int64
1273
| Nativeint -> Typerep.T typerep_of_nativeint
1274
| Char -> Typerep.T typerep_of_char
1275
| Float -> Typerep.T typerep_of_float
1276
| String -> Typerep.T typerep_of_string
1277
| Bool -> Typerep.T typerep_of_bool
1278
| Unit -> Typerep.T typerep_of_unit
1279
| Option t ->
1280
let Typerep.T rep = aux t in
1281
Typerep.T (typerep_of_option rep)
1282
| List t ->
1283
let Typerep.T rep = aux t in
1284
Typerep.T (typerep_of_list rep)
1285
| Array t ->
1286
let Typerep.T rep = aux t in
1287
Typerep.T (typerep_of_array rep)
1288
| Lazy t ->
1289
let Typerep.T rep = aux t in
1290
Typerep.T (typerep_of_lazy_t rep)
1291
| Ref t ->
1292
let Typerep.T rep = aux t in
1293
Typerep.T (typerep_of_ref rep)
1294
| (Tuple args) as type_struct -> begin
1295
match Farray.to_array ~f:(fun _ x -> x) args with
1296
| [| a ; b |] ->
1297
let Typerep.T a = aux a in
1298
let Typerep.T b = aux b in
1299
Typerep.T (typerep_of_tuple2 a b)
1300
| [| a ; b ; c |] ->
1301
let Typerep.T a = aux a in
1302
let Typerep.T b = aux b in
1303
let Typerep.T c = aux c in
1304
Typerep.T (typerep_of_tuple3 a b c)
1305
| [| a ; b ; c ; d |] ->
1306
let Typerep.T a = aux a in
1307
let Typerep.T b = aux b in
1308
let Typerep.T c = aux c in
1309
let Typerep.T d = aux d in
1310
Typerep.T (typerep_of_tuple4 a b c d)
1311
| [| a ; b ; c ; d ; e |] ->
1312
let Typerep.T a = aux a in
1313
let Typerep.T b = aux b in
1314
let Typerep.T c = aux c in
1315
let Typerep.T d = aux d in
1316
let Typerep.T e = aux e in
1317
Typerep.T (typerep_of_tuple5 a b c d e)
1318
| _ -> raise (Unsupported_tuple type_struct)
1319
end
1320
| Record (infos, fields) ->
1321
let len = Farray.length fields in
1322
let typed_fields = Farray.to_array fields ~f:(fun index (field, str) ->
1323
if index <> field.Field.index then assert false;
1324
let label = field.Field.label in
1325
let Typerep.T typerep_of_field = aux str in
1326
let get obj =
1327
let cond = Obj.is_block obj && Obj.size obj = len in
1328
if not cond then assert false;
1329
(* [Obj.field] works on float array *)
1330
Obj.obj (Obj.field obj index)
1331
in
1332
let field = {
1333
Typerep.Field_internal.
1334
label;
1335
rep = typerep_of_field;
1336
index;
1337
tyid = Typename.create ();
1338
get;
1339
} in
1340
Typerep.Record_internal.Field (Typerep.Field.internal_use_only field)
1341
)
1342
in
1343
let module Typename_of_t = Make_typename.Make0(struct
1344
type t = Obj.t
1345
let name = "dynamic record"
1346
end)
1347
in
1348
let typename = Typerep.Named.typename_of_t Typename_of_t.named in
1349
let has_double_array_tag = infos.Record_infos.has_double_array_tag in
1350
let create { Typerep.Record_internal.get } =
1351
let t =
1352
let tag =
1353
if has_double_array_tag
1354
then Obj.double_array_tag
1355
else 0
1356
in
1357
Obj.new_block tag len
1358
in
1359
let iter = function
1360
| Typerep.Record_internal.Field field ->
1361
let index = Typerep.Field.index field in
1362
let value = get field in
1363
Obj.set_field t index (Obj.repr value)
1364
in
1365
Array.iter ~f:iter typed_fields;
1366
t
1367
in
1368
let record = Typerep.Record.internal_use_only {
1369
Typerep.Record_internal.
1370
typename;
1371
fields = typed_fields;
1372
has_double_array_tag;
1373
create;
1374
} in
1375
let typerep_of_t =
1376
Typerep.Named ((Typename_of_t.named,
1377
(Some (lazy (Typerep.Record record)))))
1378
in
1379
Typerep.T typerep_of_t
1380
| Variant ({Variant_infos.kind}, tags_str) ->
1381
let polymorphic = Variant.Kind.is_polymorphic kind in
1382
let typed_tags = Farray.to_array tags_str ~f:(fun index (variant, args) ->
1383
let type_struct = type_struct_of_variant_args args in
1384
let Typerep.T typerep_of_tag = aux type_struct in
1385
let index = (if index <> variant.Variant.index then assert false); index in
1386
let ocaml_repr = variant.Variant.ocaml_repr in
1387
let arity = Farray.length args in
1388
let label = variant.Variant.label in
1389
let create_polymorphic =
1390
if arity = 0
1391
then Typerep.Tag_internal.Const (Obj.repr ocaml_repr)
1392
else Typerep.Tag_internal.Args (fun value ->
1393
let block = Obj.new_block 0 2 in
1394
Obj.set_field block 0 (Obj.repr ocaml_repr);
1395
Obj.set_field block 1 (Obj.repr value);
1396
block
1397
)
1398
in
1399
let create_usual =
1400
match arity with
1401
| 0 -> Typerep.Tag_internal.Const (Obj.repr ocaml_repr)
1402
| 1 -> Typerep.Tag_internal.Args (fun value ->
1403
let block = Obj.new_block ocaml_repr 1 in
1404
Obj.set_field block 0 (Obj.repr value);
1405
block)
1406
| n -> Typerep.Tag_internal.Args (fun value ->
1407
let args = Obj.repr value in
1408
if not (Obj.size args = n) then assert false;
1409
let block = Obj.dup args in
1410
Obj.set_tag block ocaml_repr;
1411
block)
1412
in
1413
let create = if polymorphic then create_polymorphic else create_usual in
1414
let tyid =
1415
(fun (type exist) (typerep_of_tag:exist Typerep.t) ->
1416
if arity = 0
1417
then
1418
let Type_equal.T =
1419
Typerep.same_witness_exn typerep_of_tuple0 typerep_of_tag
1420
in
1421
(typename_of_tuple0 : exist Typename.t)
1422
else
1423
(Typename.create () : exist Typename.t)
1424
) typerep_of_tag
1425
in
1426
let tag = {
1427
Typerep.Tag_internal.
1428
label;
1429
rep = typerep_of_tag;
1430
arity;
1431
index;
1432
ocaml_repr;
1433
tyid;
1434
create;
1435
} in
1436
Typerep.Variant_internal.Tag (Typerep.Tag.internal_use_only tag)
1437
) in
1438
let module Typename_of_t = Make_typename.Make0(struct
1439
type t = Obj.t
1440
let name = "dynamic variant"
1441
end) in
1442
let typename = Typerep.Named.typename_of_t Typename_of_t.named in
1443
let value_polymorphic =
1444
let map =
1445
let map exists =
1446
match exists with
1447
| Typerep.Variant_internal.Tag tag ->
1448
let ocaml_repr = Typerep.Tag.ocaml_repr tag in
1449
ocaml_repr, exists
1450
in
1451
Flat_map.Flat_int_map.of_array_map ~f:map typed_tags
1452
in
1453
(fun obj ->
1454
let repr = Typerep_obj.repr_of_poly_variant (Obj.obj obj) in
1455
let no_arg = Obj.is_int obj in
1456
match Flat_map.Flat_int_map.find map repr with
1457
| None -> assert false
1458
| Some (Typerep.Variant_internal.Tag tag) ->
1459
let arity = Typerep.Tag.arity tag in
1460
let value =
1461
match no_arg with
1462
| true ->
1463
if arity = 0
1464
then Obj.repr value_tuple0
1465
else assert false
1466
| false ->
1467
let size = Obj.size obj in
1468
if size <> 2 then assert false;
1469
let value = Obj.field obj 1 in
1470
if arity = 1
1471
then value
1472
else begin
1473
if Obj.is_int value then assert false;
1474
if Obj.size value <> arity then assert false;
1475
value
1476
end
1477
in
1478
Typerep.Variant_internal.Value (tag, Obj.obj value)
1479
)
1480
in
1481
let value_usual =
1482
let bound = Array.length typed_tags in
1483
let collect pred_args =
1484
let rec aux acc index =
1485
if index >= bound then Farray.of_list (List.rev acc)
1486
else
1487
match typed_tags.(index) with
1488
| (Typerep.Variant_internal.Tag tag) as exists ->
1489
let arity = Typerep.Tag.arity tag in
1490
let acc =
1491
if pred_args arity then exists::acc else acc
1492
in
1493
aux acc (succ index)
1494
in
1495
aux [] 0
1496
in
1497
let without_args = collect (fun i -> i = 0) in
1498
let with_args = collect (fun i -> i > 0) in
1499
let find_tag ~no_arg idx =
1500
let table = if no_arg then without_args else with_args in
1501
if idx < 0 || idx >= Farray.length table then assert false;
1502
Farray.get table idx
1503
in
1504
(fun obj ->
1505
match Obj.is_int obj with
1506
| true -> begin
1507
match find_tag ~no_arg:true (Obj.obj obj) with
1508
| Typerep.Variant_internal.Tag tag ->
1509
let Type_equal.T =
1510
Typename.same_witness_exn
1511
(Typerep.Tag.tyid tag)
1512
typename_of_tuple0
1513
in
1514
let arity = Typerep.Tag.arity tag in
1515
if arity <> 0 then assert false;
1516
Typerep.Variant_internal.Value (tag, value_tuple0)
1517
end
1518
| false ->
1519
let idx = Obj.tag obj in
1520
match find_tag ~no_arg:false idx with
1521
| Typerep.Variant_internal.Tag tag ->
1522
let arity = Typerep.Tag.arity tag in
1523
if arity <> Obj.size obj then assert false;
1524
let value =
1525
if arity = 1
1526
then Obj.field obj 0
1527
else
1528
let block = Obj.dup obj in
1529
Obj.set_tag block 0; (* tuple *)
1530
block
1531
in
1532
Typerep.Variant_internal.Value (tag, Obj.obj value)
1533
)
1534
in
1535
let value = if polymorphic then value_polymorphic else value_usual in
1536
let variant = Typerep.Variant.internal_use_only {
1537
Typerep.Variant_internal.
1538
typename;
1539
tags = typed_tags;
1540
polymorphic;
1541
value;
1542
} in
1543
let typerep_of_t =
1544
Typerep.Named ((Typename_of_t.named,
1545
(Some (lazy (Typerep.Variant variant)))))
1546
in
1547
Typerep.T typerep_of_t
1548
| Named (name, content) ->
1549
match Name.Table.find table name with
1550
| Some content -> content
1551
| None ->
1552
let module T = struct
1553
(*
1554
let [t] be the type represented by this named type_struct
1555
this type will be equal to the existential type returned by the call to
1556
aux performed on the content.
1557
*)
1558
type t
1559
let name = string_of_int name
1560
end in
1561
let module Named = Make_typename.Make0(T) in
1562
let content =
1563
match content with
1564
| Some content -> content
1565
| None ->
1566
raise (Unbound_name (type_struct, name))
1567
in
1568
let release_content_ref = ref (`aux_content content) in
1569
let typerep_of_t = Typerep.Named (Named.named, Some (lazy (
1570
match !release_content_ref with
1571
| `aux_content content ->
1572
let Typerep.T typerep_of_content = aux content in
1573
let rep = (fun (type content) (rep:content Typerep.t) ->
1574
(Obj.magic (rep : content Typerep.t) : T.t Typerep.t)
1575
) typerep_of_content
1576
in
1577
release_content_ref := `typerep rep;
1578
rep
1579
| `typerep rep -> rep
1580
))) in
1581
let data = Typerep.T typerep_of_t in
1582
Name.Table.set table ~key:name ~data;
1583
data
1584
in
1585
aux type_struct
1586
end
1587
let to_typerep = To_typerep.to_typerep
1588
1589
module Versioned = struct
1590
module Version = struct
1591
type t = [
1592
| `v0
1593
| `v1
1594
| `v2
1595
| `v3
1596
| `v4
1597
] with bin_io, sexp, typerep
1598
let v1 = `v1
1599
let v2 = `v2
1600
let v3 = `v3
1601
let v4 = `v4
1602
end
1603
exception Not_downgradable of Sexp.t with sexp
1604
module type V_sig = sig
1605
type t
1606
with sexp, bin_io, typerep
1607
val serialize : type_struct -> t
1608
val unserialize : t -> type_struct
1609
end
1610
module V0 : V_sig = struct
1611
type t =
1612
| Unit
1613
with sexp, bin_io, typerep
1614
1615
let serialize = function
1616
| T.Unit -> Unit
1617
| str -> raise (Not_downgradable (T.sexp_of_t str))
1618
1619
let unserialize = function
1620
| Unit -> T.Unit
1621
end
1622
module V1 : V_sig = struct
1623
type t =
1624
| Int
1625
| Int32
1626
| Int64
1627
| Nativeint
1628
| Char
1629
| Float
1630
| String
1631
| Bool
1632
| Unit
1633
| Option of t
1634
| List of t
1635
| Array of t
1636
| Lazy of t
1637
| Ref of t
1638
| Record of (Field.V1.t * t) Farray.t
1639
| Tuple of t Farray.t
1640
| Variant of Variant.Kind.t * (Variant.V1.t * t Farray.t) Farray.t
1641
with sexp, bin_io, typerep
1642
1643
let rec serialize = function
1644
| T.Int -> Int
1645
| T.Int32 -> Int32
1646
| T.Int64 -> Int64
1647
| T.Nativeint -> Nativeint
1648
| T.Char -> Char
1649
| T.Float -> Float
1650
| T.String -> String
1651
| T.Bool -> Bool
1652
| T.Unit -> Unit
1653
| T.Option t -> Option (serialize t)
1654
| T.List t -> List (serialize t)
1655
| T.Array t -> Array (serialize t)
1656
| T.Lazy t -> Lazy (serialize t)
1657
| T.Ref t -> Ref (serialize t)
1658
| T.Record (infos, fields) as str ->
1659
if infos.Record_infos.has_double_array_tag
1660
then raise (Not_downgradable (T.sexp_of_t str));
1661
let map (field, t) =
1662
let field = Field.to_v1 field in
1663
field, serialize t in
1664
let fields = Farray.map ~f:map fields in
1665
Record fields
1666
| T.Tuple args -> Tuple (Farray.map ~f:serialize args)
1667
| T.Variant (info, tags) ->
1668
let kind = info.Variant_infos.kind in
1669
let map (variant, t) =
1670
let variant_v1 = Variant.to_v1 kind variant in
1671
variant_v1, Farray.map ~f:serialize t
1672
in
1673
Variant (kind, Farray.map ~f:map tags)
1674
| (T.Named _) as str -> raise (Not_downgradable (T.sexp_of_t str))
1675
1676
let rec unserialize = function
1677
| Int -> T.Int
1678
| Int32 -> T.Int32
1679
| Int64 -> T.Int64
1680
| Nativeint -> T.Nativeint
1681
| Char -> T.Char
1682
| Float -> T.Float
1683
| String -> T.String
1684
| Bool -> T.Bool
1685
| Unit -> T.Unit
1686
| Option t -> T.Option (unserialize t)
1687
| List t -> T.List (unserialize t)
1688
| Array t -> T.Array (unserialize t)
1689
| Lazy t -> T.Lazy (unserialize t)
1690
| Ref t -> T.Ref (unserialize t)
1691
| Record fields ->
1692
let infos = { Record_infos.
1693
(* this is wrong is some cases, if so the exec should upgrade to >= v3 *)
1694
has_double_array_tag = false;
1695
} in
1696
let mapi index (field, t) =
1697
let field = Field.of_v1 index field in
1698
field, unserialize t
1699
in
1700
let fields = Farray.mapi ~f:mapi fields in
1701
T.Record (infos, fields)
1702
| Tuple args -> T.Tuple (Farray.map ~f:unserialize args)
1703
| Variant (kind, tags) ->
1704
let infos = { Variant_infos.kind } in
1705
let mapi index (variant_v1, t) =
1706
let variant = Variant.of_v1 kind index t tags variant_v1 in
1707
variant, Farray.map ~f:unserialize t
1708
in
1709
T.Variant (infos, Farray.mapi ~f:mapi tags)
1710
end
1711
(* Adding Named *)
1712
module V2 : V_sig = struct
1713
type t =
1714
| Int
1715
| Int32
1716
| Int64
1717
| Nativeint
1718
| Char
1719
| Float
1720
| String
1721
| Bool
1722
| Unit
1723
| Option of t
1724
| List of t
1725
| Array of t
1726
| Lazy of t
1727
| Ref of t
1728
| Record of (Field.V1.t * t) Farray.t
1729
| Tuple of t Farray.t
1730
| Variant of Variant.Kind.t * (Variant.V1.t * t Farray.t) Farray.t
1731
| Named of Name.t * t option
1732
with sexp, bin_io, typerep
1733
1734
let rec serialize = function
1735
| T.Int -> Int
1736
| T.Int32 -> Int32
1737
| T.Int64 -> Int64
1738
| T.Nativeint -> Nativeint
1739
| T.Char -> Char
1740
| T.Float -> Float
1741
| T.String -> String
1742
| T.Bool -> Bool
1743
| T.Unit -> Unit
1744
| T.Option t -> Option (serialize t)
1745
| T.List t -> List (serialize t)
1746
| T.Array t -> Array (serialize t)
1747
| T.Lazy t -> Lazy (serialize t)
1748
| T.Ref t -> Ref (serialize t)
1749
| T.Record (infos, fields) as str ->
1750
if infos.Record_infos.has_double_array_tag
1751
then raise (Not_downgradable (T.sexp_of_t str));
1752
let map (field, t) =
1753
let field = Field.to_v1 field in
1754
field, serialize t
1755
in
1756
let fields = Farray.map ~f:map fields in
1757
Record fields
1758
| T.Tuple args -> Tuple (Farray.map ~f:serialize args)
1759
| T.Variant (info, tags) ->
1760
let kind = info.Variant_infos.kind in
1761
let map (variant, t) =
1762
let variant_v1 = Variant.to_v1 kind variant in
1763
variant_v1, Farray.map ~f:serialize t
1764
in
1765
Variant (kind, Farray.map ~f:map tags)
1766
| T.Named (name, content) ->
1767
let content = Option.map ~f:serialize content in
1768
Named (name, content)
1769
1770
let rec unserialize = function
1771
| Int -> T.Int
1772
| Int32 -> T.Int32
1773
| Int64 -> T.Int64
1774
| Nativeint -> T.Nativeint
1775
| Char -> T.Char
1776
| Float -> T.Float
1777
| String -> T.String
1778
| Bool -> T.Bool
1779
| Unit -> T.Unit
1780
| Option t -> T.Option (unserialize t)
1781
| List t -> T.List (unserialize t)
1782
| Array t -> T.Array (unserialize t)
1783
| Lazy t -> T.Lazy (unserialize t)
1784
| Ref t -> T.Ref (unserialize t)
1785
| Record fields ->
1786
let infos = { Record_infos.
1787
(* this is wrong is some cases, if so the exec should upgrade to >= v3 *)
1788
has_double_array_tag = false;
1789
} in
1790
let mapi index (field, t) =
1791
let field = Field.of_v1 index field in
1792
field, unserialize t
1793
in
1794
let fields = Farray.mapi ~f:mapi fields in
1795
T.Record (infos, fields)
1796
| Tuple args -> T.Tuple (Farray.map ~f:unserialize args)
1797
| Variant (kind, tags) ->
1798
let infos = { Variant_infos.kind } in
1799
let mapi index (variant_v1, t) =
1800
let variant = Variant.of_v1 kind index t tags variant_v1 in
1801
variant, Farray.map ~f:unserialize t
1802
in
1803
T.Variant (infos, Farray.mapi ~f:mapi tags)
1804
| Named (name, content) ->
1805
let content = Option.map ~f:unserialize content in
1806
T.Named (name, content)
1807
end
1808
(* Adding meta-info to the records and variants *)
1809
module V3 : V_sig = struct
1810
type t =
1811
| Int
1812
| Int32
1813
| Int64
1814
| Nativeint
1815
| Char
1816
| Float
1817
| String
1818
| Bool
1819
| Unit
1820
| Option of t
1821
| List of t
1822
| Array of t
1823
| Lazy of t
1824
| Ref of t
1825
| Record of Record_infos.V1.t * (Field.V1.t * t) Farray.t
1826
| Tuple of t Farray.t
1827
| Variant of Variant_infos.V1.t * (Variant.V1.t * t Farray.t) Farray.t
1828
| Named of Name.t * t option
1829
with sexp, bin_io, typerep
1830
1831
let rec serialize = function
1832
| T.Int -> Int
1833
| T.Int32 -> Int32
1834
| T.Int64 -> Int64
1835
| T.Nativeint -> Nativeint
1836
| T.Char -> Char
1837
| T.Float -> Float
1838
| T.String -> String
1839
| T.Bool -> Bool
1840
| T.Unit -> Unit
1841
| T.Option t -> Option (serialize t)
1842
| T.List t -> List (serialize t)
1843
| T.Array t -> Array (serialize t)
1844
| T.Lazy t -> Lazy (serialize t)
1845
| T.Ref t -> Ref (serialize t)
1846
| T.Record (infos, fields) ->
1847
let map (field, t) =
1848
let field = Field.to_v1 field in
1849
field, serialize t
1850
in
1851
let fields = Farray.map ~f:map fields in
1852
Record (infos, fields)
1853
| T.Tuple args -> Tuple (Farray.map ~f:serialize args)
1854
| T.Variant (infos, tags) ->
1855
let kind = infos.Variant_infos.kind in
1856
let map (variant, t) =
1857
let variant_v1 = Variant.to_v1 kind variant in
1858
variant_v1, Farray.map ~f:serialize t
1859
in
1860
Variant (infos, Farray.map ~f:map tags)
1861
| T.Named (name, content) ->
1862
let content = Option.map ~f:serialize content in
1863
Named (name, content)
1864
1865
let rec unserialize = function
1866
| Int -> T.Int
1867
| Int32 -> T.Int32
1868
| Int64 -> T.Int64
1869
| Nativeint -> T.Nativeint
1870
| Char -> T.Char
1871
| Float -> T.Float
1872
| String -> T.String
1873
| Bool -> T.Bool
1874
| Unit -> T.Unit
1875
| Option t -> T.Option (unserialize t)
1876
| List t -> T.List (unserialize t)
1877
| Array t -> T.Array (unserialize t)
1878
| Lazy t -> T.Lazy (unserialize t)
1879
| Ref t -> T.Ref (unserialize t)
1880
| Record (infos, fields) ->
1881
let mapi index (field, t) =
1882
let field = Field.of_v1 index field in
1883
field, unserialize t
1884
in
1885
let fields = Farray.mapi ~f:mapi fields in
1886
T.Record (infos, fields)
1887
| Tuple args -> T.Tuple (Farray.map ~f:unserialize args)
1888
| Variant (infos, tags) ->
1889
let kind = infos.Variant_infos.kind in
1890
let mapi index (variant_v1, t) =
1891
let variant = Variant.of_v1 kind index t tags variant_v1 in
1892
variant, Farray.map ~f:unserialize t
1893
in
1894
T.Variant (infos, Farray.mapi ~f:mapi tags)
1895
| Named (name, content) ->
1896
let content = Option.map ~f:unserialize content in
1897
T.Named (name, content)
1898
end
1899
1900
(* Switching to Variant.V2 and Field.V2.t *)
1901
module V4 : V_sig with type t = T.t = struct
1902
type t = T.t =
1903
| Int
1904
| Int32
1905
| Int64
1906
| Nativeint
1907
| Char
1908
| Float
1909
| String
1910
| Bool
1911
| Unit
1912
| Option of t
1913
| List of t
1914
| Array of t
1915
| Lazy of t
1916
| Ref of t
1917
| Tuple of t Farray.t
1918
| Record of Record_infos.V1.t * (Field.V2.t * t) Farray.t
1919
| Variant of Variant_infos.V1.t * (Variant.V2.t * t Farray.t) Farray.t
1920
| Named of Name.t * t option
1921
with sexp, bin_io
1922
let typerep_of_t = T.typerep_of_t
1923
let typename_of_t = T.typename_of_t
1924
(* *)
1925
1926
let serialize t = t
1927
let unserialize t = t
1928
end
1929
1930
type t = [
1931
| `V0 of V0.t
1932
| `V1 of V1.t
1933
| `V2 of V2.t
1934
| `V3 of V3.t
1935
| `V4 of V4.t
1936
] with bin_io, sexp, typerep
1937
1938
let aux_unserialize = function
1939
| `V0 v0 -> V0.unserialize v0
1940
| `V1 v1 -> V1.unserialize v1
1941
| `V2 v2 -> V2.unserialize v2
1942
| `V3 v3 -> V3.unserialize v3
1943
| `V4 v4 -> V4.unserialize v4
1944
1945
let serialize ~version v4 =
1946
match version with
1947
| `v0 -> `V0 (V0.serialize v4)
1948
| `v1 -> `V1 (V1.serialize v4)
1949
| `v2 -> `V2 (V2.serialize v4)
1950
| `v3 -> `V3 (V3.serialize v4)
1951
| `v4 -> `V4 (V4.serialize v4)
1952
1953
let version = function
1954
| `V0 _ -> `v0
1955
| `V1 _ -> `v1
1956
| `V2 _ -> `v2
1957
| `V3 _ -> `v3
1958
| `V4 _ -> `v4
1959
1960
let change_version ~version:requested t =
1961
if version t = requested
1962
then t
1963
else serialize ~version:requested (aux_unserialize t)
1964
1965
module Diff = struct
1966
let compute a b = Diff.compute (aux_unserialize a) (aux_unserialize b)
1967
let is_bin_prot_subtype ~subtype ~supertype =
1968
let subtype = aux_unserialize subtype in
1969
let supertype = aux_unserialize supertype in
1970
Diff.is_bin_prot_subtype ~subtype ~supertype
1971
end
1972
1973
let is_polymorphic_variant t = is_polymorphic_variant (aux_unserialize t)
1974
1975
let least_upper_bound_exn t1 t2 =
1976
let supremum = least_upper_bound_exn (aux_unserialize t1) (aux_unserialize t2) in
1977
serialize ~version:(version t1) supremum
1978
1979
let unserialize = aux_unserialize
1980
1981
let to_typerep t =
1982
To_typerep.to_typerep (aux_unserialize t)
1983
1984
let of_typerep ~version rep =
1985
let type_struct = of_typerep rep in
1986
serialize ~version type_struct
1987
end
1988
1989
type 'a typed_t = t
1990
1991
let recreate_dynamically_typerep_for_test (type a) (rep:a Typerep.t) =
1992
let Typerep.T typerep = to_typerep (of_typerep rep) in
1993
(fun (type b) (typerep:b Typerep.t) ->
1994
(* this Obj.magic is used to be able to add more testing, basically we use the ocaml
1995
runtime to deal with value create with the Obj module during the execution of
1996
[Type_struct.to_typerep] and allow ocaml to treat them as value of the right type
1997
as they had been generated by some functions whose code had been known at compile
1998
time *)
1999
(Obj.magic (typerep:b Typerep.t) : a Typerep.t)
2000
) typerep
2001
Loggerhead is a web-based interface for Breezy
Version: 2.0.1