1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
open Desc
open Tools
module Fold = struct
type ('a, 'b) t = 'a -> 'b -> 'b
end
module Folds = ParameterizedVector (Fold)
let fold :
type a structure arity rec_group positive negative direct gadt .
(a, structure, arity, rec_group, 'kinds, positive, negative, direct, gadt)
desc -> (arity, 'acc, direct) Folds.t -> (a, 'acc) Fold.t =
fun (type acc) desc folds x (acc : acc) ->
let module Vector = Folds.Unary (struct type t = acc end) in
let rec fold :
type a structure arity rec_group positive negative direct gadt .
(a, structure, arity, rec_group, 'kinds, positive, negative, direct, gadt)
desc -> (arity, direct) Vector.t -> (a, acc) Fold.t =
fun desc folds x acc ->
let fold_tuple folds tuple acc =
let fold_tuple_item (Tuple.Fold { desc; value; _ }) acc =
fold desc folds value acc in
Tuple.fold fold_tuple_item tuple acc in
let fold_record folds record acc =
let fold_record_field (Record.Fold { field; value; _ }) acc =
let fold_field _label desc folds value acc =
fold desc folds value acc in
match field with
| Poly { label; destruct; variables; _ } ->
let MakeAppend subarity = make_append variables.direct_count in
let folds =
folds |>
Vector.append None
variables.presences variables.direct_count variables.direct
variables.direct_count subarity in
let ForallDestruct { desc; destruct } =
destruct.forall_destruct variables.direct_count subarity in
fold_field label desc folds (destruct value) acc
| Mono { label; desc; _ } -> fold_field label desc folds value acc in
Record.fold fold_record_field record acc in
match desc with
| Variable index ->
Vector.get index folds x acc
| Builtin _ -> acc
| Arrow _ -> acc
| LabelledArrow _ -> acc
| Array desc ->
Array.fold_left (fun acc x -> fold desc folds x acc) acc x
| Constr { constructors; destruct; _ } ->
let Constructor.Destruct destruct =
Constructor.destruct constructors (destruct x) in
let folds' =
match destruct.link with
| Constructor.Exists { exists_count; exists; variables; _ } ->
folds |>
Vector.append
(Some { item = fun _ acc -> acc })
variables.presences variables.direct_count variables.direct
exists_count exists
| Constructor.Constructor -> folds in
begin match destruct.kind with
| Constructor.Tuple tuple ->
fold_tuple folds' tuple acc
| Constructor.Record record ->
fold_record folds' record acc
end
| Variant { constructors; destruct; _ } ->
let Variant.Destruct destruct =
Variant.destruct constructors (destruct x) in
begin match destruct.kind with
| Variant.Constructor { argument; _ }->
begin match argument with
| Variant.None -> acc
| Variant.Some { desc; value } ->
fold desc folds value acc
end
| Variant.Inherit { desc; value } ->
fold desc folds value acc
end
| Object { methods; destruct; _ } ->
let fold_object_item (Object.Fold { desc; method_; _ }) acc =
fold desc folds (method_ ()) acc in
Object.fold fold_object_item { structure = methods; methods = destruct x }
acc
| Tuple { structure; destruct; _ } ->
fold_tuple folds
{ structure = Tuple.of_desc structure; values = destruct x } acc
| Record { structure; destruct; _ } ->
fold_record folds { structure; values = destruct x } acc
| Lazy desc ->
fold desc folds (Lazy.force x) acc
| Apply { arguments; desc; transfer } ->
let folds =
Vector.make { f = fold } arguments transfer folds in
fold desc folds x acc
| Rec { desc; _ } ->
fold desc folds x acc
| RecGroup { desc } ->
fold desc folds x acc
| MapOpaque _ -> acc
| Opaque _ -> acc
| SelectGADT { desc; _ } ->
fold desc folds x acc
| SubGADT { desc; _ } ->
fold desc folds x acc
| Attributes { desc; _ } ->
fold desc folds x acc
| Name { desc; _ } ->
fold desc folds x acc
| _ -> . in
fold desc (Vector.to_unary folds) x acc