loc,json,skill: hoist Context out of Error, make Path.step extensible

+107 -67

lib/loc.ml

··· 215 215 (* Structural paths *) 216 216 217 217 module Path = struct 218 - type index = Mem of string node | Nth of int node 218 + type step = .. 219 + type step += Mem of string node | Nth of int node 219 220 220 221 let pp_name = pp_code 221 - let pp_index_num ppf n = pp_code ppf (Int.to_string n) 222 + let pp_step_num ppf n = pp_code ppf (Int.to_string n) 223 + 224 + let step_printers : (step -> (Format.formatter -> unit) option) list ref = 225 + ref [] 226 + 227 + let register_step_printer p = step_printers := p :: !step_printers 222 228 223 - let pp_index ppf = function 229 + let default_pp_step ppf = function 224 230 | Mem (n, _) -> pp_name ppf n 225 - | Nth (n, _) -> Fmt.pf ppf "[%a]" pp_index_num n 231 + | Nth (n, _) -> Fmt.pf ppf "[%a]" pp_step_num n 232 + | _ -> Format.pp_print_string ppf "<unknown path step>" 226 233 227 - let pp_index_trace ppf = function 234 + let pp_step ppf s = 235 + let rec find = function 236 + | [] -> default_pp_step ppf s 237 + | p :: ps -> ( match p s with Some f -> f ppf | None -> find ps) 238 + in 239 + find !step_printers 240 + 241 + let default_pp_step_trace ppf = function 228 242 | Mem (n, meta) -> 229 243 Fmt.pf ppf "%a: in member %a" pp (Meta.textloc meta) pp_name n 230 244 | Nth (n, meta) -> 231 - Fmt.pf ppf "%a: at index %a" pp (Meta.textloc meta) pp_index_num n 245 + Fmt.pf ppf "%a: at index %a" pp (Meta.textloc meta) pp_step_num n 246 + | s -> pp_step ppf s 247 + 248 + let pp_step_trace = default_pp_step_trace 232 249 233 - type t = index list 250 + type t = step list 251 + (* Internally leaf-to-root: [push s p] conses [s] at the head. Public 252 + accessors normalize. *) 234 253 235 254 let root = [] 236 255 let is_root = function [] -> true | _ -> false 256 + let push s p = s :: p 237 257 let nth ?(meta = Meta.none) n p = Nth (n, meta) :: p 238 258 let mem ?(meta = Meta.none) n p = Mem (n, meta) :: p 239 - let rev_indices p = p 259 + let last = function [] -> None | s :: _ -> Some s 260 + let to_list p = List.rev p 261 + let rev_steps p = p 240 262 241 - let pp ppf is = 263 + let pp ppf steps = 242 264 let pp_sep ppf () = Fmt.char ppf '.' in 243 - Fmt.list ~sep:pp_sep pp_index ppf (List.rev is) 265 + Fmt.list ~sep:pp_sep pp_step ppf (List.rev steps) 244 266 245 - let pp_trace ppf is = 246 - if is <> [] then Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_index_trace) is 267 + let pp_trace ppf steps = 268 + if steps <> [] then Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_step_trace) steps 247 269 248 270 (* Parsing *) 249 271 ··· 252 274 let err_unexp_char i s = err i "Unexpected character: %C" s.[i] 253 275 let err_illegal_char i s = err i "Illegal character here: %C" s.[i] 254 276 255 - let parse_index p s i max = 277 + let parse_step p s i max = 256 278 let first, stop = match s.[i] with '[' -> (i + 1, ']') | _ -> (i, '.') in 257 279 let last, next = 258 280 let rec loop stop s i max = ··· 266 288 in 267 289 loop stop s first max 268 290 in 269 - let idx = string_subrange ~first ~last s in 270 - if idx = "" then err first "illegal empty index" 291 + let step = string_subrange ~first ~last s in 292 + if step = "" then err first "illegal empty index" 271 293 else 272 - match int_of_string idx with 273 - | exception Failure _ -> (next, Mem (idx, Meta.none) :: p) 274 - | idx -> (next, Nth (idx, Meta.none) :: p) 294 + match int_of_string step with 295 + | exception Failure _ -> (next, Mem (step, Meta.none) :: p) 296 + | n -> (next, Nth (n, Meta.none) :: p) 275 297 276 298 let of_string s = 277 299 let rec loop p s i max = 278 300 if i > max then p 279 301 else 280 - let next, p = parse_index p s i max in 302 + let next, p = parse_step p s i max in 281 303 if next > max then p 282 304 else if s.[next] <> '.' then err_unexp_char next s 283 305 else if next + 1 <= max then loop p s (next + 1) max ··· 291 313 with Failure e -> Error e 292 314 end 293 315 316 + (* Contexts *) 317 + 318 + module Context = struct 319 + type frame = { sort : string node; step : Path.step } 320 + type t = frame list 321 + (* Leaf-to-root, matching Path.t. *) 322 + 323 + let empty = [] 324 + let is_empty ctx = ctx = [] 325 + let push ~sort step ctx = { sort; step } :: ctx 326 + let push_nth sort n ctx = push ~sort (Path.Nth n) ctx 327 + let push_mem sort n ctx = push ~sort (Path.Mem n) ctx 328 + let push_array = push_nth 329 + let push_object = push_mem 330 + 331 + let path ctx = List.map (fun f -> f.step) ctx 332 + let last_step = function [] -> None | f :: _ -> Some f.step 333 + let last_sort = function [] -> None | f :: _ -> Some f.sort 334 + 335 + let pp_name = pp_code 336 + let pp_int ppf i = pp_code ppf (Int.to_string i) 337 + 338 + let pp ppf ctx = 339 + let pp_meta ppf meta = 340 + if Meta.is_none meta then () 341 + else Fmt.pf ppf "%a: " pp (Meta.textloc meta) 342 + in 343 + let pp_el ppf { sort; step } = 344 + match step with 345 + | Path.Nth (n, meta) -> 346 + Fmt.pf ppf "@[<v>%aat index %a of@,%a%a@]" pp_meta meta pp_int n 347 + pp_meta (snd sort) pp_name (fst sort) 348 + | Path.Mem (name, meta) -> 349 + Fmt.pf ppf "@[<v>%ain member %a of@,%a%a@]" pp_meta meta pp_name name 350 + pp_meta (snd sort) pp_name (fst sort) 351 + | step -> 352 + Fmt.pf ppf "@[<v>%a of@,%a%a@]" Path.pp_step_trace step pp_meta 353 + (snd sort) pp_name (fst sort) 354 + in 355 + if ctx = [] then () 356 + else Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_el) (List.rev ctx) 357 + end 358 + 294 359 (* Errors *) 295 360 296 361 type error_kind = .. 297 362 type error_kind += Msg of string 298 - type context_index = string node * Path.index 299 - type context = context_index list 300 - type error = context * Meta.t * error_kind 363 + type error = { ctx : Context.t; meta : Meta.t; kind : error_kind } 301 364 302 365 exception Error of error 303 366 304 367 module Error = struct 305 368 type kind = error_kind = .. 306 369 type kind += Msg = Msg 307 - type t = error 370 + type nonrec t = error = { ctx : Context.t; meta : Meta.t; kind : kind } 308 371 309 372 (* Registry of printers contributed by codec libraries. The first printer 310 373 that returns [Some f] wins; [Msg] falls through to the default. *) ··· 326 389 find !kind_printers 327 390 328 391 let kind_to_string k = Format.asprintf "%a" pp_kind k 329 - let pp_name = pp_code 330 - let pp_int ppf i = pp_code ppf (Int.to_string i) 392 + let pp_code = pp_code 331 393 332 - module Context = struct 333 - type index = context_index 334 - type t = context 394 + let v ~ctx ~meta kind = { ctx; meta; kind } 395 + let ctx e = e.ctx 396 + let meta e = e.meta 397 + let kind e = e.kind 398 + let msg ~ctx ~meta s = { ctx; meta; kind = Msg s } 399 + let raise ~ctx ~meta kind = raise_notrace (Error { ctx; meta; kind }) 335 400 336 - let empty = [] 337 - let is_empty ctx = ctx = [] 338 - let push_array kinded_sort n ctx = (kinded_sort, Path.Nth n) :: ctx 339 - let push_object kinded_sort n ctx = (kinded_sort, Path.Mem n) :: ctx 401 + let fail meta s = 402 + raise_notrace (Error { ctx = Context.empty; meta; kind = Msg s }) 340 403 341 - let pp ppf ctx = 342 - let pp_meta ppf meta = 343 - if Meta.is_none meta then () 344 - else Fmt.pf ppf "%a: " pp (Meta.textloc meta) 345 - in 346 - let pp_el ppf (kind, index) = 347 - match index with 348 - | Path.Nth (n, meta) -> 349 - Fmt.pf ppf "@[<v>%aat index %a of@,%a%a@]" pp_meta meta pp_int n 350 - pp_meta (snd kind) pp_name (fst kind) 351 - | Path.Mem (name, meta) -> 352 - Fmt.pf ppf "@[<v>%ain member %a of@,%a%a@]" pp_meta meta pp_name 353 - name pp_meta (snd kind) pp_name (fst kind) 354 - in 355 - if ctx = [] then () 356 - else Fmt.pf ppf "@,@[<v>%a@]" (Fmt.list pp_el) (List.rev ctx) 357 - end 358 - 359 - let v ctx meta kind = (ctx, meta, kind) 360 - let msg ctx meta s = (ctx, meta, Msg s) 361 - let raise ctx meta kind = raise_notrace (Error (ctx, meta, kind)) 362 - let fail meta s = raise_notrace (Error (Context.empty, meta, Msg s)) 363 404 let failf meta fmt = Format.kasprintf (fun s -> fail meta s) fmt 364 405 365 - let push_array kinded_sort n (ctx, meta, e) = 366 - raise_notrace (Error (Context.push_array kinded_sort n ctx, meta, e)) 406 + let push_array sort n e = 407 + raise_notrace (Error { e with ctx = Context.push_nth sort n e.ctx }) 367 408 368 - let push_object kinded_sort n (ctx, meta, e) = 369 - raise_notrace (Error (Context.push_object kinded_sort n ctx, meta, e)) 409 + let push_object sort n e = 410 + raise_notrace (Error { e with ctx = Context.push_mem sort n e.ctx }) 370 411 371 - let adjust_context ~first_byte ~first_line_num ~first_line_byte (ctx, meta, e) 372 - = 373 - match ctx with 374 - | [] -> raise_notrace (Error (ctx, meta, e)) 375 - | ((sort, smeta), idx) :: is -> 412 + let adjust_context ~first_byte ~first_line_num ~first_line_byte e = 413 + match e.ctx with 414 + | [] -> raise_notrace (Error e) 415 + | { sort = name, smeta; step } :: is -> 376 416 let textloc = Meta.textloc smeta in 377 417 let textloc = 378 418 if is_none textloc then textloc 379 419 else set_first textloc ~first_byte ~first_line_num ~first_line_byte 380 420 in 381 421 let smeta = Meta.with_textloc smeta textloc in 382 - let ctx = ((sort, smeta), idx) :: is in 383 - raise_notrace (Error (ctx, meta, e)) 422 + let ctx = { Context.sort = (name, smeta); step } :: is in 423 + raise_notrace (Error { e with ctx }) 384 424 385 - let pp ppf (ctx, m, kind) = 425 + let pp ppf e = 386 426 let pp_meta ppf m = 387 427 if not (Meta.is_none m) then Fmt.pf ppf "@,%a:" pp (Meta.textloc m) 388 428 in 389 - Fmt.pf ppf "@[<v>%a%a%a@]" pp_kind kind pp_meta m Context.pp ctx 429 + Fmt.pf ppf "@[<v>%a%a%a@]" pp_kind e.kind pp_meta e.meta Context.pp e.ctx 390 430 391 431 let to_string e = Format.asprintf "%a" pp e 392 432

