ocaml-cbor: drop make_/make naming, add Sort + Error tests

+65 -61

lib/cbor.ml

··· 34 34 | Float _ -> "float" 35 35 36 36 let type_error path expected v = 37 - Error.make_type_mismatch path ~expected ~got:(type_name v) 37 + Error.type_mismatch_result path ~expected ~got:(type_name v) 38 38 39 39 (* Major type name for stream decoding errors *) 40 40 let major_type_name = function ··· 49 49 | _ -> "unknown" 50 50 51 51 let stream_type_error path expected (hdr : Binary.header) = 52 - Error.make_type_mismatch path ~expected ~got:(major_type_name hdr.major) 52 + Error.type_mismatch_result path ~expected ~got:(major_type_name hdr.major) 53 53 54 54 (* Fallback: read a Value.t from the stream, then use the Value.t decoder *) 55 55 let decode_rw_via_cbor decode path dec = ··· 155 155 if Z.fits_int n then Ok (Z.to_int n) 156 156 else 157 157 Error 158 - (Error.make path 158 + (Error.v ~ctx:path 159 159 (Error.Out_of_range 160 160 { 161 161 value = Z.to_string n; ··· 171 171 if Z.fits_int n then Ok (Z.to_int n) 172 172 else 173 173 Error 174 - (Error.make path 174 + (Error.v ~ctx:path 175 175 (Error.Out_of_range 176 176 { 177 177 value = Z.to_string n; ··· 182 182 if Z.fits_int n then Ok (Z.to_int n) 183 183 else 184 184 Error 185 - (Error.make path 185 + (Error.v ~ctx:path 186 186 (Error.Out_of_range 187 187 { 188 188 value = Z.to_string n; ··· 205 205 then Ok (Z.to_int32 n) 206 206 else 207 207 Error 208 - (Error.make path 208 + (Error.v ~ctx:path 209 209 (Error.Out_of_range 210 210 { 211 211 value = Z.to_string n; ··· 227 227 then Ok (Z.to_int32 n) 228 228 else 229 229 Error 230 - (Error.make path 230 + (Error.v ~ctx:path 231 231 (Error.Out_of_range 232 232 { 233 233 value = Z.to_string n; ··· 247 247 if Z.fits_int64 n then Ok (Z.to_int64 n) 248 248 else 249 249 Error 250 - (Error.make path 250 + (Error.v ~ctx:path 251 251 (Error.Out_of_range 252 252 { 253 253 value = Z.to_string n; ··· 266 266 if Z.fits_int64 n then Ok (Z.to_int64 n) 267 267 else 268 268 Error 269 - (Error.make path 269 + (Error.v ~ctx:path 270 270 (Error.Out_of_range 271 271 { 272 272 value = Z.to_string n; ··· 385 385 if Z.sign n >= 0 && Z.fits_int n then Ok (Z.to_int n) 386 386 else 387 387 Error 388 - (Error.make path 388 + (Error.v ~ctx:path 389 389 (Error.Out_of_range 390 390 { 391 391 value = Z.to_string n; ··· 401 401 if Z.fits_int n then Ok (Z.to_int n) 402 402 else 403 403 Error 404 - (Error.make path 404 + (Error.v ~ctx:path 405 405 (Error.Out_of_range 406 406 { 407 407 value = Z.to_string n; ··· 410 410 | 1 -> 411 411 let n = Z.neg (Z.succ (Binary.read_argument_z dec hdr)) in 412 412 Error 413 - (Error.make path 413 + (Error.v ~ctx:path 414 414 (Error.Out_of_range 415 415 { value = Z.to_string n; range = Fmt.str "[0, %d]" max_int })) 416 416 | _ -> stream_type_error path "integer" hdr); ··· 428 428 Ok (Z.to_int32 n) 429 429 else 430 430 Error 431 - (Error.make path 431 + (Error.v ~ctx:path 432 432 (Error.Out_of_range 433 433 { value = Z.to_string n; range = "[0, 4294967295]" })) 434 434 | _ -> type_error path "integer" v); ··· 445 445 Ok (Z.to_int32 n) 446 446 else 447 447 Error 448 - (Error.make path 448 + (Error.v ~ctx:path 449 449 (Error.Out_of_range 450 450 { value = Z.to_string n; range = "[0, 4294967295]" })) 451 451 | _ -> stream_type_error path "integer" hdr); ··· 462 462 if Z.sign n >= 0 && Z.fits_int64 n then Ok (Z.to_int64 n) 463 463 else 464 464 Error 465 - (Error.make path 465 + (Error.v ~ctx:path 466 466 (Error.Out_of_range 467 467 { value = Z.to_string n; range = "[0, 2^63-1]" })) 468 468 | _ -> type_error path "integer" v); ··· 478 478 if Z.sign n >= 0 && Z.fits_int64 n then Ok (Z.to_int64 n) 479 479 else 480 480 Error 481 - (Error.make path 481 + (Error.v ~ctx:path 482 482 (Error.Out_of_range 483 483 { value = Z.to_string n; range = "[0, 2^63-1]" })) 484 484 | _ -> stream_type_error path "integer" hdr); ··· 572 572 loop 0 [] items 573 573 | Value.Array items -> 574 574 Error 575 - (Error.make path 575 + (Error.v ~ctx:path 576 576 (Error.Invalid_value 577 577 (Fmt.str "expected array of length %d, got %d" len 578 578 (List.length items)))) ··· 588 588 Binary.skip dec 589 589 done; 590 590 Error 591 - (Error.make path 591 + (Error.v ~ctx:path 592 592 (Error.Invalid_value 593 593 (Fmt.str "expected array of length %d, got %d" len n))) 594 594 | Ok None -> ( ··· 597 597 | Ok items when List.length items = len -> Ok items 598 598 | Ok items -> 599 599 Error 600 - (Error.make path 600 + (Error.v ~ctx:path 601 601 (Error.Invalid_value 602 602 (Fmt.str "expected array of length %d, got %d" len 603 603 (List.length items)))) ··· 620 620 | Ok b -> Ok (a, b))) 621 621 | Value.Array _ -> 622 622 Error 623 - (Error.make path (Error.Invalid_value "expected 2-element array")) 623 + (Error.v ~ctx:path 624 + (Error.Invalid_value "expected 2-element array")) 624 625 | _ -> type_error path "array" v); 625 626 decode_rw = 626 627 (fun path dec -> ··· 635 636 | Ok b -> Ok (a, b))) 636 637 | Ok (Some _n) -> 637 638 Error 638 - (Error.make path (Error.Invalid_value "expected 2-element array")) 639 + (Error.v ~ctx:path 640 + (Error.Invalid_value "expected 2-element array")) 639 641 | Ok None -> 640 642 Error 641 - (Error.make path (Error.Invalid_value "expected 2-element array"))); 643 + (Error.v ~ctx:path 644 + (Error.Invalid_value "expected 2-element array"))); 642 645 } 643 646 644 647 let tuple3 ca cb cc = ··· 661 664 | Ok c -> Ok (a, b, c)))) 662 665 | Value.Array _ -> 663 666 Error 664 - (Error.make path (Error.Invalid_value "expected 3-element array")) 667 + (Error.v ~ctx:path 668 + (Error.Invalid_value "expected 3-element array")) 665 669 | _ -> type_error path "array" v); 666 670 decode_rw = 667 671 (fun path dec -> ··· 679 683 | Ok c -> Ok (a, b, c)))) 680 684 | Ok (Some _n) -> 681 685 Error 682 - (Error.make path (Error.Invalid_value "expected 3-element array")) 686 + (Error.v ~ctx:path 687 + (Error.Invalid_value "expected 3-element array")) 683 688 | Ok None -> 684 689 Error 685 - (Error.make path (Error.Invalid_value "expected 3-element array"))); 690 + (Error.v ~ctx:path 691 + (Error.Invalid_value "expected 3-element array"))); 686 692 } 687 693 688 694 let tuple4 ca cb cc cd = 695 + let bad_arity path = 696 + Error (Error.v ~ctx:path (Error.Invalid_value "expected 4-element array")) 697 + in 689 698 { 690 699 kind = Fmt.str "tuple4(%s, %s, %s, %s)" ca.kind cb.kind cc.kind cd.kind; 691 700 encode = ··· 707 716 match cd.decode (Error.ctx_with_index 3 path) vd with 708 717 | Error e -> Error e 709 718 | Ok d -> Ok (a, b, c, d))))) 710 - | Value.Array _ -> 711 - Error 712 - (Error.make path (Error.Invalid_value "expected 4-element array")) 719 + | Value.Array _ -> bad_arity path 713 720 | _ -> type_error path "array" v); 714 721 decode_rw = 715 722 (fun path dec -> ··· 730 737 with 731 738 | Error e -> Error e 732 739 | Ok d -> Ok (a, b, c, d))))) 733 - | Ok (Some _n) -> 734 - Error 735 - (Error.make path (Error.Invalid_value "expected 4-element array")) 736 - | Ok None -> 737 - Error 738 - (Error.make path (Error.Invalid_value "expected 4-element array"))); 740 + | Ok (Some _) | Ok None -> bad_arity path); 739 741 } 740 742 741 743 (* Maps *) ··· 887 889 | Return a -> Ok (a, pairs) 888 890 | Mem { name; codec; cont; _ } -> ( 889 891 match find_remove name pairs with 890 - | None, _ -> Error (Error.make path (Error.Missing_member name)) 892 + | None, _ -> Error (Error.v ~ctx:path (Error.Missing_member name)) 891 893 | Some v, remaining -> ( 892 894 let path' = Error.ctx_with_key name path in 893 895 match codec.decode path' v with ··· 1026 1028 | Return a -> Ok a 1027 1029 | Mem { name; cont; _ } -> ( 1028 1030 match Hashtbl.find_opt tbl name with 1029 - | None -> Error (Error.make path (Error.Missing_member name)) 1031 + | None -> Error (Error.v ~ctx:path (Error.Missing_member name)) 1030 1032 | Some obj -> resolve_mem path tbl (cont (Stdlib.Obj.obj obj))) 1031 1033 | Mem_opt { name; cont; _ } -> ( 1032 1034 match Hashtbl.find_opt tbl name with ··· 1207 1209 | Mem { key; codec; cont; _ } -> ( 1208 1210 match find_remove key pairs with 1209 1211 | None, _ -> 1210 - Error (Error.make path (Error.Missing_member (string_of_int key))) 1212 + Error (Error.v ~ctx:path (Error.Missing_member (string_of_int key))) 1211 1213 | Some v, remaining -> ( 1212 1214 let path' = Error.ctx_with_key (string_of_int key) path in 1213 1215 match codec.decode path' v with ··· 1339 1341 | Mem { key; cont; _ } -> ( 1340 1342 match Hashtbl.find_opt tbl key with 1341 1343 | None -> 1342 - Error (Error.make path (Error.Missing_member (string_of_int key))) 1344 + Error (Error.v ~ctx:path (Error.Missing_member (string_of_int key))) 1343 1345 | Some obj -> resolve_mem path tbl (cont (Stdlib.Obj.obj obj))) 1344 1346 | Mem_opt { key; cont; _ } -> ( 1345 1347 match Hashtbl.find_opt tbl key with ··· 1458 1460 c.decode (Error.ctx_with_tag n path) content 1459 1461 | Value.Tag (m, _) -> 1460 1462 Error 1461 - (Error.make path 1463 + (Error.v ~ctx:path 1462 1464 (Error.Invalid_value 1463 1465 (Fmt.str "expected tag %d, got tag %d" n m))) 1464 1466 | _ -> type_error path (Fmt.str "tag(%d)" n) v); ··· 1470 1472 if m = n then c.decode_rw (Error.ctx_with_tag n path) dec 1471 1473 else 1472 1474 Error 1473 - (Error.make path 1475 + (Error.v ~ctx:path 1474 1476 (Error.Invalid_value 1475 1477 (Fmt.str "expected tag %d, got tag %d" n m))) 1476 1478 else stream_type_error path (Fmt.str "tag(%d)" n) hdr); ··· 1530 1532 | Ok x -> ( 1531 1533 match decode_f x with 1532 1534 | Ok y -> Ok y 1533 - | Error msg -> Error (Error.make path (Error.Custom msg)))); 1535 + | Error msg -> Error (Error.v ~ctx:path (Error.Custom msg)))); 1534 1536 decode_rw = 1535 1537 (fun path dec -> 1536 1538 match c.decode_rw path dec with ··· 1538 1540 | Ok x -> ( 1539 1541 match decode_f x with 1540 1542 | Ok y -> Ok y 1541 - | Error msg -> Error (Error.make path (Error.Custom msg)))); 1543 + | Error msg -> Error (Error.v ~ctx:path (Error.Custom msg)))); 1542 1544 } 1543 1545 1544 1546 let const v c = ··· 1585 1587 let rec try_cases = function 1586 1588 | [] -> 1587 1589 Error 1588 - (Error.make path 1590 + (Error.v ~ctx:path 1589 1591 (Error.Invalid_value 1590 1592 (Fmt.str "unknown tag %d in variant" tag))) 1591 1593 | Case (t, c, inject, _) :: _rest when t = tag -> ( ··· 1607 1609 | [] -> 1608 1610 Binary.skip dec; 1609 1611 Error 1610 - (Error.make path 1612 + (Error.v ~ctx:path 1611 1613 (Error.Invalid_value 1612 1614 (Fmt.str "unknown tag %d in variant" tag))) 1613 1615 | Case (t, c, inject, _) :: _rest when t = tag -> ( ··· 1654 1656 let rec try_cases = function 1655 1657 | [] -> 1656 1658 Error 1657 - (Error.make path 1659 + (Error.v ~ctx:path 1658 1660 (Error.Invalid_value 1659 1661 (Fmt.str "unknown key %S in variant" key))) 1660 1662 | Case (k, c, inject, _) :: _rest when k = key -> ( ··· 1667 1669 try_cases cases 1668 1670 | Value.Map _ -> 1669 1671 Error 1670 - (Error.make path 1672 + (Error.v ~ctx:path 1671 1673 (Error.Invalid_value "variant map must have exactly one key")) 1672 1674 | _ -> type_error path "map" v); 1673 1675 decode_rw = ··· 1682 1684 Binary.skip dec; 1683 1685 Binary.skip dec; 1684 1686 Error 1685 - (Error.make path 1687 + (Error.v ~ctx:path 1686 1688 (Error.Invalid_value "variant map key must be text")) 1687 1689 | _ -> 1688 1690 let key = Binary.read_text dec in ··· 1690 1692 | [] -> 1691 1693 Binary.skip dec; 1692 1694 Error 1693 - (Error.make path 1695 + (Error.v ~ctx:path 1694 1696 (Error.Invalid_value 1695 1697 (Fmt.str "unknown key %S in variant" key))) 1696 1698 | Case (k, c, inject, _) :: _rest when k = key -> ( ··· 1710 1712 Binary.skip dec 1711 1713 done; 1712 1714 Error 1713 - (Error.make path 1715 + (Error.v ~ctx:path 1714 1716 (Error.Invalid_value "variant map must have exactly one key")) 1715 1717 | Ok None -> ( 1716 1718 if ··· 1719 1721 then ( 1720 1722 Binary.skip_break dec; 1721 1723 Error 1722 - (Error.make path 1724 + (Error.v ~ctx:path 1723 1725 (Error.Invalid_value 1724 1726 "variant map must have exactly one key"))) 1725 1727 else ··· 1735 1737 done; 1736 1738 Binary.skip_break dec; 1737 1739 Error 1738 - (Error.make path 1740 + (Error.v ~ctx:path 1739 1741 (Error.Invalid_value "variant map key must be text")) 1740 1742 | _ -> 1741 1743 let key = Binary.read_text dec in ··· 1744 1746 | [] -> 1745 1747 Binary.skip dec; 1746 1748 Error 1747 - (Error.make path 1749 + (Error.v ~ctx:path 1748 1750 (Error.Invalid_value 1749 1751 (Fmt.str "unknown key %S in variant" key))) 1750 1752 | Case (k, c, inject, _) :: _rest when k = key -> ( ··· 1770 1772 Binary.skip_break dec; 1771 1773 if !extra > 0 then 1772 1774 Error 1773 - (Error.make path 1775 + (Error.v ~ctx:path 1774 1776 (Error.Invalid_value 1775 1777 "variant map must have exactly one key")) 1776 1778 else result)); ··· 1800 1802 match v with 1801 1803 | Value.Map pairs -> 1802 1804 let rec find = function 1803 - | [] -> Error (Error.make path (Error.Missing_member name)) 1805 + | [] -> Error (Error.v ~ctx:path (Error.Missing_member name)) 1804 1806 | (Value.Text k, value) :: _ when k = name -> 1805 1807 c.decode (Error.ctx_with_key name path) value 1806 1808 | _ :: rest -> find rest ··· 1823 1825 let key_cbor = Value.Int (Z.of_int key) in 1824 1826 let rec find = function 1825 1827 | [] -> 1826 - Error (Error.make path (Error.Missing_member (string_of_int key))) 1828 + Error 1829 + (Error.v ~ctx:path (Error.Missing_member (string_of_int key))) 1827 1830 | (k, value) :: _ when Value.equal k key_cbor -> 1828 1831 c.decode (Error.ctx_with_key (string_of_int key) path) value 1829 1832 | _ :: rest -> find rest ··· 1846 1849 match List.nth_opt items n with 1847 1850 | None -> 1848 1851 Error 1849 - (Error.make path 1852 + (Error.v ~ctx:path 1850 1853 (Error.Out_of_range 1851 1854 { 1852 1855 value = string_of_int n; ··· 1877 1880 let rec find found acc = function 1878 1881 | [] -> 1879 1882 if found then Ok (Value.Map (List.rev acc)) 1880 - else Error (Error.make path (Error.Missing_member name)) 1883 + else Error (Error.v ~ctx:path (Error.Missing_member name)) 1881 1884 | (Value.Text k, value) :: rest when k = name -> ( 1882 1885 match c.decode (Error.ctx_with_key name path) value with 1883 1886 | Error e -> Error e ··· 1933 1936 match Binary.peek_byte dec with 1934 1937 | Some _ -> 1935 1938 Error 1936 - (Error.make Loc.Context.empty 1939 + (Error.v ~ctx:Loc.Context.empty 1937 1940 (Error.Parse_error 1938 1941 (Fmt.str "trailing bytes at position %d" 1939 1942 (Binary.decoder_position dec)))) 1940 1943 | None -> result) 1941 1944 with 1942 - | Failure msg -> Error (Error.make Loc.Context.empty (Error.Parse_error msg)) 1945 + | Failure msg -> 1946 + Error (Error.v ~ctx:Loc.Context.empty (Error.Parse_error msg)) 1943 1947 | Invalid_argument msg -> 1944 - Error (Error.make Loc.Context.empty (Error.Parse_error msg)) 1948 + Error (Error.v ~ctx:Loc.Context.empty (Error.Parse_error msg)) 1945 1949 | End_of_file -> 1946 1950 Error 1947 - (Error.make Loc.Context.empty 1951 + (Error.v ~ctx:Loc.Context.empty 1948 1952 (Error.Parse_error "unexpected end of input")) 1949 1953 1950 1954 let decode_exn c reader =

+11 -21

lib/error.ml

··· 59 59 type t = Loc.Error.t 60 60 61 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 62 + let v ~ctx ?(meta = Loc.Meta.none) kind = Loc.Error.v ~ctx ~meta kind 64 63 let msg = Loc.Error.msg 65 64 let raise = Loc.Error.raise 66 65 let fail = Loc.Error.fail ··· 141 140 142 141 (* Result-style constructors used by the result-based codec decoders. *) 143 142 144 - let make_type_mismatch ctx ~expected ~got = 145 - Error (v ~ctx ~meta:Loc.Meta.none (Type_mismatch { expected; got })) 143 + let type_mismatch_result ctx ~expected ~got = 144 + Error (v ~ctx (Type_mismatch { expected; got })) 146 145 147 - let make_missing_member ctx name = 148 - Error (v ~ctx ~meta:Loc.Meta.none (Missing_member name)) 146 + let missing_member_result ctx name = Error (v ~ctx (Missing_member name)) 147 + let unknown_member_result ctx name = Error (v ~ctx (Unknown_member name)) 148 + let duplicate_member_result ctx name = Error (v ~ctx (Duplicate_member name)) 149 149 150 - let make_unknown_member ctx name = 151 - Error (v ~ctx ~meta:Loc.Meta.none (Unknown_member name)) 150 + let out_of_range_result ctx ~value ~range = 151 + Error (v ~ctx (Out_of_range { value; range })) 152 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)) 153 + let invalid_value_result ctx msg = Error (v ~ctx (Invalid_value msg)) 154 + let parse_error_result ctx msg = Error (v ~ctx (Parse_error msg)) 155 + let custom_result ctx msg = Error (v ~ctx (Custom msg))

+29 -16

lib/error.mli

··· 48 48 type t = Loc.Error.t 49 49 (** Alias for {!Loc.Error.t}. *) 50 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. *) 51 + val v : ctx:Loc.Context.t -> ?meta:Loc.Meta.t -> kind -> t 52 + (** [v ~ctx ?meta k] is a fresh error. [meta] defaults to {!Loc.Meta.none}, 53 + which is the right choice for result-based codec decoders that only carry a 54 + context. *) 57 55 58 56 val msg : ctx:Loc.Context.t -> meta:Loc.Meta.t -> string -> t 59 57 (** [msg ~ctx ~meta s] is an error with kind [Loc.Error.Msg s]. *) ··· 160 158 Many CBOR decoders return [('a, t) result] instead of raising. These build 161 159 an [Error _] value without raising. *) 162 160 163 - val make_type_mismatch : 161 + val type_mismatch_result : 164 162 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}))]. *) 163 + (** [type_mismatch_result ctx ~expected ~got] is 164 + [Error (v ~ctx (Type_mismatch {expected; got}))]. *) 167 165 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 166 + val missing_member_result : Loc.Context.t -> string -> ('a, t) result 167 + (** [missing_member_result ctx name] is [Error (v ~ctx (Missing_member name))]. 168 + *) 169 + 170 + val unknown_member_result : Loc.Context.t -> string -> ('a, t) result 171 + (** [unknown_member_result ctx name] is [Error (v ~ctx (Unknown_member name))]. 172 + *) 173 + 174 + val duplicate_member_result : Loc.Context.t -> string -> ('a, t) result 175 + (** [duplicate_member_result ctx name] is 176 + [Error (v ~ctx (Duplicate_member name))]. *) 171 177 172 - val make_out_of_range : 178 + val out_of_range_result : 173 179 Loc.Context.t -> value:string -> range:string -> ('a, t) result 180 + (** [out_of_range_result ctx ~value ~range] is 181 + [Error (v ~ctx (Out_of_range {value; range}))]. *) 182 + 183 + val invalid_value_result : Loc.Context.t -> string -> ('a, t) result 184 + (** [invalid_value_result ctx msg] is [Error (v ~ctx (Invalid_value msg))]. *) 174 185 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 186 + val parse_error_result : Loc.Context.t -> string -> ('a, t) result 187 + (** [parse_error_result ctx msg] is [Error (v ~ctx (Parse_error msg))]. *) 188 + 189 + val custom_result : Loc.Context.t -> string -> ('a, t) result 190 + (** [custom_result ctx msg] is [Error (v ~ctx (Custom msg))]. *)

+1 -1

test/dune

··· 1 1 (test 2 2 (name test) 3 - (libraries nox-cbor alcotest bytesrw zarith ohex fmt) 3 + (libraries nox-cbor alcotest astring bytesrw zarith ohex fmt) 4 4 (deps 5 5 (source_tree ../test-vectors)))

+8 -1

test/test.ml

··· 1 1 let () = 2 - Alcotest.run "cbor" [ Test_cbor.suite; Test_value.suite; Test_binary.suite ] 2 + Alcotest.run "cbor" 3 + [ 4 + Test_cbor.suite; 5 + Test_value.suite; 6 + Test_binary.suite; 7 + Test_sort.suite; 8 + Test_error.suite; 9 + ]

+97

test/test_error.ml

··· 1 + (** Tests for {!Cbor.Error}. *) 2 + 3 + let check_is_error label = function 4 + | Ok _ -> Alcotest.fail (label ^ ": expected Error, got Ok") 5 + | Error _ -> () 6 + 7 + let test_v_default_meta () = 8 + let e = 9 + Cbor.Error.v ~ctx:Loc.Context.empty (Cbor.Error.Invalid_value "boom") 10 + in 11 + let s = Cbor.Error.to_string e in 12 + Alcotest.(check bool) 13 + "to_string mentions the invalid_value payload" true 14 + (Astring.String.is_infix ~affix:"boom" s) 15 + 16 + let test_kind_to_string () = 17 + Alcotest.(check string) 18 + "Type_mismatch is rendered by the registered printer" 19 + "type mismatch: expected uint, got text" 20 + (Cbor.Error.kind_to_string 21 + (Cbor.Error.Type_mismatch { expected = "uint"; got = "text" })) 22 + 23 + let test_type_mismatch_result () = 24 + let r = 25 + Cbor.Error.type_mismatch_result Loc.Context.empty ~expected:"uint" 26 + ~got:"text" 27 + in 28 + check_is_error "type_mismatch_result" r; 29 + match r with 30 + | Error e -> 31 + Alcotest.(check bool) 32 + "result error carries the typed kind" true 33 + (Astring.String.is_infix ~affix:"uint" (Cbor.Error.to_string e)) 34 + | Ok _ -> () 35 + 36 + let test_missing_member_result () = 37 + let r = Cbor.Error.missing_member_result Loc.Context.empty "subject" in 38 + check_is_error "missing_member_result" r; 39 + match r with 40 + | Error e -> 41 + Alcotest.(check bool) 42 + "missing_member result mentions the member name" true 43 + (Astring.String.is_infix ~affix:"subject" (Cbor.Error.to_string e)) 44 + | Ok _ -> () 45 + 46 + let test_unknown_member_result () = 47 + let r = Cbor.Error.unknown_member_result Loc.Context.empty "extra" in 48 + check_is_error "unknown_member_result" r 49 + 50 + let test_duplicate_member_result () = 51 + let r = Cbor.Error.duplicate_member_result Loc.Context.empty "twice" in 52 + check_is_error "duplicate_member_result" r 53 + 54 + let test_out_of_range_result () = 55 + let r = 56 + Cbor.Error.out_of_range_result Loc.Context.empty ~value:"42" ~range:"[0,10]" 57 + in 58 + check_is_error "out_of_range_result" r; 59 + match r with 60 + | Error e -> 61 + let s = Cbor.Error.to_string e in 62 + Alcotest.(check bool) 63 + "out_of_range result mentions value and range" true 64 + (Astring.String.is_infix ~affix:"42" s 65 + && Astring.String.is_infix ~affix:"10" s) 66 + | Ok _ -> () 67 + 68 + let test_invalid_value_result () = 69 + check_is_error "invalid_value_result" 70 + (Cbor.Error.invalid_value_result Loc.Context.empty "bad") 71 + 72 + let test_parse_error_result () = 73 + check_is_error "parse_error_result" 74 + (Cbor.Error.parse_error_result Loc.Context.empty "trailing bytes") 75 + 76 + let test_custom_result () = 77 + check_is_error "custom_result" 78 + (Cbor.Error.custom_result Loc.Context.empty "user-defined") 79 + 80 + let suite = 81 + ( "error", 82 + [ 83 + Alcotest.test_case "v with default meta" `Quick test_v_default_meta; 84 + Alcotest.test_case "kind_to_string for Type_mismatch" `Quick 85 + test_kind_to_string; 86 + Alcotest.test_case "type_mismatch_result" `Quick test_type_mismatch_result; 87 + Alcotest.test_case "missing_member_result" `Quick 88 + test_missing_member_result; 89 + Alcotest.test_case "unknown_member_result" `Quick 90 + test_unknown_member_result; 91 + Alcotest.test_case "duplicate_member_result" `Quick 92 + test_duplicate_member_result; 93 + Alcotest.test_case "out_of_range_result" `Quick test_out_of_range_result; 94 + Alcotest.test_case "invalid_value_result" `Quick test_invalid_value_result; 95 + Alcotest.test_case "parse_error_result" `Quick test_parse_error_result; 96 + Alcotest.test_case "custom_result" `Quick test_custom_result; 97 + ] )

+4

test/test_error.mli

··· 1 + (** Alcotest suite for {!Cbor.Error}. *) 2 + 3 + val suite : string * unit Alcotest.test_case list 4 + (** [suite] is the {!Cbor.Error} test suite. *)

+83

test/test_sort.ml

··· 1 + (** Tests for {!Cbor.Sort}. *) 2 + 3 + let test_to_string () = 4 + let pairs = 5 + [ 6 + (Cbor.Sort.Unsigned, "unsigned integer"); 7 + (Cbor.Sort.Negative, "negative integer"); 8 + (Cbor.Sort.Bytes, "byte string"); 9 + (Cbor.Sort.Text, "text string"); 10 + (Cbor.Sort.Array, "array"); 11 + (Cbor.Sort.Map, "map"); 12 + (Cbor.Sort.Tag, "tag"); 13 + (Cbor.Sort.Bool, "boolean"); 14 + (Cbor.Sort.Null, "null"); 15 + (Cbor.Sort.Undefined, "undefined"); 16 + (Cbor.Sort.Simple, "simple value"); 17 + (Cbor.Sort.Float, "float"); 18 + ] 19 + in 20 + List.iter 21 + (fun (s, expected) -> 22 + Alcotest.(check string) expected expected (Cbor.Sort.to_string s)) 23 + pairs 24 + 25 + let test_pp_matches_to_string () = 26 + List.iter 27 + (fun s -> 28 + Alcotest.(check string) 29 + (Cbor.Sort.to_string s) (Cbor.Sort.to_string s) 30 + (Fmt.str "%a" Cbor.Sort.pp s)) 31 + [ 32 + Unsigned; 33 + Negative; 34 + Bytes; 35 + Text; 36 + Array; 37 + Map; 38 + Tag; 39 + Bool; 40 + Null; 41 + Undefined; 42 + Simple; 43 + Float; 44 + ] 45 + 46 + let test_or_kind_picks_kind () = 47 + Alcotest.(check string) 48 + "non-empty kind wins over the sort name" "my-tag" 49 + (Cbor.Sort.or_kind ~kind:"my-tag" Cbor.Sort.Tag) 50 + 51 + let test_or_kind_falls_back () = 52 + Alcotest.(check string) 53 + "empty kind falls back to the sort name" "tag" 54 + (Cbor.Sort.or_kind ~kind:"" Cbor.Sort.Tag) 55 + 56 + let test_kinded'_combines () = 57 + Alcotest.(check string) 58 + "kind prefix is space-separated when non-empty" "header value" 59 + (Cbor.Sort.kinded' ~kind:"header" "value"); 60 + Alcotest.(check string) 61 + "empty kind drops the prefix" "value" 62 + (Cbor.Sort.kinded' ~kind:"" "value") 63 + 64 + let test_kinded_combines () = 65 + Alcotest.(check string) 66 + "kinded prepends to the sort name" "id text string" 67 + (Cbor.Sort.kinded ~kind:"id" Cbor.Sort.Text) 68 + 69 + let suite = 70 + ( "sort", 71 + [ 72 + Alcotest.test_case "to_string covers every constructor" `Quick 73 + test_to_string; 74 + Alcotest.test_case "pp matches to_string" `Quick test_pp_matches_to_string; 75 + Alcotest.test_case "or_kind picks kind when non-empty" `Quick 76 + test_or_kind_picks_kind; 77 + Alcotest.test_case "or_kind falls back to to_string when empty" `Quick 78 + test_or_kind_falls_back; 79 + Alcotest.test_case "kinded' combines kind and string" `Quick 80 + test_kinded'_combines; 81 + Alcotest.test_case "kinded combines kind and sort" `Quick 82 + test_kinded_combines; 83 + ] )

+4

test/test_sort.mli

··· 1 + (** Alcotest suite for {!Cbor.Sort}. *) 2 + 3 + val suite : string * unit Alcotest.test_case list 4 + (** [suite] is the {!Cbor.Sort} test suite. *)

Configure Feed

Configure Feed