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
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
open Import
type t = Ast.annot
let error_at loc s =
failwith (sprintf "%s:\n%s" (Ast.string_of_loc loc) s)
let fields ~section ~field l =
List.filter_map (fun (s, (_, fs)) ->
if s = section then Some fs else None) l
|> List.map (fun fs ->
List.filter_map (fun (f, (l, s)) ->
if f = field then Some (l, s) else None)
fs)
|> List.flatten
let field ~section ~field l =
match fields ~section ~field l with
| [fieldmatch] -> Some fieldmatch
| (loc, _) :: others -> error_at loc
(sprintf "Duplicate annotation %s.%s (also in:\n %s\n)" section field
(List.map (fun (loc, _) -> (Ast.string_of_loc loc)) others
|> String.concat ",\n "))
| _ -> None
let has_section k l =
Option.is_some (List.assoc k l)
let has_field ~sections:k ~field:k2 l =
List.exists (fun k1 ->
field ~section:k1 ~field:k2 l
|> Option.is_some
) k
let get_flag ~sections:k ~field:k2 l =
k
|> List.find_map (fun k1 ->
field ~section:k1 ~field:k2 l
|> Option.map (fun (loc, o) ->
match o with
| None | Some "true" -> true
| Some "false" -> false
| Some s ->
error_at loc
(sprintf "Invalid value %S for flag %s.%s" s k1 k2)))
|> Option.value ~default:false
let get_field ~parse ~default ~sections:k ~field:k2 l =
k
|> List.find_map (fun k1 ->
let open Option.O in
field l ~section:k1 ~field:k2 >>= fun (loc, o) ->
match o with
| Some s ->
(match parse s with
Some _ as y -> y
| None ->
error_at loc
(sprintf "Invalid annotation <%s %s=%S>" k1 k2 s))
| None ->
error_at loc
(sprintf "Missing value for annotation %s.%s" k1 k2))
|> Option.value ~default
let get_fields ~parse ~sections ~field l =
List.find_map (fun section ->
Some (
fields l ~section ~field
|> List.map (fun (loc, o) ->
match o with
| None ->
error_at loc
(sprintf "Missing value for annotation %s.%s" section field)
| Some s ->
(match parse s with
| None ->
error_at loc
(sprintf "Invalid annotation <%s %s=%S>" section field s)
| Some v -> v))
)) sections
|> Option.value ~default:[]
let get_opt_field ~parse ~sections ~field l =
let parse s =
match parse s with
| None -> None
| Some v -> Some (Some v)
in
get_field ~parse ~default:None ~sections ~field l
let set_field ~loc ~section:k ~field:k2 v l : Ast.annot =
match List.assoc k l with
| None -> (k, (loc, [ k2, (loc, v) ])) :: l
| Some (section_loc, section) ->
let section_loc, section = List.assoc_exn k l in
let section =
match List.assoc k2 section with
| None -> (k2, (loc, v)) :: section
| Some _ -> List.assoc_update k2 (loc, v) section
in
List.assoc_update k (section_loc, section) l
let collapse merge l =
let tbl = Hashtbl.create 10 in
let n = ref 0 in
List.iter (
fun (s1, f1) ->
incr n;
try
let _, f2 = Hashtbl.find tbl s1 in
Hashtbl.replace tbl s1 (!n, merge f1 f2)
with Not_found ->
Hashtbl.add tbl s1 (!n, f1)
) (List.rev l);
let l = Hashtbl.fold (fun s (i, f) l -> (i, (s, f)) :: l) tbl [] in
let l = List.sort (fun (i, _) (j, _) -> compare j i) l in
List.map snd l
let override_values x1 _ = x1
let override_fields (loc1, l1) (_, l2) =
(loc1, collapse override_values (l1 @ l2))
let merge l =
collapse override_fields l
let create_id =
let n = ref (-1) in
fun () ->
incr n;
if !n < 0 then
failwith "Annot.create_id: counter overflow"
else
string_of_int !n
type node_kind =
| Module_head
| Type_def
| Type_expr
| Variant
| Cell
| Field
type schema_field = node_kind * string
type schema_section = {
section: string;
fields: schema_field list;
}
type schema = schema_section list
let validate_section sec root =
let in_module_head = ref [] in
let in_type_def = ref [] in
let in_type_expr = ref [] in
let in_variant = ref [] in
let in_cell = ref [] in
let in_field = ref [] in
sec.fields
|> List.iter (fun (kind, field_name) ->
let acc =
match kind with
| Module_head -> in_module_head
| Type_def -> in_type_def
| Type_expr -> in_type_expr
| Variant -> in_variant
| Cell -> in_cell
| Field -> in_field
in
acc := field_name :: ! acc
);
let check acc =
let allowed_fields = List.rev !acc in
fun _node (an : Ast.annot) () ->
an
|> List.iter (fun ((sec_name, (loc, fields)) : Ast.annot_section) ->
if sec_name = sec.section then
fields
|> List.iter (fun (field_name, (loc2, _opt_val)) ->
if not (List.mem field_name allowed_fields) then
Ast.error_at loc2
(sprintf "Invalid or misplaced annotation <%s ... %s... >"
sec_name field_name)
)
)
in
Ast.fold_annot
~module_head:(check in_module_head)
~type_def:(check in_type_def)
~type_expr:(check in_type_expr)
~variant:(check in_variant)
~cell:(check in_cell)
~field:(check in_field)
root ()
let validate schema root =
List.iter (fun sec ->
validate_section sec root
) schema