+124 -58

lib/loc.mli

··· 155 155 val pp_dump : Format.formatter -> t -> unit 156 156 (** Raw data dump, for debugging. *) 157 157 158 - (** {1:meta Metadata, paths and errors} *) 158 + (** {1:meta Metadata} *) 159 159 160 160 (** Abstract syntax tree node metadata. 161 161 ··· 202 202 type 'a node = 'a * Meta.t 203 203 (** Abstract syntax tree node: data plus its metadata. *) 204 204 205 - (** Structural paths into JSON-like data. 205 + (** {1:paths Structural paths} 206 206 207 - A path is a sequence of indexing operations: object members and array 208 - indices. Used to build {!Error.Context.t} and to address sub-values for 209 - queries and updates. *) 207 + Paths address sub-values in a structured document. The step alphabet is 208 + extensible: [Mem] and [Nth] are the baseline for name-addressed and 209 + index-addressed descent; formats add their own native steps (XML 210 + [Attribute], CBOR [Cbor_key], protobuf [Field_number], ...) via extension 211 + constructors and register printers for them. *) 210 212 module Path : sig 211 - type index = 212 - | Mem of string node (** Index a value by member name. *) 213 - | Nth of int node (** Index a value by zero-based array index. *) 213 + type step = .. 214 + (** The type for path steps. Extensible: formats add native addressing via 215 + [type step += ...] and {!register_step_printer}. *) 214 216 215 - val pp_index : Format.formatter -> index -> unit 216 - (** [pp_index] formats an index without source location. *) 217 + type step += 218 + | Mem of string node (** Name-addressed step: object member, XML element 219 + local-name, TOML table name, etc. *) 220 + | Nth of int node (** Index-addressed step: array index, tuple position. *) 217 221 218 - val pp_index_trace : Format.formatter -> index -> unit 219 - (** [pp_index_trace] formats an index with its source location. *) 222 + val register_step_printer : 223 + (step -> (Format.formatter -> unit) option) -> unit 224 + (** [register_step_printer p] adds [p] to the step printer registry used by 225 + {!pp_step}. Printers are tried in reverse order of registration; the first 226 + one returning [Some f] is used. Fallback handles {!Mem} and {!Nth}. Call 227 + once per format at load time. *) 228 + 229 + val pp_step : Format.formatter -> step -> unit 230 + (** [pp_step] formats a step without source location, via the registry. *) 231 + 232 + val pp_step_trace : Format.formatter -> step -> unit 233 + (** [pp_step_trace] formats a step with its source location. *) 220 234 221 235 type t 222 - (** The type for paths. *) 236 + (** The type for paths. Internally leaf-to-root (last step at the head) for 237 + O(1) cons; public accessors normalize. *) 223 238 224 239 val root : t 225 240 (** [root] is the empty path. *) ··· 227 242 val is_root : t -> bool 228 243 (** [is_root p] is [true] iff [p] is {!root}. *) 229 244 245 + val push : step -> t -> t 246 + (** [push s p] extends [p] with step [s]. The new step becomes the innermost 247 + ({!last}) position. *) 248 + 230 249 val nth : ?meta:Meta.t -> int -> t -> t 231 - (** [nth ~meta n p] extends [p] by indexing an array at [n]. *) 250 + (** [nth ~meta n p] is [push (Nth (n, meta)) p]. *) 232 251 233 252 val mem : ?meta:Meta.t -> string -> t -> t 234 - (** [mem ~meta n p] extends [p] by indexing an object at member [n]. *) 253 + (** [mem ~meta n p] is [push (Mem (n, meta)) p]. *) 254 + 255 + val last : t -> step option 256 + (** [last p] is the innermost step of [p], or [None] if [p] is {!root}. *) 235 257 236 - val rev_indices : t -> index list 237 - (** [rev_indices p] is the path's indices with the deepest one first. *) 258 + val to_list : t -> step list 259 + (** [to_list p] is [p]'s steps in {b root-to-leaf} order. Costs one list 260 + reversal. Use when you need a path to match/print from the outside in. *) 261 + 262 + val rev_steps : t -> step list 263 + (** [rev_steps p] is [p]'s steps in {b leaf-to-root} order (the raw internal 264 + order). Cheaper than {!to_list}; use when iteration order is 265 + irrelevant. *) 238 266 239 267 val of_string : string -> (t, string) result 240 - (** [of_string s] parses a dot-separated path like ["a.b.[2].c"]. *) 268 + (** [of_string s] parses a dot-separated path like ["a.b.[2].c"]. Only the 269 + {!Mem} / {!Nth} baseline is recognized. *) 241 270 242 271 val pp : Format.formatter -> t -> unit 243 - (** [pp] formats paths as dot-separated indices. *) 272 + (** [pp] formats paths as dot-separated steps, root-to-leaf. *) 244 273 245 274 val pp_trace : Format.formatter -> t -> unit 246 275 (** [pp_trace] formats paths as a vertical trace with locations. *) 247 276 end 248 277 278 + (** {1:context Navigation contexts} 279 + 280 + A context describes {b where} in a structured document we are: the full 281 + {!Path.t} from the root, plus the {e sort} label of each parent container. 282 + Errors hold a context (pointing at the offending node); cursors produce a 283 + context (describing the current focus); stream callbacks receive a context 284 + (naming the child they were handed). 285 + 286 + One noun, top to bottom. *) 287 + module Context : sig 288 + type t 289 + (** The type for contexts. *) 290 + 291 + val empty : t 292 + (** [empty] is the root context. *) 293 + 294 + val is_empty : t -> bool 295 + (** [is_empty ctx] is [true] iff [ctx] is {!empty}. *) 296 + 297 + val push : sort:string node -> Path.step -> t -> t 298 + (** [push ~sort s ctx] extends [ctx]: the current node's parent has sort label 299 + [sort], and we descend into it via step [s]. *) 300 + 301 + val push_nth : string node -> int node -> t -> t 302 + (** [push_nth sort n ctx] is [push ~sort (Path.Nth n) ctx]. *) 303 + 304 + val push_mem : string node -> string node -> t -> t 305 + (** [push_mem sort n ctx] is [push ~sort (Path.Mem n) ctx]. *) 306 + 307 + (** {2:accessors Accessors} *) 308 + 309 + val path : t -> Path.t 310 + (** [path ctx] is the path from the root to the current position. *) 311 + 312 + val last_step : t -> Path.step option 313 + (** [last_step ctx] is the innermost step, or [None] at the root. *) 314 + 315 + val last_sort : t -> string node option 316 + (** [last_sort ctx] is the sort label of the innermost frame's parent, 317 + or [None] at the root. *) 318 + 319 + (** {2:compat Legacy push helpers} *) 320 + 321 + val push_array : string node -> int node -> t -> t 322 + (** [push_array sort n ctx] is {!push_nth}. *) 323 + 324 + val push_object : string node -> string node -> t -> t 325 + (** [push_object sort n ctx] is {!push_mem}. *) 326 + 327 + val pp : Format.formatter -> t -> unit 328 + (** [pp] formats a context as an indented trace. *) 329 + end 330 + 331 + (** {1:errors Errors} *) 332 + 249 333 (** Encoding, decoding, and query errors. 250 334 251 - Errors carry a structured context (the path from the root value to the 252 - erroring sub-value), the source location of the error, and a kind. *) 335 + Errors carry a {!Context.t} (the path and sort labels from the root value to 336 + the erroring sub-value), the source location of the error, and a kind. *) 253 337 module Error : sig 254 338 type kind = .. 255 339 (** The type of error kinds. Extensible: each codec library extends this with ··· 274 358 val kind_to_string : kind -> string 275 359 (** [kind_to_string k] is the kind formatted as a string. *) 276 360 277 - module Context : sig 278 - type index = string node * Path.index 279 - (** A context index: the kinded-sort label of the parent container, plus the 280 - path index to the sub-value within it. *) 361 + type t = { ctx : Context.t; meta : Meta.t; kind : kind } 362 + (** The type for errors. Exposed as a record so consumers can destructure with 363 + [match e with Error { ctx; meta; kind }]. *) 281 364 282 - type t = index list 283 - (** A context: the chain of indexings from the root value down to the 284 - erroring sub-value. The first list element indexes the root. *) 365 + val v : ctx:Context.t -> meta:Meta.t -> kind -> t 366 + (** [v ~ctx ~meta kind] is [{ ctx; meta; kind }]. *) 285 367 286 - val empty : t 287 - (** [empty] is the empty context. *) 368 + val ctx : t -> Context.t 369 + (** [ctx e] is [e.ctx]. *) 288 370 289 - val is_empty : t -> bool 290 - (** [is_empty ctx] is [true] iff [ctx] is {!empty}. *) 371 + val meta : t -> Meta.t 372 + (** [meta e] is [e.meta]. *) 291 373 292 - val push_array : string node -> int node -> t -> t 293 - (** [push_array kinded_sort n ctx] wraps [ctx] as the [n]th element of an 294 - array of kinded sort [kinded_sort]. *) 374 + val kind : t -> kind 375 + (** [kind e] is [e.kind]. *) 295 376 296 - val push_object : string node -> string node -> t -> t 297 - (** [push_object kinded_sort n ctx] wraps [ctx] as the member named [n] of 298 - an object of kinded sort [kinded_sort]. *) 377 + val msg : ctx:Context.t -> meta:Meta.t -> string -> t 378 + (** [msg ~ctx ~meta s] is [v ~ctx ~meta (Msg s)]. *) 299 379 300 - val pp : Format.formatter -> t -> unit 301 - (** [pp] formats a context as an indented trace. *) 302 - end 303 - 304 - type t = Context.t * Meta.t * kind 305 - (** An error: a context, the error's source location and whitespace meta, and 306 - the error kind (tag + message). *) 307 - 308 - val v : Context.t -> Meta.t -> kind -> t 309 - (** [v ctx meta kind] constructs an error value with a typed kind. *) 310 - 311 - val msg : Context.t -> Meta.t -> string -> t 312 - (** [msg ctx meta s] is [v ctx meta (Msg s)]. *) 313 - 314 - val raise : Context.t -> Meta.t -> kind -> 'a 315 - (** [raise ctx meta kind] raises the {!Error} exception. *) 380 + val raise : ctx:Context.t -> meta:Meta.t -> kind -> 'a 381 + (** [raise ~ctx ~meta kind] raises the {!Error} exception. *) 316 382 317 383 val fail : Meta.t -> string -> 'a 318 384 (** [fail meta s] raises an error with empty context and message [s]. *) ··· 326 392 *) 327 393 328 394 val push_array : string node -> int node -> t -> 'a 329 - (** [push_array kinded_sort n e] re-raises [e] after pushing an array index 330 - onto its context. *) 395 + (** [push_array sort n e] re-raises [e] after pushing an array index onto its 396 + context. *) 331 397 332 398 val push_object : string node -> string node -> t -> 'a 333 - (** [push_object kinded_sort n e] re-raises [e] after pushing an object member 334 - onto its context. *) 399 + (** [push_object sort n e] re-raises [e] after pushing an object member onto 400 + its context. *) 335 401 336 402 val adjust_context : 337 403 first_byte:byte_pos ->

+29 -17

test/test_loc.ml

··· 171 171 let p = Loc.Path.mem "a" Loc.Path.root in 172 172 let p = Loc.Path.mem "b" p in 173 173 let p = Loc.Path.nth 3 p in 174 - match Loc.Path.rev_indices p with 174 + match Loc.Path.rev_steps p with 175 175 | [ Loc.Path.Nth (3, _); Loc.Path.Mem ("b", _); Loc.Path.Mem ("a", _) ] -> () 176 176 | _ -> Alcotest.fail "unexpected path shape" 177 177 ··· 179 179 match Loc.Path.of_string "ocaml.libs.[0]" with 180 180 | Error e -> Alcotest.failf "parse error: %s" e 181 181 | Ok p -> ( 182 - match Loc.Path.rev_indices p with 182 + match Loc.Path.rev_steps p with 183 183 | [ 184 184 Loc.Path.Nth (0, _); Loc.Path.Mem ("libs", _); Loc.Path.Mem ("ocaml", _); 185 185 ] -> ··· 203 203 let meta_of_sample = Loc.Meta.make sample 204 204 205 205 let error_msg () = 206 - let e = Loc.Error.msg Loc.Error.Context.empty meta_of_sample "boom" in 206 + let e = 207 + Loc.Error.msg ~ctx:Loc.Context.empty ~meta:meta_of_sample "boom" 208 + in 207 209 let s = Loc.Error.to_string e in 208 210 Alcotest.(check bool) "contains msg" true (contains_substring "boom" s); 209 211 Alcotest.(check bool) "contains file" true (contains_substring "foo.ml" s) ··· 212 214 try 213 215 let _ : int = Loc.Error.fail meta_of_sample "bad" in 214 216 Alcotest.fail "expected Error" 215 - with Loc.Error (ctx, _, k) -> 216 - Alcotest.(check bool) "ctx empty" true (Loc.Error.Context.is_empty ctx); 217 - Alcotest.(check string) "kind" "bad" (Loc.Error.kind_to_string k) 217 + with Loc.Error e -> 218 + Alcotest.(check bool) 219 + "ctx empty" true 220 + (Loc.Context.is_empty (Loc.Error.ctx e)); 221 + Alcotest.(check string) 222 + "kind" "bad" 223 + (Loc.Error.kind_to_string (Loc.Error.kind e)) 218 224 219 225 let error_expected_raises () = 220 226 try 221 227 let _ : int = Loc.Error.expected meta_of_sample "int" ~fnd:"string" in 222 228 Alcotest.fail "expected Error" 223 - with Loc.Error (_, _, k) -> 224 - let s = Loc.Error.kind_to_string k in 229 + with Loc.Error e -> 230 + let s = Loc.Error.kind_to_string (Loc.Error.kind e) in 225 231 Alcotest.(check bool) 226 232 "mentions expected" true 227 233 (contains_substring "Expected int" s); ··· 230 236 (contains_substring "found string" s) 231 237 232 238 let error_push_context () = 233 - let e = Loc.Error.msg Loc.Error.Context.empty meta_of_sample "bad" in 239 + let e = 240 + Loc.Error.msg ~ctx:Loc.Context.empty ~meta:meta_of_sample "bad" 241 + in 234 242 let kinded = ("array", Loc.Meta.none) in 235 243 let n = (3, Loc.Meta.none) in 236 244 try 237 245 let _ : int = Loc.Error.push_array kinded n e in 238 246 Alcotest.fail "expected Error" 239 - with Loc.Error (ctx, _, _) -> 240 - Alcotest.(check bool) "ctx non-empty" false (Loc.Error.Context.is_empty ctx); 241 - Alcotest.(check int) "one layer" 1 (List.length ctx) 247 + with Loc.Error e -> 248 + let ctx = Loc.Error.ctx e in 249 + Alcotest.(check bool) 250 + "ctx non-empty" false (Loc.Context.is_empty ctx); 251 + Alcotest.(check int) 252 + "one layer" 1 253 + (List.length (Loc.Path.rev_steps (Loc.Context.path ctx))) 242 254 243 255 let error_pp_mentions_path () = 244 256 let kinded = ("array", Loc.Meta.none) in 245 257 let n = (3, Loc.Meta.none) 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 258 + let ctx = Loc.Context.push_array kinded n Loc.Context.empty in 259 + let e = Loc.Error.msg ~ctx ~meta:meta_of_sample "bad" in 248 260 let s = Loc.Error.to_string e in 249 261 Alcotest.(check bool) "msg in output" true (contains_substring "bad" s); 250 262 Alcotest.(check bool) "index in output" true (contains_substring "index 3" s); ··· 265 277 Alcotest.(check string) 266 278 "registered printer runs" "expected integer, got string" 267 279 (Loc.Error.kind_to_string k); 268 - let e = Loc.Error.v Loc.Error.Context.empty meta_of_sample k in 280 + let e = Loc.Error.v ~ctx:Loc.Context.empty ~meta:meta_of_sample k in 269 281 Alcotest.(check bool) 270 282 "pattern-matches through Error.t" true 271 - (match e with 272 - | _, _, Demo_sort_mismatch { exp = "integer"; _ } -> true 283 + (match Loc.Error.kind e with 284 + | Demo_sort_mismatch { exp = "integer"; _ } -> true 273 285 | _ -> false); 274 286 Alcotest.(check string) 275 287 "Msg fallback still works" "plain text"

Configure Feed

Configure Feed