cbor: full Error refactor over Loc.Error · gazagnaire.org/ocaml-cbor@2d6552d

+136 -167

lib/cbor.ml

··· 7 7 module Binary = Binary 8 8 module Value = Value 9 9 module Sort = Sort 10 - 11 - module Error = struct 12 - type path = segment list 13 - 14 - and segment = 15 - | Root 16 - | Index of int 17 - | Key of string 18 - | Key_cbor of Value.t 19 - | Tag of int 20 - 21 - let pp_segment ppf = function 22 - | Root -> Fmt.pf ppf "$" 23 - | Index i -> Fmt.pf ppf "[%d]" i 24 - | Key k -> Fmt.pf ppf ".%s" k 25 - | Key_cbor k -> Fmt.pf ppf "[%a]" Value.pp k 26 - | Tag n -> Fmt.pf ppf "<%d>" n 27 - 28 - let pp_path ppf path = List.iter (pp_segment ppf) (List.rev path) 29 - let path_to_string path = Fmt.str "%a" pp_path path 30 - 31 - type kind = 32 - | Type_mismatch of { expected : string; got : string } 33 - | Missing_member of string 34 - | Unknown_member of string 35 - | Duplicate_member of string 36 - | Out_of_range of { value : string; range : string } 37 - | Invalid_value of string 38 - | Parse_error of string 39 - | Custom of string 40 - 41 - type t = { path : path; kind : kind } 42 - 43 - let make path kind = { path; kind } 44 - 45 - let pp_kind ppf = function 46 - | Type_mismatch { expected; got } -> 47 - Fmt.pf ppf "type mismatch: expected %s, got %s" expected got 48 - | Missing_member name -> Fmt.pf ppf "missing required member: %s" name 49 - | Unknown_member name -> Fmt.pf ppf "unknown member: %s" name 50 - | Duplicate_member name -> Fmt.pf ppf "duplicate member: %s" name 51 - | Out_of_range { value; range } -> 52 - Fmt.pf ppf "value %s out of range %s" value range 53 - | Invalid_value msg -> Fmt.pf ppf "invalid value: %s" msg 54 - | Parse_error msg -> Fmt.pf ppf "parse error: %s" msg 55 - | Custom msg -> Fmt.pf ppf "%s" msg 56 - 57 - let pp ppf { path; kind } = Fmt.pf ppf "%a: %a" pp_path path pp_kind kind 58 - let to_string e = Fmt.str "%a" pp e 59 - 60 - exception Decode of t 61 - end 10 + module Error = Error 62 11 63 12 type 'a t = { 64 13 kind : string; 65 14 encode : 'a -> Value.t; 66 - decode : Error.path -> Value.t -> ('a, Error.t) result; 67 - decode_rw : Error.path -> Binary.decoder -> ('a, Error.t) result; 15 + decode : Loc.Context.t -> Value.t -> ('a, Error.t) result; 16 + decode_rw : Loc.Context.t -> Binary.decoder -> ('a, Error.t) result; 68 17 } 69 18 70 19 let kind c = c.kind ··· 85 34 | Float _ -> "float" 86 35 87 36 let type_error path expected v = 88 - Error (Error.make path (Type_mismatch { expected; got = type_name v })) 37 + Error.make_type_mismatch path ~expected ~got:(type_name v) 89 38 90 39 (* Major type name for stream decoding errors *) 91 40 let major_type_name = function ··· 100 49 | _ -> "unknown" 101 50 102 51 let stream_type_error path expected (hdr : Binary.header) = 103 - Error 104 - (Error.make path 105 - (Type_mismatch { expected; got = major_type_name hdr.major })) 52 + Error.make_type_mismatch path ~expected ~got:(major_type_name hdr.major) 106 53 107 54 (* Fallback: read a Value.t from the stream, then use the Value.t decoder *) 108 55 let decode_rw_via_cbor decode path dec = ··· 209 156 else 210 157 Error 211 158 (Error.make path 212 - (Out_of_range 159 + (Error.Out_of_range 213 160 { 214 161 value = Z.to_string n; 215 162 range = Fmt.str "[%d, %d]" min_int max_int; ··· 225 172 else 226 173 Error 227 174 (Error.make path 228 - (Out_of_range 175 + (Error.Out_of_range 229 176 { 230 177 value = Z.to_string n; 231 178 range = Fmt.str "[%d, %d]" min_int max_int; ··· 236 183 else 237 184 Error 238 185 (Error.make path 239 - (Out_of_range 186 + (Error.Out_of_range 240 187 { 241 188 value = Z.to_string n; 242 189 range = Fmt.str "[%d, %d]" min_int max_int; ··· 259 206 else 260 207 Error 261 208 (Error.make path 262 - (Out_of_range 209 + (Error.Out_of_range 263 210 { 264 211 value = Z.to_string n; 265 212 range = Fmt.str "[%ld, %ld]" Int32.min_int Int32.max_int; ··· 281 228 else 282 229 Error 283 230 (Error.make path 284 - (Out_of_range 231 + (Error.Out_of_range 285 232 { 286 233 value = Z.to_string n; 287 234 range = Fmt.str "[%ld, %ld]" Int32.min_int Int32.max_int; ··· 301 248 else 302 249 Error 303 250 (Error.make path 304 - (Out_of_range 251 + (Error.Out_of_range 305 252 { 306 253 value = Z.to_string n; 307 254 range = Fmt.str "[%Ld, %Ld]" Int64.min_int Int64.max_int; ··· 320 267 else 321 268 Error 322 269 (Error.make path 323 - (Out_of_range 270 + (Error.Out_of_range 324 271 { 325 272 value = Z.to_string n; 326 273 range = Fmt.str "[%Ld, %Ld]" Int64.min_int Int64.max_int; ··· 439 386 else 440 387 Error 441 388 (Error.make path 442 - (Out_of_range 389 + (Error.Out_of_range 443 390 { 444 391 value = Z.to_string n; 445 392 range = Fmt.str "[0, %d]" max_int; ··· 455 402 else 456 403 Error 457 404 (Error.make path 458 - (Out_of_range 405 + (Error.Out_of_range 459 406 { 460 407 value = Z.to_string n; 461 408 range = Fmt.str "[0, %d]" max_int; ··· 464 411 let n = Z.neg (Z.succ (Binary.read_argument_z dec hdr)) in 465 412 Error 466 413 (Error.make path 467 - (Out_of_range 414 + (Error.Out_of_range 468 415 { value = Z.to_string n; range = Fmt.str "[0, %d]" max_int })) 469 416 | _ -> stream_type_error path "integer" hdr); 470 417 } ··· 482 429 else 483 430 Error 484 431 (Error.make path 485 - (Out_of_range 432 + (Error.Out_of_range 486 433 { value = Z.to_string n; range = "[0, 4294967295]" })) 487 434 | _ -> type_error path "integer" v); 488 435 decode_rw = ··· 499 446 else 500 447 Error 501 448 (Error.make path 502 - (Out_of_range 449 + (Error.Out_of_range 503 450 { value = Z.to_string n; range = "[0, 4294967295]" })) 504 451 | _ -> stream_type_error path "integer" hdr); 505 452 } ··· 516 463 else 517 464 Error 518 465 (Error.make path 519 - (Out_of_range 466 + (Error.Out_of_range 520 467 { value = Z.to_string n; range = "[0, 2^63-1]" })) 521 468 | _ -> type_error path "integer" v); 522 469 decode_rw = ··· 532 479 else 533 480 Error 534 481 (Error.make path 535 - (Out_of_range 482 + (Error.Out_of_range 536 483 { value = Z.to_string n; range = "[0, 2^63-1]" })) 537 484 | _ -> stream_type_error path "integer" hdr); 538 485 } ··· 555 502 let rec loop i acc = 556 503 if i >= n then Ok (List.rev acc) 557 504 else 558 - let path' = Error.Index i :: path in 505 + let path' = Error.ctx_with_index i path in 559 506 match c.decode_rw path' dec with 560 507 | Ok v -> loop (i + 1) (v :: acc) 561 508 | Error e -> Error e ··· 569 516 Binary.skip_break dec; 570 517 Ok (List.rev acc)) 571 518 else 572 - let path' = Error.Index i :: path in 519 + let path' = Error.ctx_with_index i path in 573 520 match c.decode_rw path' dec with 574 521 | Ok v -> loop (i + 1) (v :: acc) 575 522 | Error e -> Error e ··· 587 534 let rec loop i acc = function 588 535 | [] -> Ok (List.rev acc) 589 536 | x :: xs -> ( 590 - let path' = Error.Index i :: path in 537 + let path' = Error.ctx_with_index i path in 591 538 match c.decode path' x with 592 539 | Ok v -> loop (i + 1) (v :: acc) xs 593 540 | Error e -> Error e) ··· 617 564 let rec loop i acc = function 618 565 | [] -> Ok (List.rev acc) 619 566 | x :: xs -> ( 620 - let path' = Error.Index i :: path in 567 + let path' = Error.ctx_with_index i path in 621 568 match c.decode path' x with 622 569 | Ok v -> loop (i + 1) (v :: acc) xs 623 570 | Error e -> Error e) ··· 626 573 | Value.Array items -> 627 574 Error 628 575 (Error.make path 629 - (Invalid_value 576 + (Error.Invalid_value 630 577 (Fmt.str "expected array of length %d, got %d" len 631 578 (List.length items)))) 632 579 | _ -> type_error path "array" v); ··· 642 589 done; 643 590 Error 644 591 (Error.make path 645 - (Invalid_value 592 + (Error.Invalid_value 646 593 (Fmt.str "expected array of length %d, got %d" len n))) 647 594 | Ok None -> ( 648 595 (* Indefinite array: read all elements to find the break *) ··· 651 598 | Ok items -> 652 599 Error 653 600 (Error.make path 654 - (Invalid_value 601 + (Error.Invalid_value 655 602 (Fmt.str "expected array of length %d, got %d" len 656 603 (List.length items)))) 657 604 | Error e -> Error e)); ··· 665 612 (fun path v -> 666 613 match v with 667 614 | Value.Array [ va; vb ] -> ( 668 - match ca.decode (Error.Index 0 :: path) va with 615 + match ca.decode (Error.ctx_with_index 0 path) va with 669 616 | Error e -> Error e 670 617 | Ok a -> ( 671 - match cb.decode (Error.Index 1 :: path) vb with 618 + match cb.decode (Error.ctx_with_index 1 path) vb with 672 619 | Error e -> Error e 673 620 | Ok b -> Ok (a, b))) 674 621 | Value.Array _ -> 675 - Error (Error.make path (Invalid_value "expected 2-element array")) 622 + Error 623 + (Error.make path (Error.Invalid_value "expected 2-element array")) 676 624 | _ -> type_error path "array" v); 677 625 decode_rw = 678 626 (fun path dec -> 679 627 match read_array_length_rw path dec with 680 628 | Error e -> e 681 629 | Ok (Some 2) -> ( 682 - match ca.decode_rw (Error.Index 0 :: path) dec with 630 + match ca.decode_rw (Error.ctx_with_index 0 path) dec with 683 631 | Error e -> Error e 684 632 | Ok a -> ( 685 - match cb.decode_rw (Error.Index 1 :: path) dec with 633 + match cb.decode_rw (Error.ctx_with_index 1 path) dec with 686 634 | Error e -> Error e 687 635 | Ok b -> Ok (a, b))) 688 636 | Ok (Some _n) -> 689 - Error (Error.make path (Invalid_value "expected 2-element array")) 637 + Error 638 + (Error.make path (Error.Invalid_value "expected 2-element array")) 690 639 | Ok None -> 691 - Error (Error.make path (Invalid_value "expected 2-element array"))); 640 + Error 641 + (Error.make path (Error.Invalid_value "expected 2-element array"))); 692 642 } 693 643 694 644 let tuple3 ca cb cc = ··· 700 650 (fun path v -> 701 651 match v with 702 652 | Value.Array [ va; vb; vc ] -> ( 703 - match ca.decode (Error.Index 0 :: path) va with 653 + match ca.decode (Error.ctx_with_index 0 path) va with 704 654 | Error e -> Error e 705 655 | Ok a -> ( 706 - match cb.decode (Error.Index 1 :: path) vb with 656 + match cb.decode (Error.ctx_with_index 1 path) vb with 707 657 | Error e -> Error e 708 658 | Ok b -> ( 709 - match cc.decode (Error.Index 2 :: path) vc with 659 + match cc.decode (Error.ctx_with_index 2 path) vc with 710 660 | Error e -> Error e 711 661 | Ok c -> Ok (a, b, c)))) 712 662 | Value.Array _ -> 713 - Error (Error.make path (Invalid_value "expected 3-element array")) 663 + Error 664 + (Error.make path (Error.Invalid_value "expected 3-element array")) 714 665 | _ -> type_error path "array" v); 715 666 decode_rw = 716 667 (fun path dec -> 717 668 match read_array_length_rw path dec with 718 669 | Error e -> e 719 670 | Ok (Some 3) -> ( 720 - match ca.decode_rw (Error.Index 0 :: path) dec with 671 + match ca.decode_rw (Error.ctx_with_index 0 path) dec with 721 672 | Error e -> Error e 722 673 | Ok a -> ( 723 - match cb.decode_rw (Error.Index 1 :: path) dec with 674 + match cb.decode_rw (Error.ctx_with_index 1 path) dec with 724 675 | Error e -> Error e 725 676 | Ok b -> ( 726 - match cc.decode_rw (Error.Index 2 :: path) dec with 677 + match cc.decode_rw (Error.ctx_with_index 2 path) dec with 727 678 | Error e -> Error e 728 679 | Ok c -> Ok (a, b, c)))) 729 680 | Ok (Some _n) -> 730 - Error (Error.make path (Invalid_value "expected 3-element array")) 681 + Error 682 + (Error.make path (Error.Invalid_value "expected 3-element array")) 731 683 | Ok None -> 732 - Error (Error.make path (Invalid_value "expected 3-element array"))); 684 + Error 685 + (Error.make path (Error.Invalid_value "expected 3-element array"))); 733 686 } 734 687 735 688 let tuple4 ca cb cc cd = ··· 742 695 (fun path v -> 743 696 match v with 744 697 | Value.Array [ va; vb; vc; vd ] -> ( 745 - match ca.decode (Error.Index 0 :: path) va with 698 + match ca.decode (Error.ctx_with_index 0 path) va with 746 699 | Error e -> Error e 747 700 | Ok a -> ( 748 - match cb.decode (Error.Index 1 :: path) vb with 701 + match cb.decode (Error.ctx_with_index 1 path) vb with 749 702 | Error e -> Error e 750 703 | Ok b -> ( 751 - match cc.decode (Error.Index 2 :: path) vc with 704 + match cc.decode (Error.ctx_with_index 2 path) vc with 752 705 | Error e -> Error e 753 706 | Ok c -> ( 754 - match cd.decode (Error.Index 3 :: path) vd with 707 + match cd.decode (Error.ctx_with_index 3 path) vd with 755 708 | Error e -> Error e 756 709 | Ok d -> Ok (a, b, c, d))))) 757 710 | Value.Array _ -> 758 - Error (Error.make path (Invalid_value "expected 4-element array")) 711 + Error 712 + (Error.make path (Error.Invalid_value "expected 4-element array")) 759 713 | _ -> type_error path "array" v); 760 714 decode_rw = 761 715 (fun path dec -> 762 716 match read_array_length_rw path dec with 763 717 | Error e -> e 764 718 | Ok (Some 4) -> ( 765 - match ca.decode_rw (Error.Index 0 :: path) dec with 719 + match ca.decode_rw (Error.ctx_with_index 0 path) dec with 766 720 | Error e -> Error e 767 721 | Ok a -> ( 768 - match cb.decode_rw (Error.Index 1 :: path) dec with 722 + match cb.decode_rw (Error.ctx_with_index 1 path) dec with 769 723 | Error e -> Error e 770 724 | Ok b -> ( 771 - match cc.decode_rw (Error.Index 2 :: path) dec with 725 + match cc.decode_rw (Error.ctx_with_index 2 path) dec with 772 726 | Error e -> Error e 773 727 | Ok c -> ( 774 - match cd.decode_rw (Error.Index 3 :: path) dec with 728 + match 729 + cd.decode_rw (Error.ctx_with_index 3 path) dec 730 + with 775 731 | Error e -> Error e 776 732 | Ok d -> Ok (a, b, c, d))))) 777 733 | Ok (Some _n) -> 778 - Error (Error.make path (Invalid_value "expected 4-element array")) 734 + Error 735 + (Error.make path (Error.Invalid_value "expected 4-element array")) 779 736 | Ok None -> 780 - Error (Error.make path (Invalid_value "expected 4-element array"))); 737 + Error 738 + (Error.make path (Error.Invalid_value "expected 4-element array"))); 781 739 } 782 740 783 741 (* Maps *) ··· 803 761 let rec loop acc = function 804 762 | [] -> Ok (List.rev acc) 805 763 | (ck, cv) :: rest -> ( 806 - let path_k = Error.Key_cbor ck :: path in 764 + let path_k = Error.ctx_with_cbor_key ck path in 807 765 match kc.decode path_k ck with 808 766 | Error e -> Error e 809 767 | Ok k -> ( ··· 920 878 } 921 879 922 880 let rec decode_mem : type o a. 923 - Error.path -> 881 + Loc.Context.t -> 924 882 (string * Value.t) list -> 925 883 (o, a) mem -> 926 884 (a * (string * Value.t) list, Error.t) result = ··· 929 887 | Return a -> Ok (a, pairs) 930 888 | Mem { name; codec; cont; _ } -> ( 931 889 match find_remove name pairs with 932 - | None, _ -> Error (Error.make path (Missing_member name)) 890 + | None, _ -> Error (Error.make path (Error.Missing_member name)) 933 891 | Some v, remaining -> ( 934 - let path' = Error.Key name :: path in 892 + let path' = Error.ctx_with_key name path in 935 893 match codec.decode path' v with 936 894 | Error e -> Error e 937 895 | Ok x -> decode_mem path remaining (cont x))) ··· 940 898 | None, remaining -> decode_mem path remaining (cont None) 941 899 | Some Value.Null, remaining -> decode_mem path remaining (cont None) 942 900 | Some v, remaining -> ( 943 - let path' = Error.Key name :: path in 901 + let path' = Error.ctx_with_key name path in 944 902 match codec.decode path' v with 945 903 | Error e -> Error e 946 904 | Ok x -> decode_mem path remaining (cont (Some x)))) ··· 949 907 | None, remaining -> decode_mem path remaining (cont default) 950 908 | Some Value.Null, remaining -> decode_mem path remaining (cont default) 951 909 | Some v, remaining -> ( 952 - let path' = Error.Key name :: path in 910 + let path' = Error.ctx_with_key name path in 953 911 match codec.decode path' v with 954 912 | Error e -> Error e 955 913 | Ok x -> decode_mem path remaining (cont x))) ··· 990 948 hold heterogeneously-typed decoded results. *) 991 949 type mem_decoder = { 992 950 decode_rw_store : 993 - Error.path -> 951 + Loc.Context.t -> 994 952 Binary.decoder -> 995 953 (string, Stdlib.Obj.t) Hashtbl.t -> 996 954 (unit, Error.t) result; ··· 1059 1017 (* After reading all map pairs from the stream, walk the mem chain 1060 1018 and collect typed values from the hashtable. *) 1061 1019 let rec resolve_mem : type o a. 1062 - Error.path -> 1020 + Loc.Context.t -> 1063 1021 (string, Stdlib.Obj.t) Hashtbl.t -> 1064 1022 (o, a) mem -> 1065 1023 (a, Error.t) result = ··· 1068 1026 | Return a -> Ok a 1069 1027 | Mem { name; cont; _ } -> ( 1070 1028 match Hashtbl.find_opt tbl name with 1071 - | None -> Error (Error.make path (Missing_member name)) 1029 + | None -> Error (Error.make path (Error.Missing_member name)) 1072 1030 | Some obj -> resolve_mem path tbl (cont (Stdlib.Obj.obj obj))) 1073 1031 | Mem_opt { name; cont; _ } -> ( 1074 1032 match Hashtbl.find_opt tbl name with ··· 1095 1053 let key = Binary.read_text dec in 1096 1054 match Hashtbl.find_opt dispatch key with 1097 1055 | Some entry -> ( 1098 - let path' = Error.Key key :: path in 1056 + let path' = Error.ctx_with_key key path in 1099 1057 match entry.decode_rw_store path' dec tbl with 1100 1058 | Ok () -> loop (i + 1) 1101 1059 | Error e -> Error e) ··· 1239 1197 } 1240 1198 1241 1199 let rec decode_mem : type o a. 1242 - Error.path -> 1200 + Loc.Context.t -> 1243 1201 (int * Value.t) list -> 1244 1202 (o, a) mem -> 1245 1203 (a * (int * Value.t) list, Error.t) result = ··· 1249 1207 | Mem { key; codec; cont; _ } -> ( 1250 1208 match find_remove key pairs with 1251 1209 | None, _ -> 1252 - Error (Error.make path (Missing_member (string_of_int key))) 1210 + Error (Error.make path (Error.Missing_member (string_of_int key))) 1253 1211 | Some v, remaining -> ( 1254 - let path' = Error.Key (string_of_int key) :: path in 1212 + let path' = Error.ctx_with_key (string_of_int key) path in 1255 1213 match codec.decode path' v with 1256 1214 | Error e -> Error e 1257 1215 | Ok x -> decode_mem path remaining (cont x))) ··· 1260 1218 | None, remaining -> decode_mem path remaining (cont None) 1261 1219 | Some Value.Null, remaining -> decode_mem path remaining (cont None) 1262 1220 | Some v, remaining -> ( 1263 - let path' = Error.Key (string_of_int key) :: path in 1221 + let path' = Error.ctx_with_key (string_of_int key) path in 1264 1222 match codec.decode path' v with 1265 1223 | Error e -> Error e 1266 1224 | Ok x -> decode_mem path remaining (cont (Some x)))) ··· 1269 1227 | None, remaining -> decode_mem path remaining (cont default) 1270 1228 | Some Value.Null, remaining -> decode_mem path remaining (cont default) 1271 1229 | Some v, remaining -> ( 1272 - let path' = Error.Key (string_of_int key) :: path in 1230 + let path' = Error.ctx_with_key (string_of_int key) path in 1273 1231 match codec.decode path' v with 1274 1232 | Error e -> Error e 1275 1233 | Ok x -> decode_mem path remaining (cont x))) ··· 1304 1262 stores the typed result into a hashtable keyed by int. *) 1305 1263 type mem_decoder = { 1306 1264 decode_rw_store : 1307 - Error.path -> 1265 + Loc.Context.t -> 1308 1266 Binary.decoder -> 1309 1267 (int, Stdlib.Obj.t) Hashtbl.t -> 1310 1268 (unit, Error.t) result; ··· 1370 1328 (key, entry) :: build_decoders (cont (Stdlib.Obj.magic ())) 1371 1329 1372 1330 let rec resolve_mem : type o a. 1373 - Error.path -> 1331 + Loc.Context.t -> 1374 1332 (int, Stdlib.Obj.t) Hashtbl.t -> 1375 1333 (o, a) mem -> 1376 1334 (a, Error.t) result = ··· 1379 1337 | Return a -> Ok a 1380 1338 | Mem { key; cont; _ } -> ( 1381 1339 match Hashtbl.find_opt tbl key with 1382 - | None -> Error (Error.make path (Missing_member (string_of_int key))) 1340 + | None -> 1341 + Error (Error.make path (Error.Missing_member (string_of_int key))) 1383 1342 | Some obj -> resolve_mem path tbl (cont (Stdlib.Obj.obj obj))) 1384 1343 | Mem_opt { key; cont; _ } -> ( 1385 1344 match Hashtbl.find_opt tbl key with ··· 1417 1376 | Some key -> ( 1418 1377 match Hashtbl.find_opt dispatch key with 1419 1378 | Some entry -> ( 1420 - let path' = Error.Key (string_of_int key) :: path in 1379 + let path' = Error.ctx_with_key (string_of_int key) path in 1421 1380 match entry.decode_rw_store path' dec tbl with 1422 1381 | Ok () -> loop (i + 1) 1423 1382 | Error e -> Error e) ··· 1495 1454 (fun path v -> 1496 1455 match v with 1497 1456 | Value.Tag (m, content) when m = n -> 1498 - c.decode (Error.Tag n :: path) content 1457 + c.decode (Error.ctx_with_tag n path) content 1499 1458 | Value.Tag (m, _) -> 1500 1459 Error 1501 1460 (Error.make path 1502 - (Invalid_value (Fmt.str "expected tag %d, got tag %d" n m))) 1461 + (Error.Invalid_value 1462 + (Fmt.str "expected tag %d, got tag %d" n m))) 1503 1463 | _ -> type_error path (Fmt.str "tag(%d)" n) v); 1504 1464 decode_rw = 1505 1465 (fun path dec -> 1506 1466 let hdr = Binary.read_header dec in 1507 1467 if hdr.major = Binary.major_tag then 1508 1468 let m = Int64.to_int (Binary.read_argument dec hdr) in 1509 - if m = n then c.decode_rw (Error.Tag n :: path) dec 1469 + if m = n then c.decode_rw (Error.ctx_with_tag n path) dec 1510 1470 else 1511 1471 Error 1512 1472 (Error.make path 1513 - (Invalid_value (Fmt.str "expected tag %d, got tag %d" n m))) 1473 + (Error.Invalid_value 1474 + (Fmt.str "expected tag %d, got tag %d" n m))) 1514 1475 else stream_type_error path (Fmt.str "tag(%d)" n) hdr); 1515 1476 } 1516 1477 ··· 1522 1483 (fun path v -> 1523 1484 match v with 1524 1485 | Value.Tag (m, content) when m = n -> 1525 - c.decode (Error.Tag n :: path) content 1486 + c.decode (Error.ctx_with_tag n path) content 1526 1487 | _ -> c.decode path v); 1527 1488 decode_rw = 1528 1489 (fun path dec -> ··· 1530 1491 | Some b when b lsr 5 = Binary.major_tag -> 1531 1492 let hdr = Binary.read_header dec in 1532 1493 let m = Int64.to_int (Binary.read_argument dec hdr) in 1533 - if m = n then c.decode_rw (Error.Tag n :: path) dec 1494 + if m = n then c.decode_rw (Error.ctx_with_tag n path) dec 1534 1495 else 1535 1496 (* Not our tag; read the content as Value.t and use the Value.t 1536 1497 decoder with the tag wrapper *) ··· 1568 1529 | Ok x -> ( 1569 1530 match decode_f x with 1570 1531 | Ok y -> Ok y 1571 - | Error msg -> Error (Error.make path (Custom msg)))); 1532 + | Error msg -> Error (Error.make path (Error.Custom msg)))); 1572 1533 decode_rw = 1573 1534 (fun path dec -> 1574 1535 match c.decode_rw path dec with ··· 1576 1537 | Ok x -> ( 1577 1538 match decode_f x with 1578 1539 | Ok y -> Ok y 1579 - | Error msg -> Error (Error.make path (Custom msg)))); 1540 + | Error msg -> Error (Error.make path (Error.Custom msg)))); 1580 1541 } 1581 1542 1582 1543 let const v c = ··· 1624 1585 | [] -> 1625 1586 Error 1626 1587 (Error.make path 1627 - (Invalid_value 1588 + (Error.Invalid_value 1628 1589 (Fmt.str "unknown tag %d in variant" tag))) 1629 1590 | Case (t, c, inject, _) :: _rest when t = tag -> ( 1630 - match c.decode (Error.Tag t :: path) content with 1591 + match c.decode (Error.ctx_with_tag t path) content with 1631 1592 | Error e -> Error e 1632 1593 | Ok x -> Ok (inject x)) 1633 1594 | Case0 (t, v, _) :: _ when t = tag -> Ok v ··· 1646 1607 Binary.skip dec; 1647 1608 Error 1648 1609 (Error.make path 1649 - (Invalid_value (Fmt.str "unknown tag %d in variant" tag))) 1610 + (Error.Invalid_value 1611 + (Fmt.str "unknown tag %d in variant" tag))) 1650 1612 | Case (t, c, inject, _) :: _rest when t = tag -> ( 1651 - match c.decode_rw (Error.Tag t :: path) dec with 1613 + match c.decode_rw (Error.ctx_with_tag t path) dec with 1652 1614 | Error e -> Error e 1653 1615 | Ok x -> Ok (inject x)) 1654 1616 | Case0 (t, v, _) :: _ when t = tag -> ··· 1692 1654 | [] -> 1693 1655 Error 1694 1656 (Error.make path 1695 - (Invalid_value 1657 + (Error.Invalid_value 1696 1658 (Fmt.str "unknown key %S in variant" key))) 1697 1659 | Case (k, c, inject, _) :: _rest when k = key -> ( 1698 - match c.decode (Error.Key k :: path) content with 1660 + match c.decode (Error.ctx_with_key k path) content with 1699 1661 | Error e -> Error e 1700 1662 | Ok x -> Ok (inject x)) 1701 1663 | Case0 (k, v, _) :: _ when k = key -> Ok v ··· 1705 1667 | Value.Map _ -> 1706 1668 Error 1707 1669 (Error.make path 1708 - (Invalid_value "variant map must have exactly one key")) 1670 + (Error.Invalid_value "variant map must have exactly one key")) 1709 1671 | _ -> type_error path "map" v); 1710 1672 decode_rw = 1711 1673 (fun path dec -> ··· 1720 1682 Binary.skip dec; 1721 1683 Error 1722 1684 (Error.make path 1723 - (Invalid_value "variant map key must be text")) 1685 + (Error.Invalid_value "variant map key must be text")) 1724 1686 | _ -> 1725 1687 let key = Binary.read_text dec in 1726 1688 let rec try_cases = function ··· 1728 1690 Binary.skip dec; 1729 1691 Error 1730 1692 (Error.make path 1731 - (Invalid_value 1693 + (Error.Invalid_value 1732 1694 (Fmt.str "unknown key %S in variant" key))) 1733 1695 | Case (k, c, inject, _) :: _rest when k = key -> ( 1734 - match c.decode_rw (Error.Key k :: path) dec with 1696 + match c.decode_rw (Error.ctx_with_key k path) dec with 1735 1697 | Error e -> Error e 1736 1698 | Ok x -> Ok (inject x)) 1737 1699 | Case0 (k, v, _) :: _ when k = key -> ··· 1748 1710 done; 1749 1711 Error 1750 1712 (Error.make path 1751 - (Invalid_value "variant map must have exactly one key")) 1713 + (Error.Invalid_value "variant map must have exactly one key")) 1752 1714 | Ok None -> ( 1753 1715 if 1754 1716 (* Indefinite map: must have exactly one entry *) ··· 1757 1719 Binary.skip_break dec; 1758 1720 Error 1759 1721 (Error.make path 1760 - (Invalid_value "variant map must have exactly one key"))) 1722 + (Error.Invalid_value 1723 + "variant map must have exactly one key"))) 1761 1724 else 1762 1725 (* Read the first (and hopefully only) key *) 1763 1726 match Binary.peek_byte dec with ··· 1772 1735 Binary.skip_break dec; 1773 1736 Error 1774 1737 (Error.make path 1775 - (Invalid_value "variant map key must be text")) 1738 + (Error.Invalid_value "variant map key must be text")) 1776 1739 | _ -> 1777 1740 let key = Binary.read_text dec in 1778 1741 let result = ··· 1781 1744 Binary.skip dec; 1782 1745 Error 1783 1746 (Error.make path 1784 - (Invalid_value 1747 + (Error.Invalid_value 1785 1748 (Fmt.str "unknown key %S in variant" key))) 1786 1749 | Case (k, c, inject, _) :: _rest when k = key -> ( 1787 - match c.decode_rw (Error.Key k :: path) dec with 1750 + match 1751 + c.decode_rw (Error.ctx_with_key k path) dec 1752 + with 1788 1753 | Error e -> Error e 1789 1754 | Ok x -> Ok (inject x)) 1790 1755 | Case0 (k, v, _) :: _ when k = key -> ··· 1805 1770 if !extra > 0 then 1806 1771 Error 1807 1772 (Error.make path 1808 - (Invalid_value 1773 + (Error.Invalid_value 1809 1774 "variant map must have exactly one key")) 1810 1775 else result)); 1811 1776 } ··· 1834 1799 match v with 1835 1800 | Value.Map pairs -> 1836 1801 let rec find = function 1837 - | [] -> Error (Error.make path (Missing_member name)) 1802 + | [] -> Error (Error.make path (Error.Missing_member name)) 1838 1803 | (Value.Text k, value) :: _ when k = name -> 1839 - c.decode (Error.Key name :: path) value 1804 + c.decode (Error.ctx_with_key name path) value 1840 1805 | _ :: rest -> find rest 1841 1806 in 1842 1807 find pairs ··· 1856 1821 | Value.Map pairs -> 1857 1822 let key_cbor = Value.Int (Z.of_int key) in 1858 1823 let rec find = function 1859 - | [] -> Error (Error.make path (Missing_member (string_of_int key))) 1824 + | [] -> 1825 + Error (Error.make path (Error.Missing_member (string_of_int key))) 1860 1826 | (k, value) :: _ when Value.equal k key_cbor -> 1861 - c.decode (Error.Key (string_of_int key) :: path) value 1827 + c.decode (Error.ctx_with_key (string_of_int key) path) value 1862 1828 | _ :: rest -> find rest 1863 1829 in 1864 1830 find pairs ··· 1880 1846 | None -> 1881 1847 Error 1882 1848 (Error.make path 1883 - (Out_of_range 1849 + (Error.Out_of_range 1884 1850 { 1885 1851 value = string_of_int n; 1886 1852 range = Fmt.str "[0, %d)" (List.length items); 1887 1853 })) 1888 - | Some item -> c.decode (Error.Index n :: path) item) 1854 + | Some item -> c.decode (Error.ctx_with_index n path) item) 1889 1855 | _ -> type_error path "array" v 1890 1856 in 1891 1857 { ··· 1910 1876 let rec find found acc = function 1911 1877 | [] -> 1912 1878 if found then Ok (Value.Map (List.rev acc)) 1913 - else Error (Error.make path (Missing_member name)) 1879 + else Error (Error.make path (Error.Missing_member name)) 1914 1880 | (Value.Text k, value) :: rest when k = name -> ( 1915 - match c.decode (Error.Key name :: path) value with 1881 + match c.decode (Error.ctx_with_key name path) value with 1916 1882 | Error e -> Error e 1917 1883 | Ok new_value -> 1918 1884 let new_pair = (Value.Text name, c.encode new_value) in ··· 1951 1917 1952 1918 (* Decoding *) 1953 1919 1954 - let decode_cbor c v = c.decode [ Error.Root ] v 1920 + let decode_cbor c v = c.decode Loc.Context.empty v 1955 1921 1956 1922 let decode_cbor_exn c v = 1957 - match decode_cbor c v with Ok x -> x | Error e -> raise (Error.Decode e) 1923 + match decode_cbor c v with Ok x -> x | Error e -> raise (Loc.Error e) 1958 1924 1959 1925 let decode c reader = 1960 1926 let dec = Binary.decoder reader in 1961 1927 try 1962 - let result = c.decode_rw [ Error.Root ] dec in 1928 + let result = c.decode_rw Loc.Context.empty dec in 1963 1929 match result with 1964 1930 | Error _ -> result 1965 1931 | Ok _ -> ( 1966 1932 match Binary.peek_byte dec with 1967 1933 | Some _ -> 1968 1934 Error 1969 - (Error.make [ Error.Root ] 1970 - (Parse_error 1935 + (Error.make Loc.Context.empty 1936 + (Error.Parse_error 1971 1937 (Fmt.str "trailing bytes at position %d" 1972 1938 (Binary.decoder_position dec)))) 1973 1939 | None -> result) 1974 1940 with 1975 - | Failure msg -> Error (Error.make [ Error.Root ] (Parse_error msg)) 1976 - | Invalid_argument msg -> Error (Error.make [ Error.Root ] (Parse_error msg)) 1941 + | Failure msg -> Error (Error.make Loc.Context.empty (Error.Parse_error msg)) 1942 + | Invalid_argument msg -> 1943 + Error (Error.make Loc.Context.empty (Error.Parse_error msg)) 1977 1944 | End_of_file -> 1978 - Error (Error.make [ Error.Root ] (Parse_error "unexpected end of input")) 1945 + Error 1946 + (Error.make Loc.Context.empty 1947 + (Error.Parse_error "unexpected end of input")) 1979 1948 1980 1949 let decode_exn c reader = 1981 - match decode c reader with Ok x -> x | Error e -> raise (Error.Decode e) 1950 + match decode c reader with Ok x -> x | Error e -> raise (Loc.Error e) 1982 1951 1983 1952 let decode_string c s = 1984 1953 let reader = Bytes.Reader.of_string s in 1985 1954 decode c reader 1986 1955 1987 1956 let decode_string_exn c s = 1988 - match decode_string c s with Ok x -> x | Error e -> raise (Error.Decode e) 1957 + match decode_string c s with Ok x -> x | Error e -> raise (Loc.Error e) 1989 1958 1990 1959 (* Encoding *) 1991 1960

+7 -57

lib/cbor.mli

··· 60 60 61 61 (** {1:errors Errors} *) 62 62 63 - (** Error handling for codec operations. *) 64 - module Error : sig 65 - (** {1:paths Paths} *) 66 - 67 - type path = segment list 68 - (** Path to a location in a CBOR structure. *) 69 - 70 - (** A segment of a path. *) 71 - and segment = 72 - | Root (** The root of the structure. *) 73 - | Index of int (** An array index. *) 74 - | Key of string (** A map key (text string). *) 75 - | Key_cbor of Value.t (** A map key (arbitrary CBOR). *) 76 - | Tag of int (** Inside a tagged value. *) 77 - 78 - val pp_path : Format.formatter -> path -> unit 79 - (** [pp_path ppf path] pretty-prints [path]. *) 80 - 81 - val path_to_string : path -> string 82 - (** [path_to_string path] returns [path] as a string. *) 83 - 84 - (** {1:errors Errors} *) 85 - 86 - (** The kind of error. *) 87 - type kind = 88 - | Type_mismatch of { expected : string; got : string } 89 - (** Expected one CBOR type but got another. *) 90 - | Missing_member of string (** Required map member not found. *) 91 - | Unknown_member of string (** Unexpected map member (when strict). *) 92 - | Duplicate_member of string (** Map contains duplicate key. *) 93 - | Out_of_range of { value : string; range : string } 94 - (** Value outside acceptable range. *) 95 - | Invalid_value of string (** Value doesn't satisfy a constraint. *) 96 - | Parse_error of string (** Low-level parsing error. *) 97 - | Custom of string (** User-defined error. *) 98 - 99 - type t = { 100 - path : path; (** Location in the structure. *) 101 - kind : kind; (** What went wrong. *) 102 - } 103 - (** A decode error with location context. *) 104 - 105 - val make : path -> kind -> t 106 - (** [make path kind] creates an error. *) 107 - 108 - val pp : Format.formatter -> t -> unit 109 - (** [pp ppf e] pretty-prints error [e]. *) 110 - 111 - val to_string : t -> string 112 - (** [to_string e] returns [e] as a string. *) 113 - 114 - exception Decode of t 115 - (** Exception raised by [_exn] decoding functions. *) 116 - end 63 + module Error = Error 64 + (** CBOR error facade. Extends {!Loc.Error.kind} with typed CBOR kinds 65 + ({!Error.Type_mismatch}, {!Error.Missing_member}, ...), registers printers, 66 + and re-exports {!Loc.Error} verbs. See {!module:Error}. *) 117 67 118 68 (** {1:codec Codecs} *) 119 69 ··· 136 86 137 87 val int : int t 138 88 (** [int] is a codec for OCaml [int] as CBOR integer. 139 - @raise Error.Decode if the CBOR integer is out of [int] range. *) 89 + @raise Loc.Error if the CBOR integer is out of [int] range. *) 140 90 141 91 val int32 : int32 t 142 92 (** [int32] is a codec for [int32] as CBOR integer. 143 - @raise Error.Decode if the CBOR integer is out of [int32] range. *) 93 + @raise Loc.Error if the CBOR integer is out of [int32] range. *) 144 94 145 95 val int64 : int64 t 146 96 (** [int64] is a codec for [int64] as CBOR integer. *) ··· 424 374 (** [decode_string c s] decodes from CBOR bytes [s]. *) 425 375 426 376 val decode_exn : 'a t -> Bytes.Reader.t -> 'a 427 - (** [decode_exn c r] is like {!val-decode} but raises {!Error.Decode}. *) 377 + (** [decode_exn c r] is like {!val-decode} but raises {!Loc.Error}. *) 428 378 429 379 val decode_string_exn : 'a t -> string -> 'a 430 380 (** [decode_string_exn c s] is like {!decode_string} but raises. *)

+5 -1

lib/dune

··· 1 1 (library 2 2 (name cbor) 3 3 (public_name cbor) 4 - (libraries bytesrw zarith fmt)) 4 + (libraries 5 + bytesrw 6 + zarith 7 + fmt 8 + (re_export loc)))

+165

lib/error.ml

··· 1 + (*--------------------------------------------------------------------------- 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 + SPDX-License-Identifier: ISC 4 + ---------------------------------------------------------------------------*) 5 + 6 + (* CBOR error module. Extends Loc.Error with CBOR-typed error kinds and 7 + the shape-helper menu used by the codec interpreters. *) 8 + 9 + type Loc.Path.step += Cbor_key of Value.t Loc.node | Cbor_tag of int Loc.node 10 + type kind = Loc.Error.kind = .. 11 + 12 + type Loc.Error.kind += 13 + | Type_mismatch of { expected : string; got : string } 14 + | Missing_member of string 15 + | Unknown_member of string 16 + | Duplicate_member of string 17 + | Out_of_range of { value : string; range : string } 18 + | Invalid_value of string 19 + | Parse_error of string 20 + | Custom of string 21 + | Sort_mismatch of { exp : Sort.t; fnd : Sort.t } 22 + | Kinded_sort_mismatch of { exp : string; fnd : Sort.t } 23 + 24 + let pp_code ppf s = Fmt.(styled `Bold string) ppf s 25 + 26 + let () = 27 + Loc.Path.register_step_printer (function 28 + | Cbor_key (v, _) -> Some (fun ppf -> Fmt.pf ppf "[%a]" Value.pp v) 29 + | Cbor_tag (n, _) -> Some (fun ppf -> Fmt.pf ppf "<%d>" n) 30 + | _ -> None) 31 + 32 + let () = 33 + Loc.Error.register_kind_printer (function 34 + | Type_mismatch { expected; got } -> 35 + Some 36 + (fun ppf -> 37 + Fmt.pf ppf "type mismatch: expected %s, got %s" expected got) 38 + | Missing_member name -> 39 + Some (fun ppf -> Fmt.pf ppf "missing required member: %s" name) 40 + | Unknown_member name -> 41 + Some (fun ppf -> Fmt.pf ppf "unknown member: %s" name) 42 + | Duplicate_member name -> 43 + Some (fun ppf -> Fmt.pf ppf "duplicate member: %s" name) 44 + | Out_of_range { value; range } -> 45 + Some (fun ppf -> Fmt.pf ppf "value %s out of range %s" value range) 46 + | Invalid_value msg -> Some (fun ppf -> Fmt.pf ppf "invalid value: %s" msg) 47 + | Parse_error msg -> Some (fun ppf -> Fmt.pf ppf "parse error: %s" msg) 48 + | Custom msg -> Some (fun ppf -> Fmt.pf ppf "%s" msg) 49 + | Sort_mismatch { exp; fnd } -> 50 + Some 51 + (fun ppf -> 52 + Fmt.pf ppf "Expected %a but found %a" Sort.pp exp Sort.pp fnd) 53 + | Kinded_sort_mismatch { exp; fnd } -> 54 + Some 55 + (fun ppf -> 56 + Fmt.pf ppf "Expected %a but found %a" pp_code exp Sort.pp fnd) 57 + | _ -> None) 58 + 59 + type t = Loc.Error.t 60 + 61 + let kind_to_string = Loc.Error.kind_to_string 62 + let v = Loc.Error.v 63 + let make ctx kind = Loc.Error.v ~ctx ~meta:Loc.Meta.none kind 64 + let msg = Loc.Error.msg 65 + let raise = Loc.Error.raise 66 + let fail = Loc.Error.fail 67 + let failf = Loc.Error.failf 68 + let push_array = Loc.Error.push_array 69 + let push_object = Loc.Error.push_object 70 + let pp = Loc.Error.pp 71 + let to_string = Loc.Error.to_string 72 + 73 + (* Context builders: descend one step. The [sort] label in the parent 74 + frame is the CBOR container sort. *) 75 + 76 + let sort_label sort = (Sort.to_string sort, Loc.Meta.none) 77 + 78 + let ctx_with_index n ctx = 79 + Loc.Context.push ~sort:(sort_label Sort.Array) 80 + (Loc.Path.Nth (n, Loc.Meta.none)) 81 + ctx 82 + 83 + let ctx_with_key k ctx = 84 + Loc.Context.push ~sort:(sort_label Sort.Map) 85 + (Loc.Path.Mem (k, Loc.Meta.none)) 86 + ctx 87 + 88 + let ctx_with_cbor_key key ctx = 89 + Loc.Context.push ~sort:(sort_label Sort.Map) 90 + (Cbor_key (key, Loc.Meta.none)) 91 + ctx 92 + 93 + let ctx_with_tag n ctx = 94 + Loc.Context.push ~sort:(sort_label Sort.Tag) (Cbor_tag (n, Loc.Meta.none)) ctx 95 + 96 + (* Typed raising helpers. *) 97 + 98 + let type_mismatch ~ctx ~expected ~got = 99 + raise ~ctx ~meta:Loc.Meta.none (Type_mismatch { expected; got }) 100 + 101 + let missing_member ~ctx name = 102 + raise ~ctx ~meta:Loc.Meta.none (Missing_member name) 103 + 104 + let unknown_member ~ctx name = 105 + raise ~ctx ~meta:Loc.Meta.none (Unknown_member name) 106 + 107 + let duplicate_member ~ctx name = 108 + raise ~ctx ~meta:Loc.Meta.none (Duplicate_member name) 109 + 110 + let out_of_range ~ctx ~value ~range = 111 + raise ~ctx ~meta:Loc.Meta.none (Out_of_range { value; range }) 112 + 113 + let invalid_value ~ctx msg = raise ~ctx ~meta:Loc.Meta.none (Invalid_value msg) 114 + let parse_error ~ctx msg = raise ~ctx ~meta:Loc.Meta.none (Parse_error msg) 115 + let custom ~ctx msg = raise ~ctx ~meta:Loc.Meta.none (Custom msg) 116 + 117 + (* Generic shape helpers. *) 118 + 119 + let sort meta ~exp ~fnd = 120 + raise ~ctx:Loc.Context.empty ~meta (Sort_mismatch { exp; fnd }) 121 + 122 + let kinded_sort meta ~exp ~fnd = 123 + raise ~ctx:Loc.Context.empty ~meta (Kinded_sort_mismatch { exp; fnd }) 124 + 125 + let expected meta exp ~fnd = 126 + failf meta "Expected %a but found %a" pp_code exp pp_code fnd 127 + 128 + let index_out_of_range meta ~n ~len = 129 + failf meta "Index %d out of range [0;%d]" n (len - 1) 130 + 131 + let no_decoder meta ~kind = failf meta "No decoder for %a" pp_code kind 132 + let no_encoder meta ~kind = failf meta "No encoder for %a" pp_code kind 133 + 134 + let decode_todo meta ~kind_opt = 135 + if kind_opt = "" then failf meta "TODO: decode" 136 + else failf meta "TODO: decode %a" pp_code kind_opt 137 + 138 + let encode_todo meta ~kind_opt = 139 + if kind_opt = "" then failf meta "TODO: encode" 140 + else failf meta "TODO: encode %a" pp_code kind_opt 141 + 142 + (* Result-style constructors used by the result-based codec decoders. *) 143 + 144 + let make_type_mismatch ctx ~expected ~got = 145 + Error (v ~ctx ~meta:Loc.Meta.none (Type_mismatch { expected; got })) 146 + 147 + let make_missing_member ctx name = 148 + Error (v ~ctx ~meta:Loc.Meta.none (Missing_member name)) 149 + 150 + let make_unknown_member ctx name = 151 + Error (v ~ctx ~meta:Loc.Meta.none (Unknown_member name)) 152 + 153 + let make_duplicate_member ctx name = 154 + Error (v ~ctx ~meta:Loc.Meta.none (Duplicate_member name)) 155 + 156 + let make_out_of_range ctx ~value ~range = 157 + Error (v ~ctx ~meta:Loc.Meta.none (Out_of_range { value; range })) 158 + 159 + let make_invalid_value ctx msg = 160 + Error (v ~ctx ~meta:Loc.Meta.none (Invalid_value msg)) 161 + 162 + let make_parse_error ctx msg = 163 + Error (v ~ctx ~meta:Loc.Meta.none (Parse_error msg)) 164 + 165 + let make_custom ctx msg = Error (v ~ctx ~meta:Loc.Meta.none (Custom msg))

+177

lib/error.mli

··· 1 + (*--------------------------------------------------------------------------- 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 + SPDX-License-Identifier: ISC 4 + ---------------------------------------------------------------------------*) 5 + 6 + (** CBOR-specific error helpers. Extends {!Loc.Error.kind} with typed CBOR error 7 + kinds and the shape-error helper menu used by the codec. *) 8 + 9 + (** {1:steps CBOR-specific path steps} 10 + 11 + CBOR keys can be arbitrary {!Value.t}s (not just strings), and tagged values 12 + introduce a tag boundary in the path. These extensions add them to the 13 + baseline {!Loc.Path.Mem} / {!Loc.Path.Nth}. *) 14 + 15 + type Loc.Path.step += 16 + | Cbor_key of Value.t Loc.node 17 + (** Non-string map key. Printed as [[<cbor-value>]]. *) 18 + | Cbor_tag of int Loc.node (** Inside a tagged value. Printed as [<tag>]. *) 19 + 20 + (** {1:kinds Error kinds} *) 21 + 22 + type kind = Loc.Error.kind = .. 23 + (** Alias for {!Loc.Error.kind} so CBOR-specific constructors live in the same 24 + type. *) 25 + 26 + type Loc.Error.kind += 27 + | Type_mismatch of { expected : string; got : string } 28 + (** Wire/Value sort mismatch: expected one type, got another. *) 29 + | Missing_member of string (** Required map member not found. *) 30 + | Unknown_member of string (** Unexpected map member (when strict). *) 31 + | Duplicate_member of string (** Map contains duplicate key. *) 32 + | Out_of_range of { value : string; range : string } 33 + (** Value outside an acceptable range. *) 34 + | Invalid_value of string (** Value doesn't satisfy a constraint. *) 35 + | Parse_error of string (** Low-level parse error. *) 36 + | Custom of string (** User-defined error. *) 37 + | Sort_mismatch of { exp : Sort.t; fnd : Sort.t } 38 + (** Typed sort mismatch (expected Sort vs found Sort). *) 39 + | Kinded_sort_mismatch of { exp : string; fnd : Sort.t } 40 + (** Typed sort mismatch with a free-form expected description. *) 41 + 42 + val kind_to_string : kind -> string 43 + (** [kind_to_string k] renders [k] via the printers registered with 44 + {!Loc.Error.register_kind_printer}. *) 45 + 46 + (** {1:errors Errors} *) 47 + 48 + type t = Loc.Error.t 49 + (** Alias for {!Loc.Error.t}. *) 50 + 51 + val v : ctx:Loc.Context.t -> meta:Loc.Meta.t -> kind -> t 52 + (** [v ~ctx ~meta k] is a fresh error. *) 53 + 54 + val make : Loc.Context.t -> kind -> t 55 + (** [make ctx k] is [v ~ctx ~meta:Loc.Meta.none k]. Convenience for the 56 + result-based codec decoders that only carry a context. *) 57 + 58 + val msg : ctx:Loc.Context.t -> meta:Loc.Meta.t -> string -> t 59 + (** [msg ~ctx ~meta s] is an error with kind [Loc.Error.Msg s]. *) 60 + 61 + val raise : ctx:Loc.Context.t -> meta:Loc.Meta.t -> kind -> 'a 62 + (** [raise ~ctx ~meta k] raises [Loc.Error.Error (v ~ctx ~meta k)]. *) 63 + 64 + val fail : Loc.Meta.t -> string -> 'a 65 + (** [fail meta s] raises with an empty context and string [s]. *) 66 + 67 + val failf : Loc.Meta.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a 68 + (** [failf meta fmt] is {!fail} with a formatted message. *) 69 + 70 + val push_array : string Loc.node -> int Loc.node -> t -> 'a 71 + (** [push_array sort n e] re-raises [e] after pushing an array index onto its 72 + context. *) 73 + 74 + val push_object : string Loc.node -> string Loc.node -> t -> 'a 75 + (** [push_object sort n e] re-raises [e] after pushing an object member onto its 76 + context. *) 77 + 78 + val pp : t Fmt.t 79 + (** [pp] formats an error with its kind, source location and context. *) 80 + 81 + val to_string : t -> string 82 + (** [to_string e] is {!pp} as a string. *) 83 + 84 + (** {1:path Context builders} 85 + 86 + Convenience wrappers that descend a {!Loc.Context.t} one step using the 87 + CBOR-native path steps. *) 88 + 89 + val ctx_with_index : int -> Loc.Context.t -> Loc.Context.t 90 + (** [ctx_with_index n ctx] extends [ctx] with an array index [n]. *) 91 + 92 + val ctx_with_key : string -> Loc.Context.t -> Loc.Context.t 93 + (** [ctx_with_key k ctx] extends [ctx] with a text-string map key [k]. *) 94 + 95 + val ctx_with_cbor_key : Value.t -> Loc.Context.t -> Loc.Context.t 96 + (** [ctx_with_cbor_key v ctx] extends [ctx] with a non-string map key [v]. *) 97 + 98 + val ctx_with_tag : int -> Loc.Context.t -> Loc.Context.t 99 + (** [ctx_with_tag n ctx] extends [ctx] with the body of a tagged value [tag n]. 100 + *) 101 + 102 + (** {1:helpers Typed raising helpers} 103 + 104 + Named helpers for the CBOR-recurring error shapes. Each raises 105 + {!Loc.Error.Error} with the matching typed kind. *) 106 + 107 + val type_mismatch : ctx:Loc.Context.t -> expected:string -> got:string -> 'a 108 + (** [type_mismatch ~ctx ~expected ~got] raises {!Type_mismatch}. *) 109 + 110 + val missing_member : ctx:Loc.Context.t -> string -> 'a 111 + (** [missing_member ~ctx name] raises {!Missing_member}. *) 112 + 113 + val unknown_member : ctx:Loc.Context.t -> string -> 'a 114 + (** [unknown_member ~ctx name] raises {!Unknown_member}. *) 115 + 116 + val duplicate_member : ctx:Loc.Context.t -> string -> 'a 117 + (** [duplicate_member ~ctx name] raises {!Duplicate_member}. *) 118 + 119 + val out_of_range : ctx:Loc.Context.t -> value:string -> range:string -> 'a 120 + (** [out_of_range ~ctx ~value ~range] raises {!Out_of_range}. *) 121 + 122 + val invalid_value : ctx:Loc.Context.t -> string -> 'a 123 + (** [invalid_value ~ctx msg] raises {!Invalid_value}. *) 124 + 125 + val parse_error : ctx:Loc.Context.t -> string -> 'a 126 + (** [parse_error ~ctx msg] raises {!Parse_error}. *) 127 + 128 + val custom : ctx:Loc.Context.t -> string -> 'a 129 + (** [custom ~ctx msg] raises {!Custom}. *) 130 + 131 + (** {1:shape Generic shape-error helpers} *) 132 + 133 + val sort : Loc.Meta.t -> exp:Sort.t -> fnd:Sort.t -> 'a 134 + (** [sort meta ~exp ~fnd] raises {!Sort_mismatch}. *) 135 + 136 + val kinded_sort : Loc.Meta.t -> exp:string -> fnd:Sort.t -> 'a 137 + (** [kinded_sort meta ~exp ~fnd] raises {!Kinded_sort_mismatch}. *) 138 + 139 + val expected : Loc.Meta.t -> string -> fnd:string -> 'a 140 + (** [expected meta exp ~fnd] raises ["Expected exp but found fnd"]. *) 141 + 142 + val index_out_of_range : Loc.Meta.t -> n:int -> len:int -> 'a 143 + (** [index_out_of_range meta ~n ~len] raises ["Index n out of range [0;len-1]"]. 144 + *) 145 + 146 + val no_decoder : Loc.Meta.t -> kind:string -> 'a 147 + (** [no_decoder meta ~kind] raises ["No decoder for kind"]. *) 148 + 149 + val no_encoder : Loc.Meta.t -> kind:string -> 'a 150 + (** [no_encoder meta ~kind] raises ["No encoder for kind"]. *) 151 + 152 + val decode_todo : Loc.Meta.t -> kind_opt:string -> 'a 153 + (** [decode_todo meta ~kind_opt] raises ["TODO: decode kind_opt"]. *) 154 + 155 + val encode_todo : Loc.Meta.t -> kind_opt:string -> 'a 156 + (** [encode_todo meta ~kind_opt] raises ["TODO: encode kind_opt"]. *) 157 + 158 + (** {1:result Result-style constructors} 159 + 160 + Many CBOR decoders return [('a, t) result] instead of raising. These build 161 + an [Error _] value without raising. *) 162 + 163 + val make_type_mismatch : 164 + Loc.Context.t -> expected:string -> got:string -> ('a, t) result 165 + (** [make_type_mismatch ctx ~expected ~got] is 166 + [Error (v ~ctx ~meta:none (Type_mismatch {expected; got}))]. *) 167 + 168 + val make_missing_member : Loc.Context.t -> string -> ('a, t) result 169 + val make_unknown_member : Loc.Context.t -> string -> ('a, t) result 170 + val make_duplicate_member : Loc.Context.t -> string -> ('a, t) result 171 + 172 + val make_out_of_range : 173 + Loc.Context.t -> value:string -> range:string -> ('a, t) result 174 + 175 + val make_invalid_value : Loc.Context.t -> string -> ('a, t) result 176 + val make_parse_error : Loc.Context.t -> string -> ('a, t) result 177 + val make_custom : Loc.Context.t -> string -> ('a, t) result

Configure Feed

Configure Feed