Source locations and structured errors for text codecs (extracted from jsont)
loc: drop tuple line_pos in favour of explicit fields
Loc.make and Loc.set_first/set_last previously took a (line_num,
byte_pos) tuple. Replace with four explicit labelled args
(first_line_num, first_line_byte, last_line_num, last_line_byte) so
call sites are self-documenting and harder to swap by mistake.
Likewise expose first_line_num / first_line_byte (etc.) accessors
instead of first_line / last_line returning the tuple.
Also rename Error.msgf to Error.failf to match the convention of
"raise" being implicit in the action verb (failf raises immediately;
msgf was historically a "wrap and raise" combinator that has the
same behaviour).
ocaml-csvt is the only in-repo consumer that still used the tuple
form; adapt csvt.ml to the new signature and the failf rename.
+146
-107
+9
-10
README.md
+9
-10
README.md
···
34
34
let loc =
35
35
Loc.make ~file:"config.toml"
36
36
~first_byte:42 ~last_byte:47
37
-
~first_line:(3, 0) ~last_line:(3, 0)
37
+
~first_line_num:3 ~first_line_byte:0
38
+
~last_line_num:3 ~last_line_byte:0
38
39
39
40
let meta = Loc.Meta.make loc
40
41
···
45
46
Loc.Error.msgf meta "expected %s, got %s" "integer" "\"nope\""
46
47
with Loc.Error e ->
47
48
print_endline (Loc.Error.to_string e)
48
-
(* File "config.toml", line 3, characters 42-48:
49
-
expected integer, got "nope" *)
49
+
(* expected integer, got "nope"
50
+
File "config.toml", line 3, characters 42-48: *)
50
51
51
-
(* Build a path and attach context to an error as it bubbles up. *)
52
-
let raise_in_context () =
53
-
let root_kind = ("element <server>", Loc.Meta.none) in
52
+
(* Wrap a raised error with structural context as it bubbles up. *)
53
+
let () =
54
+
let root = ("table [server]", Loc.Meta.none) in
54
55
try
55
56
try
56
57
Loc.Error.msg Loc.Meta.none "not a number"
57
58
with Loc.Error e ->
58
-
Loc.Error.push_object root_kind ("port", Loc.Meta.none) e
59
+
Loc.Error.push_object root ("port", Loc.Meta.none) e
59
60
with Loc.Error e ->
60
-
let ctx, _, _ = e in
61
-
List.length ctx
62
-
(* 1 -- the port/server frame *)
61
+
print_endline (Loc.Error.to_string e)
63
62
```
64
63
65
64
## API
+67
-34
lib/loc.mli
+67
-34
lib/loc.mli
···
42
42
val line_num_none : line_num
43
43
(** [line_num_none] is [-1]. A line number to use when there is none. *)
44
44
45
-
(** {2:line_pos Line positions} *)
45
+
(** {2:line_pos Line positions}
46
46
47
-
type line_pos = line_num * byte_pos
48
-
(** The type for line positions. This identifies a line by its line number and
49
-
the absolute byte position following its newline (or the start of text for
50
-
the first line). That byte position:
47
+
A line position is a line number paired with the absolute byte position
48
+
following its newline (or the start of text for the first line). That byte
49
+
position:
51
50
- indexes the first byte of the line if it is non-empty;
52
51
- indexes the first byte of the next newline sequence if the line is empty;
53
52
- is out of bounds and equal to the text's length for a last empty line
54
53
(also the case on empty text). *)
55
54
56
-
val line_pos_first : line_pos
57
-
(** [line_pos_first] is [1, 0]. This is the only line position of the empty
58
-
text. *)
59
-
60
-
val line_pos_none : line_pos
61
-
(** [line_pos_none] is [(line_num_none, byte_pos_none)]. *)
62
-
63
55
(** {1:tloc Text locations} *)
64
56
65
57
type t
···
75
67
file:fpath ->
76
68
first_byte:byte_pos ->
77
69
last_byte:byte_pos ->
78
-
first_line:line_pos ->
79
-
last_line:line_pos ->
70
+
first_line_num:line_num ->
71
+
first_line_byte:byte_pos ->
72
+
last_line_num:line_num ->
73
+
last_line_byte:byte_pos ->
80
74
t
81
-
(** [make ~file ~first_byte ~last_byte ~first_line ~last_line] is a text
82
-
location with the given parameters. Use {!file_none} when there is no file.
83
-
*)
75
+
(** [make ~file ~first_byte ~last_byte ~first_line_num ~first_line_byte
76
+
~last_line_num ~last_line_byte] is a text location with the given
77
+
parameters. Use {!file_none} when there is no file. *)
84
78
85
79
val file : t -> fpath
86
80
val set_file : t -> fpath -> t
87
81
val first_byte : t -> byte_pos
88
82
val last_byte : t -> byte_pos
89
-
val first_line : t -> line_pos
90
-
val last_line : t -> line_pos
83
+
val first_line_num : t -> line_num
84
+
val first_line_byte : t -> byte_pos
85
+
val last_line_num : t -> line_num
86
+
val last_line_byte : t -> byte_pos
91
87
92
88
(** {2:preds Predicates and comparisons} *)
93
89
···
107
103
108
104
(** {2:shrink_and_stretch Shrink and stretch} *)
109
105
110
-
val set_first : t -> first_byte:byte_pos -> first_line:line_pos -> t
111
-
val set_last : t -> last_byte:byte_pos -> last_line:line_pos -> t
106
+
val set_first :
107
+
t ->
108
+
first_byte:byte_pos ->
109
+
first_line_num:line_num ->
110
+
first_line_byte:byte_pos ->
111
+
t
112
+
113
+
val set_last :
114
+
t ->
115
+
last_byte:byte_pos ->
116
+
last_line_num:line_num ->
117
+
last_line_byte:byte_pos ->
118
+
t
112
119
113
120
val to_first : t -> t
114
121
(** [to_first l] has both positions set to [l]'s first position. *)
···
246
253
module Error : sig
247
254
type loc := t
248
255
249
-
type kind
250
-
(** The type of error kinds. Currently opaque (a tagged string). *)
256
+
type kind = ..
257
+
(** The type of error kinds. Extensible: each codec library extends this with
258
+
its own typed constructors (e.g. sort mismatches, missing members,
259
+
duplicate keys) and registers a printer via {!register_kind_printer}. *)
260
+
261
+
type kind +=
262
+
| Msg of string
263
+
(** [Msg s] is the generic message kind used by {!msg} and {!msgf}. *)
264
+
265
+
val register_kind_printer :
266
+
(kind -> (Format.formatter -> unit) option) -> unit
267
+
(** [register_kind_printer p] adds [p] to the printer registry. When
268
+
formatting a [kind], registered printers are tried in reverse order of
269
+
registration; the first one returning [Some f] is used. Fallback handles
270
+
{!Msg}. Call this once per codec library at load time. *)
271
+
272
+
val pp_kind : Format.formatter -> kind -> unit
273
+
(** [pp_kind] formats a kind via the registered printers. *)
251
274
252
275
val kind_to_string : kind -> string
253
-
(** [kind_to_string k] is the underlying message string of [k]. *)
276
+
(** [kind_to_string k] is the kind formatted as a string. *)
254
277
255
278
module Context : sig
256
279
type index = string node * Path.index
···
283
306
(** An error: a context, the error's source location and whitespace meta, and
284
307
the error kind (tag + message). *)
285
308
309
+
val v : Context.t -> Meta.t -> kind -> t
310
+
(** [v ctx meta kind] constructs an error value with a typed kind. *)
311
+
312
+
val msg : Context.t -> Meta.t -> string -> t
313
+
(** [msg ctx meta s] is [v ctx meta (Msg s)]. *)
314
+
286
315
val raise : Context.t -> Meta.t -> kind -> 'a
287
316
(** [raise ctx meta kind] raises the {!Error} exception. *)
288
317
289
-
val make_msg : Context.t -> Meta.t -> string -> t
290
-
(** [make_msg ctx meta msg] constructs an error value. *)
318
+
val fail : Meta.t -> string -> 'a
319
+
(** [fail meta s] raises an error with empty context and message [s]. *)
291
320
292
-
val msg : Meta.t -> string -> 'a
293
-
(** [msg meta s] raises an error with empty context. *)
294
-
295
-
val msgf : Meta.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a
296
-
(** [msgf meta fmt] raises an error, formatted per [fmt]. *)
321
+
val failf : Meta.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a
322
+
(** [failf meta fmt] raises an error with empty context, message formatted per
323
+
[fmt]. *)
297
324
298
325
val expected : Meta.t -> string -> fnd:string -> 'a
299
326
(** [expected meta exp ~fnd] raises an ["Expected exp but found fnd"] error.
···
307
334
(** [push_object kinded_sort n e] re-raises [e] after pushing an object member
308
335
onto its context. *)
309
336
310
-
val adjust_context : first_byte:byte_pos -> first_line:line_pos -> t -> 'a
311
-
(** [adjust_context ~first_byte ~first_line e] re-raises [e] with the
312
-
first-position of its innermost context's location updated. *)
337
+
val adjust_context :
338
+
first_byte:byte_pos ->
339
+
first_line_num:line_num ->
340
+
first_line_byte:byte_pos ->
341
+
t ->
342
+
'a
343
+
(** [adjust_context ~first_byte ~first_line_num ~first_line_byte e] re-raises
344
+
[e] with the first-position of its innermost context's location updated.
345
+
*)
313
346
314
347
val to_string : t -> string
315
348
(** [to_string e] is the error formatted as a string. *)
+70
-63
test/test_loc.ml
+70
-63
test/test_loc.ml
···
13
13
loop 0
14
14
15
15
let sample =
16
-
Loc.make ~file:"foo.ml" ~first_byte:10 ~last_byte:14 ~first_line:(2, 5)
17
-
~last_line:(2, 5)
16
+
Loc.make ~file:"foo.ml" ~first_byte:10 ~last_byte:14 ~first_line_num:2
17
+
~first_line_byte:5 ~last_line_num:2 ~last_line_byte:5
18
18
19
-
(* ── Constructors and accessors ──────────────────────────── *)
19
+
(* -- Constructors and accessors -- *)
20
20
21
21
let make_and_accessors () =
22
22
Alcotest.(check string) "file" "foo.ml" (Loc.file sample);
23
23
Alcotest.(check int) "first_byte" 10 (Loc.first_byte sample);
24
24
Alcotest.(check int) "last_byte" 14 (Loc.last_byte sample);
25
-
Alcotest.(check (pair int int))
26
-
"first_line" (2, 5)
27
-
(Loc.first_line sample);
28
-
Alcotest.(check (pair int int)) "last_line" (2, 5) (Loc.last_line sample)
25
+
Alcotest.(check int) "first_line_num" 2 (Loc.first_line_num sample);
26
+
Alcotest.(check int) "first_line_byte" 5 (Loc.first_line_byte sample);
27
+
Alcotest.(check int) "last_line_num" 2 (Loc.last_line_num sample);
28
+
Alcotest.(check int) "last_line_byte" 5 (Loc.last_line_byte sample)
29
29
30
30
let set_file () =
31
31
let l = Loc.set_file sample "other.ml" in
···
37
37
38
38
let empty_detection () =
39
39
let empty =
40
-
Loc.make ~file:"-" ~first_byte:5 ~last_byte:3 ~first_line:(1, 0)
41
-
~last_line:(1, 0)
40
+
Loc.make ~file:"-" ~first_byte:5 ~last_byte:3 ~first_line_num:1
41
+
~first_line_byte:0 ~last_line_num:1 ~last_line_byte:0
42
42
in
43
43
Alcotest.(check bool) "empty" true (Loc.is_empty empty);
44
44
Alcotest.(check bool) "sample not empty" false (Loc.is_empty sample)
···
47
47
48
48
let equal_ignores_line_info () =
49
49
let a =
50
-
Loc.make ~file:"f" ~first_byte:3 ~last_byte:7 ~first_line:(1, 0)
51
-
~last_line:(1, 0)
50
+
Loc.make ~file:"f" ~first_byte:3 ~last_byte:7 ~first_line_num:1
51
+
~first_line_byte:0 ~last_line_num:1 ~last_line_byte:0
52
52
in
53
53
let b =
54
-
Loc.make ~file:"f" ~first_byte:3 ~last_byte:7 ~first_line:(2, 10)
55
-
~last_line:(3, 20)
54
+
Loc.make ~file:"f" ~first_byte:3 ~last_byte:7 ~first_line_num:2
55
+
~first_line_byte:10 ~last_line_num:3 ~last_line_byte:20
56
56
in
57
-
Alcotest.(check bool)
58
-
"equal despite different line info" true (Loc.equal a b)
57
+
Alcotest.(check bool) "equal despite different line info" true (Loc.equal a b)
59
58
60
59
let compare_orders_by_file_then_byte () =
61
60
let a =
62
-
Loc.make ~file:"a" ~first_byte:0 ~last_byte:0 ~first_line:(1, 0)
63
-
~last_line:(1, 0)
61
+
Loc.make ~file:"a" ~first_byte:0 ~last_byte:0 ~first_line_num:1
62
+
~first_line_byte:0 ~last_line_num:1 ~last_line_byte:0
64
63
in
65
64
let b =
66
-
Loc.make ~file:"b" ~first_byte:0 ~last_byte:0 ~first_line:(1, 0)
67
-
~last_line:(1, 0)
65
+
Loc.make ~file:"b" ~first_byte:0 ~last_byte:0 ~first_line_num:1
66
+
~first_line_byte:0 ~last_line_num:1 ~last_line_byte:0
68
67
in
69
68
Alcotest.(check bool) "a < b (by file)" true (Loc.compare a b < 0);
70
69
let b2 =
71
-
Loc.make ~file:"a" ~first_byte:5 ~last_byte:10 ~first_line:(1, 0)
72
-
~last_line:(1, 0)
70
+
Loc.make ~file:"a" ~first_byte:5 ~last_byte:10 ~first_line_num:1
71
+
~first_line_byte:0 ~last_line_num:1 ~last_line_byte:0
73
72
in
74
73
Alcotest.(check bool) "a < b2 (by first_byte)" true (Loc.compare a b2 < 0)
75
74
···
77
76
78
77
let to_first_and_to_last () =
79
78
let l =
80
-
Loc.make ~file:"-" ~first_byte:5 ~last_byte:10 ~first_line:(2, 2)
81
-
~last_line:(3, 8)
79
+
Loc.make ~file:"-" ~first_byte:5 ~last_byte:10 ~first_line_num:2
80
+
~first_line_byte:2 ~last_line_num:3 ~last_line_byte:8
82
81
in
83
82
let fst = Loc.to_first l in
84
83
Alcotest.(check int) "to_first first_byte" 5 (Loc.first_byte fst);
···
89
88
90
89
let span_unions_ranges () =
91
90
let a =
92
-
Loc.make ~file:"-" ~first_byte:3 ~last_byte:7 ~first_line:(1, 0)
93
-
~last_line:(1, 0)
91
+
Loc.make ~file:"-" ~first_byte:3 ~last_byte:7 ~first_line_num:1
92
+
~first_line_byte:0 ~last_line_num:1 ~last_line_byte:0
94
93
in
95
94
let b =
96
-
Loc.make ~file:"-" ~first_byte:10 ~last_byte:20 ~first_line:(1, 0)
97
-
~last_line:(1, 0)
95
+
Loc.make ~file:"-" ~first_byte:10 ~last_byte:20 ~first_line_num:1
96
+
~first_line_byte:0 ~last_line_num:1 ~last_line_byte:0
98
97
in
99
98
let s = Loc.span a b in
100
99
Alcotest.(check int) "span first_byte" 3 (Loc.first_byte s);
···
104
103
105
104
let pp_ocaml_single_line () =
106
105
let l =
107
-
Loc.make ~file:"foo.ml" ~first_byte:10 ~last_byte:14 ~first_line:(2, 5)
108
-
~last_line:(2, 5)
106
+
Loc.make ~file:"foo.ml" ~first_byte:10 ~last_byte:14 ~first_line_num:2
107
+
~first_line_byte:5 ~last_line_num:2 ~last_line_byte:5
109
108
in
110
109
let out = Fmt.str "%a" Loc.pp_ocaml l in
111
110
Alcotest.(check string)
···
113
112
114
113
let pp_gnu_format () =
115
114
let l =
116
-
Loc.make ~file:"foo.ml" ~first_byte:10 ~last_byte:14 ~first_line:(2, 5)
117
-
~last_line:(2, 5)
115
+
Loc.make ~file:"foo.ml" ~first_byte:10 ~last_byte:14 ~first_line_num:2
116
+
~first_line_byte:5 ~last_line_num:2 ~last_line_byte:5
118
117
in
119
118
let out = Fmt.str "%a" Loc.pp_gnu l in
120
119
Alcotest.(check string) "gnu format" "foo.ml:2.6-10" out
···
135
134
(Loc.equal sample (Loc.Meta.textloc m))
136
135
137
136
let meta_none () =
138
-
Alcotest.(check bool)
139
-
"none is_none" true
140
-
(Loc.Meta.is_none Loc.Meta.none);
141
-
Alcotest.(check string)
142
-
"none ws_before" ""
143
-
(Loc.Meta.ws_before Loc.Meta.none)
137
+
Alcotest.(check bool) "none is_none" true (Loc.Meta.is_none Loc.Meta.none);
138
+
Alcotest.(check string) "none ws_before" "" (Loc.Meta.ws_before Loc.Meta.none)
144
139
145
140
let meta_with_textloc () =
146
141
let m = Loc.Meta.make ~ws_before:"a" sample in
···
170
165
(* -- Path ------------------------------------------------------ *)
171
166
172
167
let path_root () =
173
-
Alcotest.(check bool)
174
-
"root is_root" true
175
-
(Loc.Path.is_root Loc.Path.root)
168
+
Alcotest.(check bool) "root is_root" true (Loc.Path.is_root Loc.Path.root)
176
169
177
170
let path_build () =
178
171
let p = Loc.Path.mem "a" Loc.Path.root in
179
172
let p = Loc.Path.mem "b" p in
180
173
let p = Loc.Path.nth 3 p in
181
174
match Loc.Path.rev_indices p with
182
-
| [
183
-
Loc.Path.Nth (3, _); Loc.Path.Mem ("b", _); Loc.Path.Mem ("a", _);
184
-
] ->
185
-
()
175
+
| [ Loc.Path.Nth (3, _); Loc.Path.Mem ("b", _); Loc.Path.Mem ("a", _) ] -> ()
186
176
| _ -> Alcotest.fail "unexpected path shape"
187
177
188
178
let path_of_string_roundtrip () =
···
191
181
| Ok p -> (
192
182
match Loc.Path.rev_indices p with
193
183
| [
194
-
Loc.Path.Nth (0, _);
195
-
Loc.Path.Mem ("libs", _);
196
-
Loc.Path.Mem ("ocaml", _);
184
+
Loc.Path.Nth (0, _); Loc.Path.Mem ("libs", _); Loc.Path.Mem ("ocaml", _);
197
185
] ->
198
186
()
199
187
| _ -> Alcotest.fail "unexpected parsed path")
···
214
202
215
203
let meta_of_sample = Loc.Meta.make sample
216
204
217
-
let error_make_msg () =
218
-
let e =
219
-
Loc.Error.make_msg Loc.Error.Context.empty meta_of_sample "boom"
220
-
in
205
+
let error_msg () =
206
+
let e = Loc.Error.msg Loc.Error.Context.empty meta_of_sample "boom" in
221
207
let s = Loc.Error.to_string e in
222
208
Alcotest.(check bool) "contains msg" true (contains_substring "boom" s);
223
209
Alcotest.(check bool) "contains file" true (contains_substring "foo.ml" s)
224
210
225
211
let error_msg_raises () =
226
212
try
227
-
let _ : int = Loc.Error.msg meta_of_sample "bad" in
213
+
let _ : int = Loc.Error.fail meta_of_sample "bad" in
228
214
Alcotest.fail "expected Error"
229
215
with Loc.Error (ctx, _, k) ->
230
216
Alcotest.(check bool) "ctx empty" true (Loc.Error.Context.is_empty ctx);
···
244
230
(contains_substring "found string" s)
245
231
246
232
let error_push_context () =
247
-
let e =
248
-
Loc.Error.make_msg Loc.Error.Context.empty meta_of_sample "bad"
249
-
in
233
+
let e = Loc.Error.msg Loc.Error.Context.empty meta_of_sample "bad" in
250
234
let kinded = ("array", Loc.Meta.none) in
251
235
let n = (3, Loc.Meta.none) in
252
236
try
253
237
let _ : int = Loc.Error.push_array kinded n e in
254
238
Alcotest.fail "expected Error"
255
239
with Loc.Error (ctx, _, _) ->
256
-
Alcotest.(check bool)
257
-
"ctx non-empty" false
258
-
(Loc.Error.Context.is_empty ctx);
240
+
Alcotest.(check bool) "ctx non-empty" false (Loc.Error.Context.is_empty ctx);
259
241
Alcotest.(check int) "one layer" 1 (List.length ctx)
260
242
261
243
let error_pp_mentions_path () =
262
244
let kinded = ("array", Loc.Meta.none) in
263
245
let n = (3, Loc.Meta.none) in
264
-
let ctx =
265
-
Loc.Error.Context.push_array kinded n Loc.Error.Context.empty
266
-
in
267
-
let e = Loc.Error.make_msg ctx meta_of_sample "bad" in
246
+
let ctx = Loc.Error.Context.push_array kinded n Loc.Error.Context.empty in
247
+
let e = Loc.Error.msg ctx meta_of_sample "bad" in
268
248
let s = Loc.Error.to_string e in
269
249
Alcotest.(check bool) "msg in output" true (contains_substring "bad" s);
270
250
Alcotest.(check bool) "index in output" true (contains_substring "index 3" s);
271
251
Alcotest.(check bool) "kind in output" true (contains_substring "array" s)
272
252
253
+
(* Extensible kind: a codec library defines its own typed kind and registers
254
+
a printer. The kind is pattern-matchable by consumers. *)
255
+
type Loc.Error.kind += Demo_sort_mismatch of { exp : string; fnd : string }
256
+
257
+
let () =
258
+
Loc.Error.register_kind_printer (function
259
+
| Demo_sort_mismatch { exp; fnd } ->
260
+
Some (fun ppf -> Format.fprintf ppf "expected %s, got %s" exp fnd)
261
+
| _ -> None)
262
+
263
+
let error_kind_extension () =
264
+
let k = Demo_sort_mismatch { exp = "integer"; fnd = "string" } in
265
+
Alcotest.(check string)
266
+
"registered printer runs" "expected integer, got string"
267
+
(Loc.Error.kind_to_string k);
268
+
let e = Loc.Error.v Loc.Error.Context.empty meta_of_sample k in
269
+
Alcotest.(check bool)
270
+
"pattern-matches through Error.t" true
271
+
(match e with
272
+
| _, _, Demo_sort_mismatch { exp = "integer"; _ } -> true
273
+
| _ -> false);
274
+
Alcotest.(check string)
275
+
"Msg fallback still works" "plain text"
276
+
(Loc.Error.kind_to_string (Loc.Error.Msg "plain text"))
277
+
273
278
let suite =
274
279
( "loc",
275
280
[
···
297
302
path_of_string_roundtrip;
298
303
Alcotest.test_case "Path.pp" `Quick path_pp;
299
304
Alcotest.test_case "Path.of_string error" `Quick path_of_string_err;
300
-
Alcotest.test_case "Error.make_msg / to_string" `Quick error_make_msg;
305
+
Alcotest.test_case "Error.msg / to_string" `Quick error_msg;
301
306
Alcotest.test_case "Error.msg raises" `Quick error_msg_raises;
302
307
Alcotest.test_case "Error.expected raises" `Quick error_expected_raises;
303
308
Alcotest.test_case "Error.push_array" `Quick error_push_context;
304
309
Alcotest.test_case "Error.pp mentions path" `Quick error_pp_mentions_path;
310
+
Alcotest.test_case "Error.kind extension + printer" `Quick
311
+
error_kind_extension;
305
312
] )