Source file make.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
open Desc
module StringMap = Stdcompat.Map.Make (String)
type ('a, 'arity, 'b) typed_attribute_kind +=
| Attribute_default : ('a, 'arity, 'a) typed_attribute_kind
type ('arity, 'rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt) field =
| F :
('a, 'structure, 'arity, 'rec_group, 'kinds, 'positive, 'negative, 'direct,
'gadt) desc * 'a ->
('arity, 'rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt) field
let rec make_fields :
type types structures .
(types, structures, 'arity, 'rec_group, 'kinds, 'positive,
'negative, 'direct, 'gadt) record_structure ->
('arity, 'rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt)
field StringMap.t ->
types =
fun structures fields ->
match structures with
| RNil -> ()
| RCons { head = Poly _; _ } ->
invalid_arg "make: polymorphic fields unsupported"
| RCons { head = Mono head; tail } ->
let head =
match StringMap.find_opt head.label fields with
| None ->
begin match head.attributes.typed Attribute_default with
| Some default -> default
| None ->
invalid_arg
(Printf.sprintf "make: no value for field '%s'" head.label)
end
| Some (F (desc, value)) ->
match Convert.cast desc head.desc value with
| value -> value in
head, make_fields tail fields
type ('a, 'b) record_type_structure =
[`RecGroup of [`Name of [`Record of 'a]] * 'b]
let make :
type a structures new_rec_group .
(a, (structures, new_rec_group) record_type_structure, 'arity,
'rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt) desc ->
('arity, new_rec_group, 'kinds, 'positive, 'negative, 'direct, 'gadt)
field StringMap.t ->
a =
fun desc fields ->
let RecGroup { desc = Name { desc =
Record { structure; construct; _ }; _ }; _ } =
desc in
construct (make_fields structure fields)