Source file enum.ml
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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
open Desc
open Tools
type ('a, 'arity, 'b) typed_attribute_kind +=
| Attribute_value : ('a, 'arity, int) typed_attribute_kind
let rec lift_zero (l : ('cases binary_choice * int option) list) :
(('cases * _) binary_choice * int option) list =
match l with
| [] -> []
| (choice, value) :: tl -> (CZero choice, value) :: lift_zero tl
let rec lift_one (l : ('cases binary_choice * int option) list) :
((_ * 'cases) binary_choice * int option) list =
match l with
| [] -> []
| (choice, value) :: tl -> (COne choice, value) :: lift_one tl
let rec merge l0 l1 =
match l0, l1 with
| hd0 :: tl0, hd1 :: tl1 -> hd0 :: hd1 :: merge tl0 tl1
| _, [] -> l0
| [], l1 -> l1
let rec constructor_assoc :
type cases structures .
(cases, structures, 'arity, 'rec_group, 'kinds, 'positive,
'negative, 'direct, 'gadt) constructors ->
(cases binary_choice * int option) list =
fun constructors ->
match constructors with
| CNode { zero; one } ->
merge
(lift_zero (constructor_assoc zero))
(lift_one (constructor_assoc one))
| CLeaf constructor ->
begin match constructor with
| Constructor { kind = CTuple TNil; eqs = ENil; attributes; _ } ->
[(CEnd ((), ()), attributes.typed Attribute_value)]
| _ -> []
end
let constructor_assoc_with_default_values constructors =
let assoc = constructor_assoc constructors in
let put_default_value (default, accu) (choice, value) =
let value = Stdcompat.Option.value ~default value in
(succ value, (choice, value) :: accu) in
let (_default_value, accu) =
List.fold_left put_default_value (0, []) assoc in
List.rev accu
let fold :
type a .
(int -> int -> int) ->
(a, [`RecGroup of [`Name of [`Constr of 'structures]] * _],
'arity, 'rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt) desc ->
int =
fun op constructors ->
match constructors with
| RecGroup { desc = Name { desc = Constr { constructors; _ }; _}; _ } ->
match constructor_assoc_with_default_values constructors with
| [] -> 0
| (_, value) :: tail ->
List.fold_left (fun a (_, b) -> op a b) value tail
type ('a, 'b) enum_structure =
[`RecGroup of [`Name of [`Constr of 'a]] * 'b]
let min :
type a .
(a, ('structures, _) enum_structure,
'arity, 'rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt) desc ->
int =
fun constructors ->
fold min constructors
let max :
type a .
(a, ('structures, _) enum_structure,
'arity, 'rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt) desc ->
int =
fun constructors ->
fold max constructors
let check_choice (c : 'cases binary_choice)
((c', _) : ('cases binary_choice * int)) =
Tools.equal_binary_choice c c'
let check_value (v : int)
((_, v') : ('cases binary_choice * int)) =
v = v'
let to_int_opt :
type a .
(a, ('structures, _) enum_structure,
'arity, 'rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt) desc ->
a -> int option =
fun desc value ->
match desc with
| RecGroup { desc = Name { desc =
Constr { constructors; destruct; _ }; _ }; _ } ->
Stdcompat.Option.map snd
(Stdcompat.List.find_opt (check_choice (destruct value))
(constructor_assoc_with_default_values constructors))
let of_int_opt :
type a .
(a, ('structures, _) enum_structure,
'arity, 'rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt) desc ->
int -> a option =
fun desc value ->
match desc with
| RecGroup { desc = Name { desc =
Constr { construct; constructors; _ }; _ }; _ } ->
Stdcompat.Option.map (fun item -> construct (fst item))
(Stdcompat.List.find_opt (check_value value)
(constructor_assoc_with_default_values constructors))
let to_string :
type a .
(a, ('structures, _) enum_structure,
'arity, 'rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt) desc ->
a -> string =
fun desc value ->
match desc with
| RecGroup { desc = Name { desc =
Constr { constructors; destruct; _ }; _ }; _ } ->
let Constructor.Destruct destruct =
Constructor.destruct constructors (destruct value) in
destruct.name
let rec of_string_aux :
type cases structures .
(cases, structures, 'arity, 'rec_group, 'kinds, 'positive,
'negative, 'direct, 'gadt) constructors ->
string ->
cases binary_choice option =
fun constructors value ->
match constructors with
| CNode { zero; one } ->
begin match of_string_aux zero value with
| None -> Stdcompat.Option.map (fun c -> COne c) (of_string_aux one value)
| some -> Stdcompat.Option.map (fun c -> CZero c) some
end
| CLeaf (Constructor c) when c.name = value ->
begin match c.kind, c.eqs with
| CTuple TNil, ENil ->
Some (CEnd ((), ()))
| _ -> None
end
| _ -> None
let of_string_opt :
type a .
(a, ('structures, _) enum_structure,
'arity, 'rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt) desc ->
string -> a option =
fun desc value ->
match desc with
| RecGroup { desc = Name { desc =
Constr { construct; constructors; _ }; _ }; _ } ->
match of_string_aux constructors value with
| None -> None
| Some choice -> Some (construct choice)