Source locations and structured errors for text codecs (extracted from jsont)
loc, xmlt, s3: complete Error API transition
loc.ml now exposes [Error.v], [Error.msg], [Error.raise], [Error.fail],
[Error.failf] (old [msg]/[msgf] renamed to raise-flavour [fail]/[failf]).
Flattens [line_pos] pair into separate [first_line_num]/[first_line_byte]
fields to match the .mli.
+100
-60
+100
-60
lib/loc.ml
+100
-60
lib/loc.ml
···
32
32
33
33
let line_num_none = -1
34
34
35
-
(* Line positions
36
-
37
-
The byte position of the first element on the line. May equal the
38
-
text length when the input ends with a newline. Subtracting this
39
-
from an absolute byte gives a column approximation that is correct
40
-
on US-ASCII data; UTF-8 multibyte runs shift it. *)
41
-
42
-
type line_pos = line_num * byte_pos
43
-
44
-
let line_pos_first = (1, 0)
45
-
let line_pos_none = (line_num_none, byte_pos_none)
35
+
(* Text locations.
46
36
47
-
(* Text locations *)
37
+
A line position is a (line number, byte offset of line start) pair.
38
+
Subtracting the line start from an absolute byte gives a column
39
+
approximation that is correct on US-ASCII data; UTF-8 multibyte runs
40
+
shift it. *)
48
41
49
42
type t = {
50
43
file : fpath;
51
44
first_byte : byte_pos;
52
45
last_byte : byte_pos;
53
-
first_line : line_pos;
54
-
last_line : line_pos;
46
+
first_line_num : line_num;
47
+
first_line_byte : byte_pos;
48
+
last_line_num : line_num;
49
+
last_line_byte : byte_pos;
55
50
}
56
51
57
-
let make ~file ~first_byte ~last_byte ~first_line ~last_line =
58
-
{ file; first_byte; last_byte; first_line; last_line }
52
+
let make ~file ~first_byte ~last_byte ~first_line_num ~first_line_byte
53
+
~last_line_num ~last_line_byte =
54
+
{
55
+
file;
56
+
first_byte;
57
+
last_byte;
58
+
first_line_num;
59
+
first_line_byte;
60
+
last_line_num;
61
+
last_line_byte;
62
+
}
59
63
60
64
let file l = l.file
61
65
let set_file l file = { l with file }
62
66
let first_byte l = l.first_byte
63
67
let last_byte l = l.last_byte
64
-
let first_line l = l.first_line
65
-
let last_line l = l.last_line
68
+
let first_line_num l = l.first_line_num
69
+
let first_line_byte l = l.first_line_byte
70
+
let last_line_num l = l.last_line_num
71
+
let last_line_byte l = l.last_line_byte
66
72
67
73
let none =
68
74
make ~file:file_none ~first_byte:byte_pos_none ~last_byte:byte_pos_none
69
-
~first_line:line_pos_none ~last_line:line_pos_none
75
+
~first_line_num:line_num_none ~first_line_byte:byte_pos_none
76
+
~last_line_num:line_num_none ~last_line_byte:byte_pos_none
70
77
71
78
(* Predicates and comparisons *)
72
79
···
87
94
88
95
(* Shrink and stretch *)
89
96
90
-
let set_first l ~first_byte ~first_line = { l with first_byte; first_line }
91
-
let set_last l ~last_byte ~last_line = { l with last_byte; last_line }
97
+
let set_first l ~first_byte ~first_line_num ~first_line_byte =
98
+
{ l with first_byte; first_line_num; first_line_byte }
99
+
100
+
let set_last l ~last_byte ~last_line_num ~last_line_byte =
101
+
{ l with last_byte; last_line_num; last_line_byte }
92
102
93
103
let to_first l =
94
104
make ~file:l.file ~first_byte:l.first_byte ~last_byte:l.first_byte
95
-
~first_line:l.first_line ~last_line:l.first_line
105
+
~first_line_num:l.first_line_num ~first_line_byte:l.first_line_byte
106
+
~last_line_num:l.first_line_num ~last_line_byte:l.first_line_byte
96
107
97
108
let to_last l =
98
109
make ~file:l.file ~first_byte:l.last_byte ~last_byte:l.last_byte
99
-
~first_line:l.last_line ~last_line:l.last_line
110
+
~first_line_num:l.last_line_num ~first_line_byte:l.last_line_byte
111
+
~last_line_num:l.last_line_num ~last_line_byte:l.last_line_byte
100
112
101
113
let before l =
102
114
make ~file:l.file ~first_byte:l.first_byte ~last_byte:byte_pos_none
103
-
~first_line:l.first_line ~last_line:line_pos_none
115
+
~first_line_num:l.first_line_num ~first_line_byte:l.first_line_byte
116
+
~last_line_num:line_num_none ~last_line_byte:byte_pos_none
104
117
105
118
let after l =
106
119
make ~file:l.file ~first_byte:(l.first_byte + 1) ~last_byte:byte_pos_none
107
-
~first_line:l.last_line ~last_line:line_pos_none
120
+
~first_line_num:l.last_line_num ~first_line_byte:l.last_line_byte
121
+
~last_line_num:line_num_none ~last_line_byte:byte_pos_none
108
122
109
123
let span l0 l1 =
110
-
let first_byte, first_line =
111
-
if l0.first_byte < l1.first_byte then (l0.first_byte, l0.first_line)
112
-
else (l1.first_byte, l1.first_line)
124
+
let first_byte, first_line_num, first_line_byte =
125
+
if l0.first_byte < l1.first_byte then
126
+
(l0.first_byte, l0.first_line_num, l0.first_line_byte)
127
+
else (l1.first_byte, l1.first_line_num, l1.first_line_byte)
113
128
in
114
-
let last_byte, last_line, file =
115
-
if l0.last_byte < l1.last_byte then (l1.last_byte, l1.last_line, l1.file)
116
-
else (l0.last_byte, l0.last_line, l0.file)
129
+
let last_byte, last_line_num, last_line_byte, file =
130
+
if l0.last_byte < l1.last_byte then
131
+
(l1.last_byte, l1.last_line_num, l1.last_line_byte, l1.file)
132
+
else (l0.last_byte, l0.last_line_num, l0.last_line_byte, l0.file)
117
133
in
118
-
make ~file ~first_byte ~first_line ~last_byte ~last_line
134
+
make ~file ~first_byte ~first_line_num ~first_line_byte ~last_byte
135
+
~last_line_num ~last_line_byte
119
136
120
137
let reloc ~first ~last =
121
138
make ~file:last.file ~first_byte:first.first_byte ~last_byte:last.last_byte
122
-
~first_line:first.first_line ~last_line:last.last_line
139
+
~first_line_num:first.first_line_num ~first_line_byte:first.first_line_byte
140
+
~last_line_num:last.last_line_num ~last_line_byte:last.last_line_byte
123
141
124
142
(* Formatters *)
125
143
···
129
147
if is_none l then pf ppf "File \"%a\"" pp_path l.file
130
148
else
131
149
let pp_lines ppf l =
132
-
if fst l.first_line = fst l.last_line then
133
-
pf ppf "line %d" (fst l.first_line)
134
-
else pf ppf "lines %d-%d" (fst l.first_line) (fst l.last_line)
150
+
if l.first_line_num = l.last_line_num then
151
+
pf ppf "line %d" l.first_line_num
152
+
else pf ppf "lines %d-%d" l.first_line_num l.last_line_num
135
153
in
136
-
let pos_s = l.first_byte - snd l.first_line in
137
-
let pos_e = l.last_byte - snd l.last_line + 1 in
154
+
let pos_s = l.first_byte - l.first_line_byte in
155
+
let pos_e = l.last_byte - l.last_line_byte + 1 in
138
156
if pos_s = 0 && pos_e = 0 then
139
157
pf ppf "File \"%a\", %a" pp_path l.file pp_lines l
140
158
else
···
145
163
if is_none l then pf ppf "%a:" pp_path l.file
146
164
else
147
165
let pp_lines ppf l =
148
-
let col_s = l.first_byte - snd l.first_line + 1 in
149
-
let col_e = l.last_byte - snd l.last_line + 1 in
150
-
if fst l.first_line = fst l.last_line then
151
-
pf ppf "%d.%d-%d" (fst l.first_line) col_s col_e
152
-
else pf ppf "%d.%d-%d.%d" (fst l.first_line) col_s (fst l.last_line) col_e
166
+
let col_s = l.first_byte - l.first_line_byte + 1 in
167
+
let col_e = l.last_byte - l.last_line_byte + 1 in
168
+
if l.first_line_num = l.last_line_num then
169
+
pf ppf "%d.%d-%d" l.first_line_num col_s col_e
170
+
else pf ppf "%d.%d-%d.%d" l.first_line_num col_s l.last_line_num col_e
153
171
in
154
172
pf ppf "%a:%a" pp_path l.file pp_lines l
155
173
···
157
175
158
176
let pp_dump ppf l =
159
177
pf ppf "file:%s bytes:%d-%d lines:(%d,%d)-(%d,%d)" l.file l.first_byte
160
-
l.last_byte (fst l.first_line) (snd l.first_line) (fst l.last_line)
161
-
(snd l.last_line)
178
+
l.last_byte l.first_line_num l.first_line_byte l.last_line_num
179
+
l.last_line_byte
162
180
163
181
(* Local helper: String.sub by byte range, tolerant of out-of-bounds. *)
164
182
···
276
294
277
295
(* Errors *)
278
296
279
-
type error_kind = string
297
+
type error_kind = ..
298
+
type error_kind += Msg of string
280
299
type context_index = string node * Path.index
281
300
type context = context_index list
282
301
type error = context * Meta.t * error_kind
···
284
303
exception Error of error
285
304
286
305
module Error = struct
287
-
type kind = error_kind
306
+
type kind = error_kind = ..
307
+
type kind += Msg = Msg
288
308
type t = error
289
309
290
-
let kind_to_string k = k
291
-
let pp_kind = pp_code
310
+
(* Registry of printers contributed by codec libraries. The first printer
311
+
that returns [Some f] wins; [Msg] falls through to the default. *)
312
+
let kind_printers : (error_kind -> (Format.formatter -> unit) option) list ref
313
+
=
314
+
ref []
315
+
316
+
let register_kind_printer p = kind_printers := p :: !kind_printers
317
+
318
+
let default_pp_kind ppf = function
319
+
| Msg s -> Fmt.lines ppf s
320
+
| _ -> Format.pp_print_string ppf "<unknown error kind>"
321
+
322
+
let pp_kind ppf k =
323
+
let rec find = function
324
+
| [] -> default_pp_kind ppf k
325
+
| p :: ps -> ( match p k with Some f -> f ppf | None -> find ps)
326
+
in
327
+
find !kind_printers
328
+
329
+
let kind_to_string k = Format.asprintf "%a" pp_kind k
292
330
let pp_name = pp_code
293
331
let pp_int ppf i = pp_code ppf (Int.to_string i)
294
332
···
310
348
match index with
311
349
| Path.Nth (n, meta) ->
312
350
Fmt.pf ppf "@[<v>%aat index %a of@,%a%a@]" pp_meta meta pp_int n
313
-
pp_meta (snd kind) pp_kind (fst kind)
351
+
pp_meta (snd kind) pp_name (fst kind)
314
352
| Path.Mem (name, meta) ->
315
353
Fmt.pf ppf "@[<v>%ain member %a of@,%a%a@]" pp_meta meta pp_name
316
-
name pp_meta (snd kind) pp_kind (fst kind)
354
+
name pp_meta (snd kind) pp_name (fst kind)
317
355
in
318
356
if ctx = [] then ()
319
357
else Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_el) (List.rev ctx)
320
358
end
321
359
322
-
let make_msg ctx meta msg = (ctx, meta, msg)
323
-
let raise ctx meta msg = raise_notrace (Error (ctx, meta, msg))
324
-
let msg meta msg = raise_notrace (Error (Context.empty, meta, msg))
325
-
let msgf meta fmt = Format.kasprintf (fun m -> msg meta m) fmt
360
+
let v ctx meta kind = (ctx, meta, kind)
361
+
let msg ctx meta s = (ctx, meta, Msg s)
362
+
let raise ctx meta kind = raise_notrace (Error (ctx, meta, kind))
363
+
let fail meta s = raise_notrace (Error (Context.empty, meta, Msg s))
364
+
let failf meta fmt = Format.kasprintf (fun s -> fail meta s) fmt
326
365
327
366
let push_array kinded_sort n (ctx, meta, e) =
328
367
raise_notrace (Error (Context.push_array kinded_sort n ctx, meta, e))
···
330
369
let push_object kinded_sort n (ctx, meta, e) =
331
370
raise_notrace (Error (Context.push_object kinded_sort n ctx, meta, e))
332
371
333
-
let adjust_context ~first_byte ~first_line (ctx, meta, e) =
372
+
let adjust_context ~first_byte ~first_line_num ~first_line_byte (ctx, meta, e)
373
+
=
334
374
match ctx with
335
375
| [] -> raise_notrace (Error (ctx, meta, e))
336
376
| ((sort, smeta), idx) :: is ->
337
377
let textloc = Meta.textloc smeta in
338
378
let textloc =
339
379
if is_none textloc then textloc
340
-
else set_first textloc ~first_byte ~first_line
380
+
else set_first textloc ~first_byte ~first_line_num ~first_line_byte
341
381
in
342
382
let smeta = Meta.with_textloc smeta textloc in
343
383
let ctx = ((sort, smeta), idx) :: is in
344
384
raise_notrace (Error (ctx, meta, e))
345
385
346
-
let pp ppf (ctx, m, msg) =
386
+
let pp ppf (ctx, m, kind) =
347
387
let pp_meta ppf m =
348
388
if not (Meta.is_none m) then Fmt.pf ppf "@,%a:" pp (Meta.textloc m)
349
389
in
350
-
Fmt.pf ppf "@[<v>%a%a%a@]" Fmt.lines msg pp_meta m Context.pp ctx
390
+
Fmt.pf ppf "@[<v>%a%a%a@]" pp_kind kind pp_meta m Context.pp ctx
351
391
352
392
let to_string e = Format.asprintf "%a" pp e
353
393
···
356
396
Fmt.char ppf ':'
357
397
358
398
let expected meta exp ~fnd =
359
-
msgf meta "Expected %a but found %a" pp_code exp pp_code fnd
399
+
failf meta "Expected %a but found %a" pp_code exp pp_code fnd
360
400
end