Source locations and structured errors for text codecs (extracted from jsont)
textloc -> loc: rename package, drop Sort_kind, use dune re_export
Rename the shared location/error-infrastructure package to 'loc' (module
Loc), dropping the awkward 'textloc' / 'Textloc' naming. Consumers now
write [Sexpt.Meta], [Sexpt.Error], [Loc.t], etc.
- ocaml-textloc -> ocaml-loc (directory, opam, module).
- Dropped the single-function Sort_kind module; parsers inline the
one-liner at their local Sort.kinded definitions.
- Parser dunes use [(re_export loc)] so downstream consumers don't need
to declare loc in their own dune or opam.
- monopam lint: new [collect_exports] walks META [exports] fields
(dune's re_export metadata) and expands each opam package's
effective dep set with everything its declared deps re-export.
[Fl_split.in_words] replaces the ad-hoc whitespace splitter.
- merlint: drop 'loc' from its dune-project depends -- reaches via
sexpt re_export.
- Consumers (cdm, s3, test files) updated to [Loc.*] naming.
All 360 tests pass (26 loc + 177 xmlt + 60 csvt + 77 sexpt + 20
dune-codec).
+1177
+15
LICENSE.md
+15
LICENSE.md
···
1
+
ISC License
2
+
3
+
Copyright (c) 2024 The jsont programmers
4
+
5
+
Permission to use, copy, modify, and distribute this software for any
6
+
purpose with or without fee is hereby granted, provided that the above
7
+
copyright notice and this permission notice appear in all copies.
8
+
9
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+82
README.md
+82
README.md
···
1
+
# loc
2
+
3
+
Source-location and structured-error infrastructure for text-based
4
+
codecs, extracted from Daniel Bünzli's
5
+
[jsont](https://erratique.ch/software/jsont). Packaging the shared
6
+
base as a standalone library lets non-JSON text codecs (`xmlt`,
7
+
`csvt`, `sexpt`, ...) reuse it without pulling in `jsont`.
8
+
9
+
A direct copy of `jsont_base.ml` and the `Error` module of `jsont.ml`,
10
+
with JSON-specific pieces (the `Number` module, the JSON `Sort.t`
11
+
enum, JSON-shaped predefined errors) removed; everything else is
12
+
verbatim.
13
+
14
+
Provides:
15
+
16
+
- `Loc` -- byte/line/column ranges for source text
17
+
- `Meta` -- node metadata (location + surrounding whitespace)
18
+
- `Path` -- structural paths (`Mem of string node | Nth of int node`)
19
+
- `Error` -- contextualised errors with a kind, source location, and
20
+
structural path (`Error.t = Context.t * Meta.t * kind`)
21
+
- `exception Error of Error.t` -- single shared exception for
22
+
cross-package error propagation
23
+
24
+
## Installation
25
+
26
+
```
27
+
opam install loc
28
+
```
29
+
30
+
## Usage
31
+
32
+
```ocaml
33
+
(* A library reports an error at a specific source location. *)
34
+
let loc =
35
+
Loc.make ~file:"config.toml"
36
+
~first_byte:42 ~last_byte:47
37
+
~first_line:(3, 0) ~last_line:(3, 0)
38
+
39
+
let meta = Loc.Meta.make loc
40
+
41
+
(* Raise a structured error; library code can catch and inspect it,
42
+
or format it for display. *)
43
+
let () =
44
+
try
45
+
Loc.Error.msgf meta "expected %s, got %s" "integer" "\"nope\""
46
+
with Loc.Error e ->
47
+
print_endline (Loc.Error.to_string e)
48
+
(* File "config.toml", line 3, characters 42-48:
49
+
expected integer, got "nope" *)
50
+
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
54
+
try
55
+
try
56
+
Loc.Error.msg Loc.Meta.none "not a number"
57
+
with Loc.Error e ->
58
+
Loc.Error.push_object root_kind ("port", Loc.Meta.none) e
59
+
with Loc.Error e ->
60
+
let ctx, _, _ = e in
61
+
List.length ctx
62
+
(* 1 -- the port/server frame *)
63
+
```
64
+
65
+
## API
66
+
67
+
Full signatures in [`loc.mli`](lib/loc.mli).
68
+
69
+
## Upstream
70
+
71
+
- [jsont](https://erratique.ch/software/jsont) -- Daniel Bünzli's
72
+
JSON codec library, of which this package is an extracted subset
73
+
- [jsont_base.ml](https://github.com/dbuenzli/jsont/blob/main/src/jsont_base.ml)
74
+
-- the source `Loc`, `Meta`, `Path`, and the `Fmt` helper are
75
+
copied from
76
+
- [jsont.ml](https://github.com/dbuenzli/jsont/blob/main/src/jsont.ml)
77
+
-- the source the `Error` module is copied from (minus JSON-specific
78
+
predefined errors)
79
+
80
+
## License
81
+
82
+
ISC, matching upstream. See [LICENSE.md](LICENSE.md).
+30
dune-project
+30
dune-project
···
1
+
(lang dune 3.21)
2
+
3
+
(name loc)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(source (tangled gazagnaire.org/ocaml-loc))
8
+
(license ISC)
9
+
(authors "Daniel Bünzli")
10
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
11
+
12
+
(package
13
+
(name loc)
14
+
(synopsis
15
+
"Source locations and structured errors for text codecs (extracted from jsont)")
16
+
(tags (org:blacksun parser text))
17
+
(description
18
+
"A direct copy of the Loc / Meta / Path / Error modules from
19
+
Daniel Bünzli's jsont (jsont_base.ml and jsont.ml), packaged as a
20
+
standalone library so non-JSON text codecs -- XML, CSV,
21
+
S-expression, YAML, etc. -- can report error positions uniformly
22
+
without depending on jsont. JSON-specific pieces (Number, the JSON
23
+
Sort.t enum, JSON-shaped predefined errors) are omitted;
24
+
everything else is verbatim.")
25
+
(depends
26
+
(ocaml (>= 4.14))
27
+
(dune (>= 3.21))
28
+
fmt
29
+
(alcotest :with-test)
30
+
(odoc :with-doc)))
+360
lib/loc.ml
+360
lib/loc.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
5
+
Extracted from jsont (jsont.ml / jsont_base.ml) with JSON-specific
6
+
pieces removed.
7
+
---------------------------------------------------------------------------*)
8
+
9
+
(* Bold-styled code formatter, matching jsont's Fmt.code.
10
+
Styling respects the formatter's renderer (opam fmt): on ppf with
11
+
[Fmt.set_style_renderer ppf `Ansi_tty] the output is bold ANSI, on
12
+
a default formatter (including asprintf / str_formatter) it is
13
+
plain. *)
14
+
let pp_code = Fmt.styled `Bold Fmt.string
15
+
16
+
(* File paths *)
17
+
18
+
type fpath = string
19
+
20
+
let file_none = "-"
21
+
let pp_path = Format.pp_print_string
22
+
23
+
(* Byte positions *)
24
+
25
+
type byte_pos = int
26
+
27
+
let byte_pos_none = -1
28
+
29
+
(* Lines *)
30
+
31
+
type line_num = int
32
+
33
+
let line_num_none = -1
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)
46
+
47
+
(* Text locations *)
48
+
49
+
type t = {
50
+
file : fpath;
51
+
first_byte : byte_pos;
52
+
last_byte : byte_pos;
53
+
first_line : line_pos;
54
+
last_line : line_pos;
55
+
}
56
+
57
+
let make ~file ~first_byte ~last_byte ~first_line ~last_line =
58
+
{ file; first_byte; last_byte; first_line; last_line }
59
+
60
+
let file l = l.file
61
+
let set_file l file = { l with file }
62
+
let first_byte l = l.first_byte
63
+
let last_byte l = l.last_byte
64
+
let first_line l = l.first_line
65
+
let last_line l = l.last_line
66
+
67
+
let none =
68
+
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
70
+
71
+
(* Predicates and comparisons *)
72
+
73
+
let is_none l = l.first_byte < 0
74
+
let is_empty l = l.first_byte > l.last_byte
75
+
76
+
let equal l0 l1 =
77
+
String.equal l0.file l1.file
78
+
&& Int.equal l0.first_byte l1.first_byte
79
+
&& Int.equal l0.last_byte l1.last_byte
80
+
81
+
let compare l0 l1 =
82
+
let c = String.compare l0.file l1.file in
83
+
if c <> 0 then c
84
+
else
85
+
let c = Int.compare l0.first_byte l1.first_byte in
86
+
if c <> 0 then c else Int.compare l0.last_byte l1.last_byte
87
+
88
+
(* Shrink and stretch *)
89
+
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 }
92
+
93
+
let to_first l =
94
+
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
96
+
97
+
let to_last l =
98
+
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
100
+
101
+
let before l =
102
+
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
104
+
105
+
let after l =
106
+
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
108
+
109
+
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)
113
+
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)
117
+
in
118
+
make ~file ~first_byte ~first_line ~last_byte ~last_line
119
+
120
+
let reloc ~first ~last =
121
+
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
123
+
124
+
(* Formatters *)
125
+
126
+
let pf = Format.fprintf
127
+
128
+
let pp_ocaml ppf l =
129
+
if is_none l then pf ppf "File \"%a\"" pp_path l.file
130
+
else
131
+
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)
135
+
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
138
+
if pos_s = 0 && pos_e = 0 then
139
+
pf ppf "File \"%a\", %a" pp_path l.file pp_lines l
140
+
else
141
+
pf ppf "File \"%a\", %a, characters %d-%d" pp_path l.file pp_lines l pos_s
142
+
pos_e
143
+
144
+
let pp_gnu ppf l =
145
+
if is_none l then pf ppf "%a:" pp_path l.file
146
+
else
147
+
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
153
+
in
154
+
pf ppf "%a:%a" pp_path l.file pp_lines l
155
+
156
+
let pp = pp_ocaml
157
+
158
+
let pp_dump ppf l =
159
+
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)
162
+
163
+
(* Local helper: String.sub by byte range, tolerant of out-of-bounds. *)
164
+
165
+
let string_subrange ?(first = 0) ?last s =
166
+
let max = String.length s - 1 in
167
+
let last =
168
+
match last with None -> max | Some l when l > max -> max | Some l -> l
169
+
in
170
+
let first = if first < 0 then 0 else first in
171
+
if first > last then "" else String.sub s first (last - first + 1)
172
+
173
+
(* Node metadata *)
174
+
175
+
module Meta = struct
176
+
type textloc = t
177
+
type t = { textloc : textloc; ws_before : string; ws_after : string }
178
+
179
+
let make ?(ws_before = "") ?(ws_after = "") textloc =
180
+
{ textloc; ws_before; ws_after }
181
+
182
+
let none = { textloc = none; ws_before = ""; ws_after = "" }
183
+
let is_none m = none == m
184
+
let textloc m = m.textloc
185
+
let ws_before m = m.ws_before
186
+
let ws_after m = m.ws_after
187
+
let with_textloc m textloc = { m with textloc }
188
+
let clear_ws m = { m with ws_before = ""; ws_after = "" }
189
+
let clear_textloc m = { m with textloc = none.textloc }
190
+
191
+
let copy_ws src ~dst =
192
+
{ dst with ws_before = src.ws_before; ws_after = src.ws_after }
193
+
end
194
+
195
+
type 'a node = 'a * Meta.t
196
+
197
+
(* Structural paths *)
198
+
199
+
module Path = struct
200
+
type index = Mem of string node | Nth of int node
201
+
202
+
let pp_name = pp_code
203
+
let pp_index_num ppf n = pp_code ppf (Int.to_string n)
204
+
205
+
let pp_index ppf = function
206
+
| Mem (n, _) -> pp_name ppf n
207
+
| Nth (n, _) -> Fmt.pf ppf "[%a]" pp_index_num n
208
+
209
+
let pp_index_trace ppf = function
210
+
| Mem (n, meta) ->
211
+
Fmt.pf ppf "%a: in member %a" pp (Meta.textloc meta) pp_name n
212
+
| Nth (n, meta) ->
213
+
Fmt.pf ppf "%a: at index %a" pp (Meta.textloc meta) pp_index_num n
214
+
215
+
type t = index list
216
+
217
+
let root = []
218
+
let is_root = function [] -> true | _ -> false
219
+
let nth ?(meta = Meta.none) n p = Nth (n, meta) :: p
220
+
let mem ?(meta = Meta.none) n p = Mem (n, meta) :: p
221
+
let rev_indices p = p
222
+
223
+
let pp ppf is =
224
+
let pp_sep ppf () = Fmt.char ppf '.' in
225
+
Fmt.list ~sep:pp_sep pp_index ppf (List.rev is)
226
+
227
+
let pp_trace ppf is =
228
+
if is <> [] then Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_index_trace) is
229
+
230
+
(* Parsing *)
231
+
232
+
let err i fmt = Format.kasprintf failwith ("%d: " ^^ fmt) i
233
+
let err_unexp_eoi i = err i "Unexpected end of input"
234
+
let err_unexp_char i s = err i "Unexpected character: %C" s.[i]
235
+
let err_illegal_char i s = err i "Illegal character here: %C" s.[i]
236
+
let err_unexp i s = err i "Unexpected input: %S" (string_subrange ~first:i s)
237
+
238
+
let parse_index p s i max =
239
+
let first, stop = match s.[i] with '[' -> (i + 1, ']') | _ -> (i, '.') in
240
+
let last, next =
241
+
let rec loop stop s i max =
242
+
match i > max with
243
+
| true -> if stop = ']' then err_unexp_eoi i else (i - 1, i)
244
+
| false ->
245
+
let illegal = s.[i] = '[' || (s.[i] = ']' && stop = '.') in
246
+
if illegal then err_illegal_char i s
247
+
else if s.[i] <> stop then loop stop s (i + 1) max
248
+
else (i - 1, if stop = ']' then i + 1 else i)
249
+
in
250
+
loop stop s first max
251
+
in
252
+
let idx = string_subrange ~first ~last s in
253
+
if idx = "" then err first "illegal empty index"
254
+
else
255
+
match int_of_string idx with
256
+
| exception Failure _ -> (next, Mem (idx, Meta.none) :: p)
257
+
| idx -> (next, Nth (idx, Meta.none) :: p)
258
+
259
+
let of_string s =
260
+
let rec loop p s i max =
261
+
if i > max then p
262
+
else
263
+
let next, p = parse_index p s i max in
264
+
if next > max then p
265
+
else if s.[next] <> '.' then err_unexp_char next s
266
+
else if next + 1 <= max then loop p s (next + 1) max
267
+
else err_unexp_eoi next
268
+
in
269
+
try
270
+
if s = "" then Ok []
271
+
else
272
+
let start = if s.[0] = '.' then 1 else 0 in
273
+
Ok (loop [] s start (String.length s - 1))
274
+
with Failure e -> Error e
275
+
end
276
+
277
+
(* Errors *)
278
+
279
+
type error_kind = string
280
+
type context_index = string node * Path.index
281
+
type context = context_index list
282
+
type error = context * Meta.t * error_kind
283
+
284
+
exception Error of error
285
+
286
+
module Error = struct
287
+
type kind = error_kind
288
+
type t = error
289
+
290
+
let kind_to_string k = k
291
+
let pp_kind = pp_code
292
+
let pp_name = pp_code
293
+
let pp_int ppf i = pp_code ppf (Int.to_string i)
294
+
295
+
module Context = struct
296
+
type index = context_index
297
+
type t = context
298
+
299
+
let empty = []
300
+
let is_empty ctx = ctx = []
301
+
let push_array kinded_sort n ctx = (kinded_sort, Path.Nth n) :: ctx
302
+
let push_object kinded_sort n ctx = (kinded_sort, Path.Mem n) :: ctx
303
+
304
+
let pp ppf ctx =
305
+
let pp_meta ppf meta =
306
+
if Meta.is_none meta then ()
307
+
else Fmt.pf ppf "%a: " pp (Meta.textloc meta)
308
+
in
309
+
let pp_el ppf (kind, index) =
310
+
match index with
311
+
| Path.Nth (n, meta) ->
312
+
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)
314
+
| Path.Mem (name, meta) ->
315
+
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)
317
+
in
318
+
if ctx = [] then ()
319
+
else Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_el) (List.rev ctx)
320
+
end
321
+
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
326
+
327
+
let push_array kinded_sort n (ctx, meta, e) =
328
+
raise_notrace (Error (Context.push_array kinded_sort n ctx, meta, e))
329
+
330
+
let push_object kinded_sort n (ctx, meta, e) =
331
+
raise_notrace (Error (Context.push_object kinded_sort n ctx, meta, e))
332
+
333
+
let adjust_context ~first_byte ~first_line (ctx, meta, e) =
334
+
match ctx with
335
+
| [] -> raise_notrace (Error (ctx, meta, e))
336
+
| ((sort, smeta), idx) :: is ->
337
+
let textloc = Meta.textloc smeta in
338
+
let textloc =
339
+
if is_none textloc then textloc
340
+
else set_first textloc ~first_byte ~first_line
341
+
in
342
+
let smeta = Meta.with_textloc smeta textloc in
343
+
let ctx = ((sort, smeta), idx) :: is in
344
+
raise_notrace (Error (ctx, meta, e))
345
+
346
+
let pp ppf (ctx, m, msg) =
347
+
let pp_meta ppf m =
348
+
if not (Meta.is_none m) then Fmt.pf ppf "@,%a:" pp (Meta.textloc m)
349
+
in
350
+
Fmt.pf ppf "@[<v>%a%a%a@]" Fmt.lines msg pp_meta m Context.pp ctx
351
+
352
+
let to_string e = Format.asprintf "%a" pp e
353
+
354
+
let puterr ppf () =
355
+
Fmt.styled (`Fg `Red) (Fmt.styled `Bold Fmt.string) ppf "Error";
356
+
Fmt.char ppf ':'
357
+
358
+
let expected meta exp ~fnd =
359
+
msgf meta "Expected %a but found %a" pp_code exp pp_code fnd
360
+
end
+330
lib/loc.mli
+330
lib/loc.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
5
+
Extracted from jsont (jsont.mli / jsont_base.mli) with JSON-specific
6
+
pieces removed.
7
+
---------------------------------------------------------------------------*)
8
+
9
+
(** Text locations: byte ranges and line positions.
10
+
11
+
A location identifies a span within a UTF-8 encoded file by an inclusive
12
+
range of absolute byte positions and the line positions on which they occur.
13
+
Designed for parser error reporting; the representation is compatible with
14
+
the OCaml compiler's format and the GNU error convention. *)
15
+
16
+
(** {1:fpath File paths} *)
17
+
18
+
type fpath = string
19
+
(** The type for file paths. *)
20
+
21
+
val file_none : fpath
22
+
(** [file_none] is ["-"]. A file path to use when there is none. *)
23
+
24
+
(** {1:pos Positions} *)
25
+
26
+
(** {2:byte_pos Byte positions} *)
27
+
28
+
type byte_pos = int
29
+
(** The type for zero-based, absolute byte positions in text. If the text has
30
+
[n] bytes, [0] is the first position and [n-1] is the last position. *)
31
+
32
+
val byte_pos_none : byte_pos
33
+
(** [byte_pos_none] is [-1]. A position to use when there is none. *)
34
+
35
+
(** {2:lines Lines} *)
36
+
37
+
type line_num = int
38
+
(** The type for one-based line numbers. Lines increment after a newline which
39
+
is either a line feed ['\n'] (U+000A), a carriage return ['\r'] (U+000D), or
40
+
a carriage return followed by a line feed ["\r\n"] (<U+000D,U+000A>). *)
41
+
42
+
val line_num_none : line_num
43
+
(** [line_num_none] is [-1]. A line number to use when there is none. *)
44
+
45
+
(** {2:line_pos Line positions} *)
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:
51
+
- indexes the first byte of the line if it is non-empty;
52
+
- indexes the first byte of the next newline sequence if the line is empty;
53
+
- is out of bounds and equal to the text's length for a last empty line
54
+
(also the case on empty text). *)
55
+
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
+
(** {1:tloc Text locations} *)
64
+
65
+
type t
66
+
(** The type for text locations. If the first byte equals the last byte the
67
+
range contains exactly that byte. If the first byte is greater than the last
68
+
byte the location represents an insertion point before the first byte; in
69
+
that case last-position information should be ignored. *)
70
+
71
+
val none : t
72
+
(** [none] is a location to use when there is none. *)
73
+
74
+
val make :
75
+
file:fpath ->
76
+
first_byte:byte_pos ->
77
+
last_byte:byte_pos ->
78
+
first_line:line_pos ->
79
+
last_line:line_pos ->
80
+
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
+
*)
84
+
85
+
val file : t -> fpath
86
+
val set_file : t -> fpath -> t
87
+
val first_byte : t -> byte_pos
88
+
val last_byte : t -> byte_pos
89
+
val first_line : t -> line_pos
90
+
val last_line : t -> line_pos
91
+
92
+
(** {2:preds Predicates and comparisons} *)
93
+
94
+
val is_none : t -> bool
95
+
(** [is_none t] is [true] iff [first_byte t < 0]. *)
96
+
97
+
val is_empty : t -> bool
98
+
(** [is_empty t] is [true] iff [first_byte t > last_byte t]. *)
99
+
100
+
val equal : t -> t -> bool
101
+
(** [equal t0 t1] is [true] iff [file], [first_byte], and [last_byte] are equal.
102
+
Line information is ignored. *)
103
+
104
+
val compare : t -> t -> int
105
+
(** [compare] orders locations by [(file, first_byte, last_byte)], compatible
106
+
with {!equal}. *)
107
+
108
+
(** {2:shrink_and_stretch Shrink and stretch} *)
109
+
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
112
+
113
+
val to_first : t -> t
114
+
(** [to_first l] has both positions set to [l]'s first position. *)
115
+
116
+
val to_last : t -> t
117
+
(** [to_last l] has both positions set to [l]'s last position. *)
118
+
119
+
val before : t -> t
120
+
(** [before l] is the empty location at [first_byte]. *)
121
+
122
+
val after : t -> t
123
+
(** [after l] is the empty location at [last_byte + 1]. *)
124
+
125
+
val span : t -> t -> t
126
+
(** [span l0 l1] covers from the smallest first byte of either to the largest
127
+
last byte of either. File is taken from the location with the greater last
128
+
byte. *)
129
+
130
+
val reloc : first:t -> last:t -> t
131
+
(** [reloc ~first ~last] uses [first]'s first position, [last]'s last position,
132
+
and [last]'s file. *)
133
+
134
+
(** {2:fmt Formatting} *)
135
+
136
+
val pp_ocaml : Format.formatter -> t -> unit
137
+
(** Formats locations like the OCaml compiler:
138
+
[File "f.ml", line 3, characters 10-15]. *)
139
+
140
+
val pp_gnu : Format.formatter -> t -> unit
141
+
(** Formats locations per the
142
+
{{:https://www.gnu.org/prep/standards/standards.html#Errors} GNU convention}:
143
+
[f.ml:3.10-15]. *)
144
+
145
+
val pp : Format.formatter -> t -> unit
146
+
(** [pp] is {!pp_ocaml}. *)
147
+
148
+
val pp_dump : Format.formatter -> t -> unit
149
+
(** Raw data dump, for debugging. *)
150
+
151
+
(** {1:meta Metadata, paths and errors} *)
152
+
153
+
(** Abstract syntax tree node metadata.
154
+
155
+
Keeps source text locations and surrounding whitespace. *)
156
+
module Meta : sig
157
+
type loc := t
158
+
159
+
type t
160
+
(** The type for node metadata. *)
161
+
162
+
val make : ?ws_before:string -> ?ws_after:string -> loc -> t
163
+
(** [make ~ws_before ~ws_after loc] is metadata with source location [loc] and
164
+
the given surrounding whitespace (default empty). *)
165
+
166
+
val none : t
167
+
(** [none] is metadata with no location and no whitespace. *)
168
+
169
+
val is_none : t -> bool
170
+
(** [is_none m] is [true] iff [m] is {!none} (physical equality). *)
171
+
172
+
val textloc : t -> loc
173
+
(** [textloc m] is the source location of [m]. *)
174
+
175
+
val ws_before : t -> string
176
+
(** [ws_before m] is the whitespace preceding the node. *)
177
+
178
+
val ws_after : t -> string
179
+
(** [ws_after m] is the whitespace following the node. *)
180
+
181
+
val with_textloc : t -> loc -> t
182
+
(** [with_textloc m loc] is [m] with source location set to [loc]. *)
183
+
184
+
val clear_ws : t -> t
185
+
(** [clear_ws m] is [m] with both whitespace fields cleared. *)
186
+
187
+
val clear_textloc : t -> t
188
+
(** [clear_textloc m] is [m] with its source location set to {!none}. *)
189
+
190
+
val copy_ws : t -> dst:t -> t
191
+
(** [copy_ws src ~dst] is [dst] with its whitespace fields copied from [src].
192
+
*)
193
+
end
194
+
195
+
type 'a node = 'a * Meta.t
196
+
(** Abstract syntax tree node: data plus its metadata. *)
197
+
198
+
(** Structural paths into JSON-like data.
199
+
200
+
A path is a sequence of indexing operations: object members and array
201
+
indices. Used to build {!Error.Context.t} and to address sub-values for
202
+
queries and updates. *)
203
+
module Path : sig
204
+
type index =
205
+
| Mem of string node (** Index a value by member name. *)
206
+
| Nth of int node (** Index a value by zero-based array index. *)
207
+
208
+
val pp_index : Format.formatter -> index -> unit
209
+
(** [pp_index] formats an index without source location. *)
210
+
211
+
val pp_index_trace : Format.formatter -> index -> unit
212
+
(** [pp_index_trace] formats an index with its source location. *)
213
+
214
+
type t
215
+
(** The type for paths. *)
216
+
217
+
val root : t
218
+
(** [root] is the empty path. *)
219
+
220
+
val is_root : t -> bool
221
+
(** [is_root p] is [true] iff [p] is {!root}. *)
222
+
223
+
val nth : ?meta:Meta.t -> int -> t -> t
224
+
(** [nth ~meta n p] extends [p] by indexing an array at [n]. *)
225
+
226
+
val mem : ?meta:Meta.t -> string -> t -> t
227
+
(** [mem ~meta n p] extends [p] by indexing an object at member [n]. *)
228
+
229
+
val rev_indices : t -> index list
230
+
(** [rev_indices p] is the path's indices with the deepest one first. *)
231
+
232
+
val of_string : string -> (t, string) result
233
+
(** [of_string s] parses a dot-separated path like ["a.b.[2].c"]. *)
234
+
235
+
val pp : Format.formatter -> t -> unit
236
+
(** [pp] formats paths as dot-separated indices. *)
237
+
238
+
val pp_trace : Format.formatter -> t -> unit
239
+
(** [pp_trace] formats paths as a vertical trace with locations. *)
240
+
end
241
+
242
+
(** Encoding, decoding, and query errors.
243
+
244
+
Errors carry a structured context (the path from the root value to the
245
+
erroring sub-value), the source location of the error, and a kind. *)
246
+
module Error : sig
247
+
type loc := t
248
+
249
+
type kind
250
+
(** The type of error kinds. Currently opaque (a tagged string). *)
251
+
252
+
val kind_to_string : kind -> string
253
+
(** [kind_to_string k] is the underlying message string of [k]. *)
254
+
255
+
module Context : sig
256
+
type index = string node * Path.index
257
+
(** A context index: the kinded-sort label of the parent container, plus the
258
+
path index to the sub-value within it. *)
259
+
260
+
type t = index list
261
+
(** A context: the chain of indexings from the root value down to the
262
+
erroring sub-value. The first list element indexes the root. *)
263
+
264
+
val empty : t
265
+
(** [empty] is the empty context. *)
266
+
267
+
val is_empty : t -> bool
268
+
(** [is_empty ctx] is [true] iff [ctx] is {!empty}. *)
269
+
270
+
val push_array : string node -> int node -> t -> t
271
+
(** [push_array kinded_sort n ctx] wraps [ctx] as the [n]th element of an
272
+
array of kinded sort [kinded_sort]. *)
273
+
274
+
val push_object : string node -> string node -> t -> t
275
+
(** [push_object kinded_sort n ctx] wraps [ctx] as the member named [n] of
276
+
an object of kinded sort [kinded_sort]. *)
277
+
278
+
val pp : Format.formatter -> t -> unit
279
+
(** [pp] formats a context as an indented trace. *)
280
+
end
281
+
282
+
type t = Context.t * Meta.t * kind
283
+
(** An error: a context, the error's source location and whitespace meta, and
284
+
the error kind (tag + message). *)
285
+
286
+
val raise : Context.t -> Meta.t -> kind -> 'a
287
+
(** [raise ctx meta kind] raises the {!Error} exception. *)
288
+
289
+
val make_msg : Context.t -> Meta.t -> string -> t
290
+
(** [make_msg ctx meta msg] constructs an error value. *)
291
+
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]. *)
297
+
298
+
val expected : Meta.t -> string -> fnd:string -> 'a
299
+
(** [expected meta exp ~fnd] raises an ["Expected exp but found fnd"] error.
300
+
*)
301
+
302
+
val push_array : string node -> int node -> t -> 'a
303
+
(** [push_array kinded_sort n e] re-raises [e] after pushing an array index
304
+
onto its context. *)
305
+
306
+
val push_object : string node -> string node -> t -> 'a
307
+
(** [push_object kinded_sort n e] re-raises [e] after pushing an object member
308
+
onto its context. *)
309
+
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. *)
313
+
314
+
val to_string : t -> string
315
+
(** [to_string e] is the error formatted as a string. *)
316
+
317
+
val pp : Format.formatter -> t -> unit
318
+
(** [pp] formats errors with message, location, and context. *)
319
+
320
+
val puterr : Format.formatter -> unit -> unit
321
+
(** [puterr ppf ()] prints ["Error:"] in bold red.
322
+
323
+
Styling is effective only on formatters configured for ANSI output via
324
+
{!Fmt.set_style_renderer} (e.g. {!Fmt.pr} / {!Fmt.pp_stderr}). Plain
325
+
formatters (including {!Format.asprintf} and {!Format.str_formatter}) emit
326
+
the text without escapes -- so {!to_string} is always plain. *)
327
+
end
328
+
329
+
exception Error of Error.t
330
+
(** Raised by codec mappers and decoders to abort with a structured error. *)
+43
loc.opam
+43
loc.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis:
4
+
"Source locations and structured errors for text codecs (extracted from jsont)"
5
+
description: """
6
+
A direct copy of the Loc / Meta / Path / Error modules from
7
+
Daniel Bünzli's jsont (jsont_base.ml and jsont.ml), packaged as a
8
+
standalone library so non-JSON text codecs -- XML, CSV,
9
+
S-expression, YAML, etc. -- can report error positions uniformly
10
+
without depending on jsont. JSON-specific pieces (Number, the JSON
11
+
Sort.t enum, JSON-shaped predefined errors) are omitted;
12
+
everything else is verbatim."""
13
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
14
+
authors: ["Daniel Bünzli"]
15
+
license: "ISC"
16
+
tags: ["org:blacksun" "parser" "text"]
17
+
homepage: "https://tangled.org/gazagnaire.org/ocaml-loc"
18
+
bug-reports: "https://tangled.org/gazagnaire.org/ocaml-loc/issues"
19
+
depends: [
20
+
"ocaml" {>= "4.14"}
21
+
"dune" {>= "3.21" & >= "3.21"}
22
+
"fmt"
23
+
"alcotest" {with-test}
24
+
"odoc" {with-doc}
25
+
]
26
+
build: [
27
+
["dune" "subst"] {dev}
28
+
[
29
+
"dune"
30
+
"build"
31
+
"-p"
32
+
name
33
+
"-j"
34
+
jobs
35
+
"@install"
36
+
"@runtest" {with-test}
37
+
"@doc" {with-doc}
38
+
]
39
+
]
40
+
dev-repo: "git+https://tangled.org/gazagnaire.org/ocaml-loc"
41
+
x-maintenance-intent: ["(latest)"]
42
+
x-quality-build: "2026-04-16"
43
+
x-quality-test: "2026-04-16"
+1
test/test.ml
+1
test/test.ml
···
1
+
let () = Alcotest.run "loc" [ Test_loc.suite ]
+305
test/test_loc.ml
+305
test/test_loc.ml
···
1
+
let contains_substring needle haystack =
2
+
let nlen = String.length needle in
3
+
let hlen = String.length haystack in
4
+
if nlen = 0 then true
5
+
else if nlen > hlen then false
6
+
else
7
+
let limit = hlen - nlen in
8
+
let rec loop i =
9
+
if i > limit then false
10
+
else if String.sub haystack i nlen = needle then true
11
+
else loop (i + 1)
12
+
in
13
+
loop 0
14
+
15
+
let sample =
16
+
Loc.make ~file:"foo.ml" ~first_byte:10 ~last_byte:14 ~first_line:(2, 5)
17
+
~last_line:(2, 5)
18
+
19
+
(* ── Constructors and accessors ──────────────────────────── *)
20
+
21
+
let make_and_accessors () =
22
+
Alcotest.(check string) "file" "foo.ml" (Loc.file sample);
23
+
Alcotest.(check int) "first_byte" 10 (Loc.first_byte sample);
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)
29
+
30
+
let set_file () =
31
+
let l = Loc.set_file sample "other.ml" in
32
+
Alcotest.(check string) "updated" "other.ml" (Loc.file l)
33
+
34
+
let none_is_none () =
35
+
Alcotest.(check bool) "none.is_none" true (Loc.is_none Loc.none);
36
+
Alcotest.(check bool) "sample.is_none" false (Loc.is_none sample)
37
+
38
+
let empty_detection () =
39
+
let empty =
40
+
Loc.make ~file:"-" ~first_byte:5 ~last_byte:3 ~first_line:(1, 0)
41
+
~last_line:(1, 0)
42
+
in
43
+
Alcotest.(check bool) "empty" true (Loc.is_empty empty);
44
+
Alcotest.(check bool) "sample not empty" false (Loc.is_empty sample)
45
+
46
+
(* ── Equality and comparison ─────────────────────────────── *)
47
+
48
+
let equal_ignores_line_info () =
49
+
let a =
50
+
Loc.make ~file:"f" ~first_byte:3 ~last_byte:7 ~first_line:(1, 0)
51
+
~last_line:(1, 0)
52
+
in
53
+
let b =
54
+
Loc.make ~file:"f" ~first_byte:3 ~last_byte:7 ~first_line:(2, 10)
55
+
~last_line:(3, 20)
56
+
in
57
+
Alcotest.(check bool)
58
+
"equal despite different line info" true (Loc.equal a b)
59
+
60
+
let compare_orders_by_file_then_byte () =
61
+
let a =
62
+
Loc.make ~file:"a" ~first_byte:0 ~last_byte:0 ~first_line:(1, 0)
63
+
~last_line:(1, 0)
64
+
in
65
+
let b =
66
+
Loc.make ~file:"b" ~first_byte:0 ~last_byte:0 ~first_line:(1, 0)
67
+
~last_line:(1, 0)
68
+
in
69
+
Alcotest.(check bool) "a < b (by file)" true (Loc.compare a b < 0);
70
+
let b2 =
71
+
Loc.make ~file:"a" ~first_byte:5 ~last_byte:10 ~first_line:(1, 0)
72
+
~last_line:(1, 0)
73
+
in
74
+
Alcotest.(check bool) "a < b2 (by first_byte)" true (Loc.compare a b2 < 0)
75
+
76
+
(* ── Shrink and stretch ─────────────────────────────────── *)
77
+
78
+
let to_first_and_to_last () =
79
+
let l =
80
+
Loc.make ~file:"-" ~first_byte:5 ~last_byte:10 ~first_line:(2, 2)
81
+
~last_line:(3, 8)
82
+
in
83
+
let fst = Loc.to_first l in
84
+
Alcotest.(check int) "to_first first_byte" 5 (Loc.first_byte fst);
85
+
Alcotest.(check int) "to_first last_byte" 5 (Loc.last_byte fst);
86
+
let lst = Loc.to_last l in
87
+
Alcotest.(check int) "to_last first_byte" 10 (Loc.first_byte lst);
88
+
Alcotest.(check int) "to_last last_byte" 10 (Loc.last_byte lst)
89
+
90
+
let span_unions_ranges () =
91
+
let a =
92
+
Loc.make ~file:"-" ~first_byte:3 ~last_byte:7 ~first_line:(1, 0)
93
+
~last_line:(1, 0)
94
+
in
95
+
let b =
96
+
Loc.make ~file:"-" ~first_byte:10 ~last_byte:20 ~first_line:(1, 0)
97
+
~last_line:(1, 0)
98
+
in
99
+
let s = Loc.span a b in
100
+
Alcotest.(check int) "span first_byte" 3 (Loc.first_byte s);
101
+
Alcotest.(check int) "span last_byte" 20 (Loc.last_byte s)
102
+
103
+
(* ── Pretty-printing ─────────────────────────────────────── *)
104
+
105
+
let pp_ocaml_single_line () =
106
+
let l =
107
+
Loc.make ~file:"foo.ml" ~first_byte:10 ~last_byte:14 ~first_line:(2, 5)
108
+
~last_line:(2, 5)
109
+
in
110
+
let out = Fmt.str "%a" Loc.pp_ocaml l in
111
+
Alcotest.(check string)
112
+
"ocaml format" "File \"foo.ml\", line 2, characters 5-10" out
113
+
114
+
let pp_gnu_format () =
115
+
let l =
116
+
Loc.make ~file:"foo.ml" ~first_byte:10 ~last_byte:14 ~first_line:(2, 5)
117
+
~last_line:(2, 5)
118
+
in
119
+
let out = Fmt.str "%a" Loc.pp_gnu l in
120
+
Alcotest.(check string) "gnu format" "foo.ml:2.6-10" out
121
+
122
+
let pp_none () =
123
+
let out = Fmt.str "%a" Loc.pp_ocaml Loc.none in
124
+
Alcotest.(check string) "none ocaml" "File \"-\"" out
125
+
126
+
(* -- Meta ------------------------------------------------------ *)
127
+
128
+
let meta_basic () =
129
+
let m = Loc.Meta.make ~ws_before:" " ~ws_after:"\n" sample in
130
+
Alcotest.(check bool) "is_none false" false (Loc.Meta.is_none m);
131
+
Alcotest.(check string) "ws_before" " " (Loc.Meta.ws_before m);
132
+
Alcotest.(check string) "ws_after" "\n" (Loc.Meta.ws_after m);
133
+
Alcotest.(check bool)
134
+
"textloc eq" true
135
+
(Loc.equal sample (Loc.Meta.textloc m))
136
+
137
+
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)
144
+
145
+
let meta_with_textloc () =
146
+
let m = Loc.Meta.make ~ws_before:"a" sample in
147
+
let m' = Loc.Meta.with_textloc m Loc.none in
148
+
Alcotest.(check bool)
149
+
"textloc replaced" true
150
+
(Loc.is_none (Loc.Meta.textloc m'));
151
+
Alcotest.(check string) "ws preserved" "a" (Loc.Meta.ws_before m')
152
+
153
+
let meta_clear () =
154
+
let m = Loc.Meta.make ~ws_before:"a" ~ws_after:"b" sample in
155
+
let m1 = Loc.Meta.clear_ws m in
156
+
Alcotest.(check string) "ws_before cleared" "" (Loc.Meta.ws_before m1);
157
+
Alcotest.(check string) "ws_after cleared" "" (Loc.Meta.ws_after m1);
158
+
let m2 = Loc.Meta.clear_textloc m in
159
+
Alcotest.(check bool)
160
+
"textloc cleared" true
161
+
(Loc.is_none (Loc.Meta.textloc m2))
162
+
163
+
let meta_copy_ws () =
164
+
let src = Loc.Meta.make ~ws_before:"x" ~ws_after:"y" sample in
165
+
let dst = Loc.Meta.make ~ws_before:"a" ~ws_after:"b" sample in
166
+
let out = Loc.Meta.copy_ws src ~dst in
167
+
Alcotest.(check string) "ws_before copied" "x" (Loc.Meta.ws_before out);
168
+
Alcotest.(check string) "ws_after copied" "y" (Loc.Meta.ws_after out)
169
+
170
+
(* -- Path ------------------------------------------------------ *)
171
+
172
+
let path_root () =
173
+
Alcotest.(check bool)
174
+
"root is_root" true
175
+
(Loc.Path.is_root Loc.Path.root)
176
+
177
+
let path_build () =
178
+
let p = Loc.Path.mem "a" Loc.Path.root in
179
+
let p = Loc.Path.mem "b" p in
180
+
let p = Loc.Path.nth 3 p in
181
+
match Loc.Path.rev_indices p with
182
+
| [
183
+
Loc.Path.Nth (3, _); Loc.Path.Mem ("b", _); Loc.Path.Mem ("a", _);
184
+
] ->
185
+
()
186
+
| _ -> Alcotest.fail "unexpected path shape"
187
+
188
+
let path_of_string_roundtrip () =
189
+
match Loc.Path.of_string "ocaml.libs.[0]" with
190
+
| Error e -> Alcotest.failf "parse error: %s" e
191
+
| Ok p -> (
192
+
match Loc.Path.rev_indices p with
193
+
| [
194
+
Loc.Path.Nth (0, _);
195
+
Loc.Path.Mem ("libs", _);
196
+
Loc.Path.Mem ("ocaml", _);
197
+
] ->
198
+
()
199
+
| _ -> Alcotest.fail "unexpected parsed path")
200
+
201
+
let path_pp () =
202
+
let p = Loc.Path.mem "ocaml" Loc.Path.root in
203
+
let p = Loc.Path.mem "libs" p in
204
+
let p = Loc.Path.nth 0 p in
205
+
let out = Fmt.str "%a" Loc.Path.pp p in
206
+
Alcotest.(check string) "pp" "ocaml.libs.[0]" out
207
+
208
+
let path_of_string_err () =
209
+
match Loc.Path.of_string "a.[]" with
210
+
| Ok _ -> Alcotest.fail "expected parse error"
211
+
| Error _ -> ()
212
+
213
+
(* -- Error ----------------------------------------------------- *)
214
+
215
+
let meta_of_sample = Loc.Meta.make sample
216
+
217
+
let error_make_msg () =
218
+
let e =
219
+
Loc.Error.make_msg Loc.Error.Context.empty meta_of_sample "boom"
220
+
in
221
+
let s = Loc.Error.to_string e in
222
+
Alcotest.(check bool) "contains msg" true (contains_substring "boom" s);
223
+
Alcotest.(check bool) "contains file" true (contains_substring "foo.ml" s)
224
+
225
+
let error_msg_raises () =
226
+
try
227
+
let _ : int = Loc.Error.msg meta_of_sample "bad" in
228
+
Alcotest.fail "expected Error"
229
+
with Loc.Error (ctx, _, k) ->
230
+
Alcotest.(check bool) "ctx empty" true (Loc.Error.Context.is_empty ctx);
231
+
Alcotest.(check string) "kind" "bad" (Loc.Error.kind_to_string k)
232
+
233
+
let error_expected_raises () =
234
+
try
235
+
let _ : int = Loc.Error.expected meta_of_sample "int" ~fnd:"string" in
236
+
Alcotest.fail "expected Error"
237
+
with Loc.Error (_, _, k) ->
238
+
let s = Loc.Error.kind_to_string k in
239
+
Alcotest.(check bool)
240
+
"mentions expected" true
241
+
(contains_substring "Expected int" s);
242
+
Alcotest.(check bool)
243
+
"mentions found" true
244
+
(contains_substring "found string" s)
245
+
246
+
let error_push_context () =
247
+
let e =
248
+
Loc.Error.make_msg Loc.Error.Context.empty meta_of_sample "bad"
249
+
in
250
+
let kinded = ("array", Loc.Meta.none) in
251
+
let n = (3, Loc.Meta.none) in
252
+
try
253
+
let _ : int = Loc.Error.push_array kinded n e in
254
+
Alcotest.fail "expected Error"
255
+
with Loc.Error (ctx, _, _) ->
256
+
Alcotest.(check bool)
257
+
"ctx non-empty" false
258
+
(Loc.Error.Context.is_empty ctx);
259
+
Alcotest.(check int) "one layer" 1 (List.length ctx)
260
+
261
+
let error_pp_mentions_path () =
262
+
let kinded = ("array", Loc.Meta.none) in
263
+
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
268
+
let s = Loc.Error.to_string e in
269
+
Alcotest.(check bool) "msg in output" true (contains_substring "bad" s);
270
+
Alcotest.(check bool) "index in output" true (contains_substring "index 3" s);
271
+
Alcotest.(check bool) "kind in output" true (contains_substring "array" s)
272
+
273
+
let suite =
274
+
( "loc",
275
+
[
276
+
Alcotest.test_case "make + accessors" `Quick make_and_accessors;
277
+
Alcotest.test_case "set_file" `Quick set_file;
278
+
Alcotest.test_case "none is_none" `Quick none_is_none;
279
+
Alcotest.test_case "is_empty detection" `Quick empty_detection;
280
+
Alcotest.test_case "equal ignores line info" `Quick
281
+
equal_ignores_line_info;
282
+
Alcotest.test_case "compare orders by file then byte" `Quick
283
+
compare_orders_by_file_then_byte;
284
+
Alcotest.test_case "to_first / to_last" `Quick to_first_and_to_last;
285
+
Alcotest.test_case "span unions ranges" `Quick span_unions_ranges;
286
+
Alcotest.test_case "pp_ocaml single line" `Quick pp_ocaml_single_line;
287
+
Alcotest.test_case "pp_gnu format" `Quick pp_gnu_format;
288
+
Alcotest.test_case "pp_ocaml none" `Quick pp_none;
289
+
Alcotest.test_case "Meta.make/accessors" `Quick meta_basic;
290
+
Alcotest.test_case "Meta.none is_none" `Quick meta_none;
291
+
Alcotest.test_case "Meta.with_textloc" `Quick meta_with_textloc;
292
+
Alcotest.test_case "Meta.clear_ws / clear_textloc" `Quick meta_clear;
293
+
Alcotest.test_case "Meta.copy_ws" `Quick meta_copy_ws;
294
+
Alcotest.test_case "Path.root" `Quick path_root;
295
+
Alcotest.test_case "Path.mem/nth/rev_indices" `Quick path_build;
296
+
Alcotest.test_case "Path.of_string round-trip" `Quick
297
+
path_of_string_roundtrip;
298
+
Alcotest.test_case "Path.pp" `Quick path_pp;
299
+
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;
301
+
Alcotest.test_case "Error.msg raises" `Quick error_msg_raises;
302
+
Alcotest.test_case "Error.expected raises" `Quick error_expected_raises;
303
+
Alcotest.test_case "Error.push_array" `Quick error_push_context;
304
+
Alcotest.test_case "Error.pp mentions path" `Quick error_pp_mentions_path;
305
+
] )