json: move Codec combinators into codec.ml · gazagnaire.org/ocaml-json@a80edc2

+26 -23

lib/brr/json_brr.ml

··· 57 57 58 58 (* Decoding *) 59 59 60 - let error_push_array map i e = 61 - Json.Codec.error_push_array Json.Meta.none map (i, Json.Meta.none) e 60 + let fail_push_array map i e = 61 + Json.Codec.fail_push_array Json.Meta.none map (i, Json.Meta.none) e 62 62 63 - let error_push_object map n e = 64 - Json.Codec.error_push_object Json.Meta.none map (n, Json.Meta.none) e 63 + let fail_push_object map n e = 64 + Json.Codec.fail_push_object Json.Meta.none map (n, Json.Meta.none) e 65 65 66 - let type_error t ~fnd = Json.Codec.type_error Json.Meta.none t ~fnd 66 + let fail_type_mismatch t ~fnd = 67 + Json.Codec.fail_type_mismatch Json.Meta.none t ~fnd 67 68 68 69 let all_unexpected ~mem_decs mems = 69 70 let unexpected (n, _jname) = ··· 79 80 | Null map -> ( 80 81 match jv_sort jv with 81 82 | Null -> map.dec Json.Meta.none () 82 - | fnd -> type_error t ~fnd) 83 + | fnd -> fail_type_mismatch t ~fnd) 83 84 | Bool map -> ( 84 85 match jv_sort jv with 85 86 | Bool -> map.dec Json.Meta.none (Jv.to_bool jv) 86 - | fnd -> type_error t ~fnd) 87 + | fnd -> fail_type_mismatch t ~fnd) 87 88 | Number map -> ( 88 89 match jv_sort jv with 89 90 | Number -> map.dec Json.Meta.none (Jv.to_float jv) 90 91 | Null -> map.dec Json.Meta.none Float.nan 91 - | fnd -> type_error t ~fnd) 92 + | fnd -> fail_type_mismatch t ~fnd) 92 93 | String map -> ( 93 94 match jv_sort jv with 94 95 | String -> map.dec Json.Meta.none (Jv.to_string jv) 95 - | fnd -> type_error t ~fnd) 96 + | fnd -> fail_type_mismatch t ~fnd) 96 97 | Array map -> ( 97 98 match jv_sort jv with 98 99 | Array -> decode_array map jv 99 - | fnd -> type_error t ~fnd) 100 + | fnd -> fail_type_mismatch t ~fnd) 100 101 | Object map -> ( 101 102 match jv_sort jv with 102 103 | Object -> decode_object map jv 103 - | fnd -> type_error t ~fnd) 104 + | fnd -> fail_type_mismatch t ~fnd) 104 105 | Map map -> map.dec (decode map.dom jv) 105 106 | Any map -> decode_any t map jv 106 107 | Rec t -> decode (Lazy.force t) jv ··· 114 115 try 115 116 if map.dec_skip i !b then () 116 117 else b := map.dec_add i (decode map.elt (Jv.Jarray.get jv i)) !b 117 - with Json.Error e -> error_push_array map i e 118 + with Json.Error e -> fail_push_array map i e 118 119 done; 119 120 map.dec_finish Json.Meta.none len !b 120 121 ··· 184 185 | Some (Mem_dec m) -> 185 186 let dict = 186 187 try Dict.add m.id (decode m.type' (Jv.get' jv jname)) dict 187 - with Json.Error e -> error_push_object map n e 188 + with Json.Error e -> fail_push_object map n e 188 189 in 189 190 let mem_decs = String_map.remove n mem_decs in 190 191 decode_object_basic map umems umap mem_decs dict names jv ··· 194 195 decode_object_basic map umems umap mem_decs dict names jv 195 196 | Unknown_error -> 196 197 let fnd = (n, Json.Meta.none) :: all_unexpected ~mem_decs names in 197 - Json.Codec.unexpected_mems_error Json.Meta.none map ~fnd 198 + Json.Codec.fail_unexpected_members Json.Meta.none map ~fnd 198 199 | Unknown_keep (mmap, _) -> 199 200 let umap = 200 201 let v = 201 202 try decode mmap.mems_type (Jv.get' jv jname) 202 - with Json.Error e -> error_push_object map n e 203 + with Json.Error e -> fail_push_object map n e 203 204 in 204 205 mmap.dec_add Json.Meta.none n v umap 205 206 in ··· 218 219 let decode_case_tag tag = 219 220 let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in 220 221 match List.find_opt eq_tag cases.cases with 221 - | None -> Json.Codec.unexpected_case_tag_error Json.Meta.none map cases tag 222 + | None -> Json.Codec.fail_unexpected_case_tag Json.Meta.none map cases tag 222 223 | Some (Case case) -> 223 224 let mems = String_map.remove cases.tag.name names in 224 225 let dict = ··· 229 230 match String_map.find_opt cases.tag.name names with 230 231 | Some jname -> ( 231 232 try decode_case_tag (decode cases.tag.type' (Jv.get' jv jname)) 232 - with Json.Error e -> error_push_object map cases.tag.name e) 233 + with Json.Error e -> fail_push_object map cases.tag.name e) 233 234 | None -> ( 234 235 match cases.tag.dec_absent with 235 236 | Some tag -> decode_case_tag tag 236 237 | None -> 237 238 let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in 238 239 let fnd = jv_mem_name_list jv in 239 - Json.Codec.missing_mems_error Json.Meta.none map ~exp ~fnd) 240 + Json.Codec.fail_missing_members Json.Meta.none map ~exp ~fnd) 240 241 241 242 and decode_any : type a. a t -> a any_map -> Jv.t -> a = 242 243 fun t map jv -> 243 244 let case t map sort jv = 244 - match map with Some t -> decode t jv | None -> type_error t ~fnd:sort 245 + match map with 246 + | Some t -> decode t jv 247 + | None -> fail_type_mismatch t ~fnd:sort 245 248 in 246 249 match jv_sort jv with 247 250 | Null as s -> case t map.dec_null s jv ··· 267 270 try 268 271 Jv.Jarray.set a i (encode map.elt vi); 269 272 a 270 - with Json.Error e -> error_push_array map i e 273 + with Json.Error e -> fail_push_array map i e 271 274 in 272 275 map.enc (add map) (Jv.Jarray.create 0) v 273 276 | Object map -> encode_object map ~do_unknown:true v (Jv.obj [||]) ··· 286 289 else ( 287 290 Jv.set' jv (Jstr.of_string mmap.name) (encode mmap.type' v); 288 291 jv) 289 - with Json.Error e -> error_push_object map mmap.name e 292 + with Json.Error e -> fail_push_object map mmap.name e 290 293 in 291 294 let jv = List.fold_left (encode_mem map o) jv map.mem_encs in 292 295 match map.shape with ··· 302 305 let tag = encode cases.tag.type' case.tag in 303 306 Jv.set' jv (Jstr.of_string cases.tag.name) tag; 304 307 jv 305 - with Json.Error e -> error_push_object map cases.tag.name e 308 + with Json.Error e -> fail_push_object map cases.tag.name e 306 309 in 307 310 match u with 308 311 | Some (Unknown_keep (umap, enc)) -> ··· 317 320 try 318 321 Jv.set' jv (Jstr.of_string name) (encode umap.mems_type v); 319 322 jv 320 - with Json.Error e -> error_push_object map name e 323 + with Json.Error e -> fail_push_object map name e 321 324 in 322 325 umap.enc (encode_mem map) mems jv 323 326

+1600 -13

lib/codec.ml

··· 10 10 module Sort = Sort 11 11 module String_map = Map.Make (String) 12 12 13 + exception Error = Loc.Error 14 + 13 15 type 'a node = 'a * Meta.t 14 16 15 17 type ('ret, 'f) dec_fun = ··· 255 257 256 258 let pp_code = Fmt.code 257 259 let pp_kind = Fmt.code 260 + let pp_int ppf i = Fmt.code ppf (Int.to_string i) 258 261 259 - let error_push_object meta map name e = 260 - Error.push_object (object_kinded_sort map, meta) name e 262 + let fail_push_object meta map name e = 263 + Error.fail_push_object (object_kinded_sort map, meta) name e 261 264 262 - let error_push_array meta map i e = 263 - Error.push_array (array_kinded_sort map, meta) i e 265 + let fail_push_array meta map i e = 266 + Error.fail_push_array (array_kinded_sort map, meta) i e 264 267 265 - let type_error meta t ~fnd = Error.kinded_sort meta ~exp:(kinded_sort t) ~fnd 268 + let fail_type_mismatch meta t ~fnd = 269 + Error.fail_kinded_sort meta ~exp:(kinded_sort t) ~fnd 266 270 267 - let missing_mems_error meta (object_map : ('o, 'o) object_map) ~exp ~fnd = 271 + let fail_missing_members meta (object_map : ('o, 'o) object_map) ~exp ~fnd = 268 272 let kinded_sort = object_kinded_sort object_map in 269 273 let exp = 270 274 let add n (Mem_dec m) acc = ··· 272 276 in 273 277 List.rev (String_map.fold add exp []) 274 278 in 275 - Error.missing_mems meta ~kinded_sort ~exp ~fnd 279 + Error.fail_missing_members meta ~kinded_sort ~exp ~fnd 276 280 277 - let unexpected_mems_error meta (object_map : ('o, 'o) object_map) ~fnd = 281 + let fail_unexpected_members meta (object_map : ('o, 'o) object_map) ~fnd = 278 282 let kinded_sort = object_kinded_sort object_map in 279 283 let exp = List.map (fun (Mem_enc m) -> m.name) object_map.mem_encs in 280 - Error.unexpected_mems meta ~kinded_sort ~exp ~fnd 284 + Error.fail_unexpected_members meta ~kinded_sort ~exp ~fnd 281 285 282 - let unexpected_case_tag_error meta object_map object_cases tag = 286 + let fail_unexpected_case_tag meta object_map object_cases tag = 283 287 let kinded_sort = object_kinded_sort object_map in 284 288 let case_to_string (Case c) = 285 289 match object_cases.tag_to_string with ··· 292 296 | None -> "<tag>" (* XXX not good *) 293 297 | Some str -> str tag 294 298 in 295 - let mem_name = object_cases.tag.name in 296 - Error.unexpected_case_tag meta ~kinded_sort ~mem_name ~exp ~fnd 299 + let member_name = object_cases.tag.name in 300 + Error.fail_unexpected_case_tag meta ~kinded_sort ~member_name ~exp ~fnd 297 301 298 302 (* Processor toolbox *) 299 303 ··· 368 372 with Exit -> 369 373 let no_default _ (Mem_dec mm) = Option.is_none mm.dec_absent in 370 374 let exp = String_map.filter no_default mem_decs in 371 - missing_mems_error meta map ~exp ~fnd:[] 375 + fail_missing_members meta map ~exp ~fnd:[] 376 + 377 + (* Codec combinators. Moved from json.ml. *) 378 + 379 + (* Keep an alias to the internal [Value] module so we can still reach 380 + [Value.meta] / [Value.sort] etc. after defining a [Value] submodule of 381 + AST-preserving codecs (which shadows the library-level [Value]). *) 382 + module Ast = Value 383 + 384 + type value = Value.t 385 + type 'a codec = 'a t 386 + type name = Value.name 387 + type member = Value.member 388 + type object' = Value.object' 389 + type number_format = Value.number_format 390 + 391 + let enc_meta_none _v = Meta.none 392 + 393 + (* Base types *) 394 + 395 + module Base = struct 396 + type ('a, 'b) map = ('a, 'b) base_map 397 + 398 + let base_map_sort = "base map" 399 + 400 + let map ?(kind = "") ?(doc = "") ?dec ?enc ?(enc_meta = enc_meta_none) () = 401 + let dec = 402 + match dec with 403 + | Some dec -> dec 404 + | None -> 405 + let kind = Sort.kinded_string ~kind base_map_sort in 406 + fun meta _v -> Error.fail_no_decoder meta ~kind 407 + in 408 + let enc = 409 + match enc with 410 + | Some enc -> enc 411 + | None -> 412 + let kind = Sort.kinded_string ~kind base_map_sort in 413 + fun _v -> Error.fail_no_encoder Meta.none ~kind 414 + in 415 + { kind; doc; dec; enc; enc_meta } 416 + 417 + let id = 418 + let dec _meta v = v and enc = Fun.id in 419 + { kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none } 420 + 421 + let ignore = 422 + let kind = "ignore" in 423 + let dec _meta _v = () in 424 + let enc _v = 425 + let kind = Sort.kinded_string ~kind base_map_sort in 426 + Error.fail_no_encoder Meta.none ~kind 427 + in 428 + { kind; doc = ""; dec; enc; enc_meta = enc_meta_none } 429 + 430 + let null map = Null map 431 + let bool map = Bool map 432 + let number map = Number map 433 + let string map = String map 434 + let dec dec = fun _meta v -> dec v 435 + 436 + let dec_result ?(kind = "") dec = 437 + let kind = Sort.kinded_string ~kind base_map_sort in 438 + fun meta v -> 439 + match dec v with Ok v -> v | Error e -> Error.failf meta "%s: %s" kind e 440 + 441 + let dec_failure ?(kind = "") dec = 442 + let kind = Sort.kinded_string ~kind base_map_sort in 443 + fun meta v -> try dec v with Failure e -> Error.failf meta "%s: %s" kind e 444 + 445 + let enc = Fun.id 446 + 447 + let enc_result ?(kind = "") enc = 448 + let kind = Sort.kinded_string ~kind base_map_sort in 449 + fun v -> 450 + match enc v with 451 + | Ok v -> v 452 + | Error e -> Error.failf Meta.none "%s: %s" kind e 453 + 454 + let enc_failure ?(kind = "") enc = 455 + let kind = Sort.kinded_string ~kind base_map_sort in 456 + fun v -> try enc v with Failure e -> Error.failf Meta.none "%s: %s" kind e 457 + end 458 + 459 + (* Any JSON value (RFC 8259 s. 3) *) 460 + 461 + let any ?(kind = "") ?(doc = "") ?dec_null ?dec_bool ?dec_number ?dec_string 462 + ?dec_array ?dec_object ?enc () = 463 + let enc = 464 + match enc with 465 + | Some enc -> enc 466 + | None -> 467 + let kind = Sort.kinded_string ~kind "value" in 468 + fun _v -> Error.fail_no_encoder Meta.none ~kind 469 + in 470 + Any 471 + { 472 + kind; 473 + doc; 474 + dec_null; 475 + dec_bool; 476 + dec_number; 477 + dec_string; 478 + dec_array; 479 + dec_object; 480 + enc; 481 + } 482 + 483 + (* Maps and recursion *) 484 + 485 + let map ?(kind = "") ?(doc = "") ?dec ?enc dom = 486 + let map_sort = "map" in 487 + let dec = 488 + match dec with 489 + | Some dec -> dec 490 + | None -> 491 + let kind = Sort.kinded_string ~kind map_sort in 492 + fun _v -> Error.fail_no_decoder Meta.none ~kind 493 + in 494 + let enc = 495 + match enc with 496 + | Some enc -> enc 497 + | None -> 498 + let kind = Sort.kinded_string ~kind map_sort in 499 + fun _v -> Error.fail_no_encoder Meta.none ~kind 500 + in 501 + Map { kind; doc; dom; dec; enc } 502 + 503 + let iter ?(kind = "") ?(doc = "") ?dec ?enc dom = 504 + let dec = 505 + match dec with 506 + | None -> Fun.id 507 + | Some dec -> 508 + fun v -> 509 + dec v; 510 + v 511 + in 512 + let enc = 513 + match enc with 514 + | None -> Fun.id 515 + | Some enc -> 516 + fun v -> 517 + enc v; 518 + v 519 + in 520 + Map { kind; doc; dom; dec; enc } 521 + 522 + let fix t = Rec t 523 + 524 + (* Nulls and options *) 525 + 526 + let null ?kind ?doc v = 527 + let dec _meta () = v and enc _meta = () in 528 + Null (Base.map ?doc ?kind ~dec ~enc ()) 529 + 530 + let none = 531 + let none = 532 + let dec _meta _v = None and enc _ = () in 533 + { kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none } 534 + in 535 + Null none 536 + 537 + let some t = map ~dec:Option.some ~enc:Option.get t 538 + 539 + let option : type a. ?kind:string -> ?doc:string -> a t -> a option t = 540 + fun ?kind ?doc t -> 541 + let some = some t in 542 + let enc = function None -> none | Some _ -> some in 543 + match t with 544 + | Null _ -> any ?doc ?kind ~dec_null:none ~enc () 545 + | Bool _ -> any ?doc ?kind ~dec_null:none ~dec_bool:some ~enc () 546 + | Number _ -> any ?doc ?kind ~dec_null:none ~dec_number:some ~enc () 547 + | String _ -> any ?doc ?kind ~dec_null:none ~dec_string:some ~enc () 548 + | Array _ -> any ?doc ?kind ~dec_null:none ~dec_array:some ~enc () 549 + | Object _ -> any ?doc ?kind ~dec_null:none ~dec_object:some ~enc () 550 + | Any _ | Map _ | Rec _ | Ignore -> 551 + any ?doc ?kind ~dec_null:none ~dec_bool:some ~dec_number:some 552 + ~dec_string:some ~dec_array:some ~dec_object:some ~enc () 553 + 554 + (* Booleans *) 555 + 556 + let bool = Bool Base.id 557 + 558 + (* Numbers *) 559 + 560 + let[@inline] check_finite_number meta ~kind v = 561 + if Float.is_finite v then () 562 + else 563 + Error.fail_kinded_sort meta ~exp:(Sort.kinded ~kind Number) ~fnd:Sort.Null 564 + 565 + let number = Number Base.id 566 + 567 + let any_float = 568 + let kind = "float" in 569 + let finite = number in 570 + let non_finite = 571 + let dec m v = 572 + match Float.of_string_opt v with 573 + | Some v -> v 574 + | None -> 575 + Error.failf m "String %a does not parse to %a value" Fmt.json_string v 576 + Fmt.code kind 577 + in 578 + Base.string (Base.map ~kind ~dec ~enc:Float.to_string ()) 579 + in 580 + let enc v = if Float.is_finite v then finite else non_finite in 581 + any ~kind ~dec_null:finite ~dec_number:finite ~dec_string:non_finite ~enc () 582 + 583 + let float_as_hex_string = 584 + let kind = "float" in 585 + let dec meta v = 586 + match Float.of_string_opt v with 587 + | Some v -> v 588 + | None -> 589 + Error.failf meta "String %a does not parse to %a value" Fmt.json_string 590 + v Fmt.code kind 591 + in 592 + let enc v = Fmt.str "%h" v in 593 + Base.string (Base.map ~kind ~dec ~enc ()) 594 + 595 + let uint8 = 596 + let kind = "uint8" in 597 + let dec meta v = 598 + check_finite_number meta ~kind v; 599 + if Core.Number.in_exact_uint8_range v then Int.of_float v 600 + else Error.fail_number_range meta ~kind v 601 + in 602 + let enc v = 603 + if Core.Number.int_is_uint8 v then Int.to_float v 604 + else Error.fail_integer_range Meta.none ~kind v 605 + in 606 + Base.number (Base.map ~kind ~dec ~enc ()) 607 + 608 + let uint16 = 609 + let kind = "uint16" in 610 + let dec meta v = 611 + check_finite_number meta ~kind v; 612 + if Core.Number.in_exact_uint16_range v then Int.of_float v 613 + else Error.fail_number_range meta ~kind v 614 + in 615 + let enc v = 616 + if Core.Number.int_is_uint16 v then Int.to_float v 617 + else Error.fail_integer_range Meta.none ~kind v 618 + in 619 + Base.number (Base.map ~kind ~dec ~enc ()) 620 + 621 + let int8 = 622 + let kind = "int8" in 623 + let dec meta v = 624 + check_finite_number meta ~kind v; 625 + if Core.Number.in_exact_int8_range v then Int.of_float v 626 + else Error.fail_number_range meta ~kind v 627 + in 628 + let enc v = 629 + if Core.Number.int_is_int8 v then Int.to_float v 630 + else Error.fail_integer_range Meta.none ~kind v 631 + in 632 + Base.number (Base.map ~kind ~dec ~enc ()) 633 + 634 + let int16 = 635 + let kind = "int16" in 636 + let dec meta v = 637 + check_finite_number meta ~kind v; 638 + if Core.Number.in_exact_int16_range v then Int.of_float v 639 + else Error.fail_number_range meta ~kind v 640 + in 641 + let enc v = 642 + if Core.Number.int_is_int16 v then Int.to_float v 643 + else Error.fail_integer_range Meta.none ~kind v 644 + in 645 + Base.number (Base.map ~kind ~dec ~enc ()) 646 + 647 + let int32 = 648 + let kind = "int32" in 649 + let dec meta v = 650 + check_finite_number meta ~kind v; 651 + if Core.Number.in_exact_int32_range v then Int32.of_float v 652 + else Error.fail_number_range meta ~kind v 653 + in 654 + let enc = Int32.to_float in 655 + Base.number (Base.map ~kind ~dec ~enc ()) 656 + 657 + let int64_as_string = 658 + let kind = "int64" in 659 + let dec meta v = 660 + match Int64.of_string_opt v with 661 + | Some v -> v 662 + | None -> 663 + Error.failf meta "String %a does not parse to %a value" Fmt.json_string 664 + v Fmt.code kind 665 + in 666 + Base.string (Base.map ~kind ~dec ~enc:Int64.to_string ()) 667 + 668 + let int64_number = 669 + let kind = "int64" in 670 + let dec meta v = 671 + if Core.Number.in_exact_int64_range v then Int64.of_float v 672 + else Error.fail_number_range meta ~kind v 673 + in 674 + Base.number (Base.map ~kind ~dec ~enc:Int64.to_float ()) 675 + 676 + let int64 = 677 + let dec_number = int64_number and dec_string = int64_as_string in 678 + let enc v = 679 + if Core.Number.can_store_exact_int64 v then int64_number 680 + else int64_as_string 681 + in 682 + any ~kind:"int64" ~dec_number ~dec_string ~enc () 683 + 684 + let int_as_string = 685 + let kind = "OCaml int" in 686 + let dec meta v = 687 + match int_of_string_opt v with 688 + | Some v -> v 689 + | None -> 690 + Error.failf meta "String %a does not parse to %a value" Fmt.json_string 691 + v Fmt.code kind 692 + in 693 + Base.string (Base.map ~kind ~dec ~enc:Int.to_string ()) 694 + 695 + let int_number = 696 + let kind = "OCaml int" in 697 + let dec meta v = 698 + if Core.Number.in_exact_int_range v then Int.of_float v 699 + else Error.fail_number_range meta ~kind v 700 + in 701 + Base.number (Base.map ~kind ~dec ~enc:Int.to_float ()) 702 + 703 + let int = 704 + let enc v = 705 + if Core.Number.can_store_exact_int v then int_number else int_as_string 706 + in 707 + let dec_number = int_number and dec_string = int_as_string in 708 + any ~kind:"OCaml int" ~dec_number ~dec_string ~enc () 709 + 710 + (* Strings and enums *) 711 + 712 + let string = String Base.id 713 + 714 + let of_of_string ?kind ?doc ?enc of_string = 715 + let dec = Base.dec_result ?kind of_string in 716 + let enc = match enc with None -> None | Some enc -> Some (Base.enc enc) in 717 + Base.string (Base.map ?kind ?doc ?enc ~dec ()) 718 + 719 + let enum (type a) ?(cmp = Stdlib.compare) ?(kind = "") ?doc assoc = 720 + let kind = Sort.kinded_string ~kind "enum" in 721 + let dec_map = 722 + let add m (k, v) = String_map.add k v m in 723 + let m = List.fold_left add String_map.empty assoc in 724 + fun k -> String_map.find_opt k m 725 + in 726 + let enc_map = 727 + let module M = Map.Make (struct 728 + type t = a 729 + 730 + let compare = cmp 731 + end) in 732 + let add m (k, v) = M.add v k m in 733 + let m = List.fold_left add M.empty assoc in 734 + fun v -> M.find_opt v m 735 + in 736 + let dec meta s = 737 + match dec_map s with 738 + | Some v -> v 739 + | None -> 740 + let kind = Sort.kinded ~kind String in 741 + let pp_kind ppf () = Fmt.pf ppf "%a value" pp_code kind in 742 + Error.failf meta "%a" 743 + (Fmt.out_of_dom ~pp_kind ()) 744 + (s, List.map fst assoc) 745 + in 746 + let enc v = 747 + match enc_map v with 748 + | Some s -> s 749 + | None -> Error.failf Meta.none "Encode %a: unknown enum value" pp_code kind 750 + in 751 + Base.string (Base.map ~kind ?doc ~dec ~enc ()) 752 + 753 + let binary_string = 754 + let kind = "hex" in 755 + let kind' = Sort.kinded ~kind String in 756 + let dec = Base.dec_result ~kind:kind' Core.binary_string_of_hex in 757 + let enc = Base.enc Core.binary_string_to_hex in 758 + Base.string (Base.map ~kind ~dec ~enc ()) 759 + 760 + (* Arrays and tuples *) 761 + 762 + module Array = struct 763 + type ('array, 'elt, 'builder) map = ('array, 'elt, 'builder) array_map 764 + 765 + type ('array, 'elt) enc = { 766 + enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; 767 + } 768 + 769 + let array_kind kind = Sort.kinded ~kind Sort.Array 770 + let default_skip _i _builder = false 771 + 772 + let map ?(kind = "") ?(doc = "") ?dec_empty ?dec_skip ?dec_add ?dec_finish 773 + ?enc ?(enc_meta = enc_meta_none) elt = 774 + let dec_empty = 775 + match dec_empty with 776 + | Some dec_empty -> dec_empty 777 + | None -> 778 + fun () -> Error.fail_no_decoder Meta.none ~kind:(array_kind kind) 779 + in 780 + let dec_skip = Option.value ~default:default_skip dec_skip in 781 + let dec_add = 782 + match dec_add with 783 + | Some dec_add -> dec_add 784 + | None -> 785 + fun _ _ _ -> Error.fail_no_decoder Meta.none ~kind:(array_kind kind) 786 + in 787 + let dec_finish = 788 + match dec_finish with 789 + | Some dec_finish -> dec_finish 790 + | None -> 791 + fun _ _ _ -> Error.fail_no_decoder Meta.none ~kind:(array_kind kind) 792 + in 793 + let enc = 794 + match enc with 795 + | Some { enc } -> enc 796 + | None -> 797 + fun _ _ _ -> Error.fail_no_encoder Meta.none ~kind:(array_kind kind) 798 + in 799 + { kind; doc; elt; dec_empty; dec_add; dec_skip; dec_finish; enc; enc_meta } 800 + 801 + let list_enc f acc l = 802 + let rec loop f acc i = function 803 + | [] -> acc 804 + | v :: l -> loop f (f acc i v) (i + 1) l 805 + in 806 + loop f acc 0 l 807 + 808 + let list_map ?kind ?doc ?dec_skip elt = 809 + let dec_empty () = [] in 810 + let dec_add _i v l = v :: l in 811 + let dec_finish _meta _len l = List.rev l in 812 + let enc = { enc = list_enc } in 813 + map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt 814 + 815 + type 'a array_builder = 'a Core.Rarray.t 816 + 817 + let array_enc f acc a = 818 + let acc = ref acc in 819 + for i = 0 to Stdlib.Array.length a - 1 do 820 + acc := f !acc i (Stdlib.Array.unsafe_get a i) 821 + done; 822 + !acc 823 + 824 + let array_map ?kind ?doc ?dec_skip elt = 825 + let dec_empty () = Core.Rarray.empty () in 826 + let dec_add _i v a = Core.Rarray.add_last v a in 827 + let dec_finish _meta _len a = Core.Rarray.to_array a in 828 + let enc = { enc = array_enc } in 829 + map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt 830 + 831 + type ('a, 'b, 'c) bigarray_builder = ('a, 'b, 'c) Core.Rbigarray1.t 832 + 833 + let bigarray_map ?kind ?doc ?dec_skip k l elt = 834 + let dec_empty _meta = Core.Rbigarray1.empty k l in 835 + let dec_add _i v a = Core.Rbigarray1.add_last v a in 836 + let dec_finish _meta _len a = Core.Rbigarray1.to_bigarray a in 837 + let enc f acc a = 838 + let acc = ref acc in 839 + for i = 0 to Bigarray.Array1.dim a - 1 do 840 + acc := f !acc i (Bigarray.Array1.unsafe_get a i) 841 + done; 842 + !acc 843 + in 844 + let enc = { enc } in 845 + map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt 846 + 847 + let array map = Array map 848 + 849 + let stub_elt = 850 + Map 851 + { 852 + kind = ""; 853 + doc = ""; 854 + dom = Base.(null id); 855 + enc = (fun _ -> assert false); 856 + dec = (fun _ -> assert false); 857 + } 858 + 859 + let ignore = 860 + let kind = "ignore" in 861 + let kind' = Sort.kinded ~kind Array in 862 + let dec_empty () = () and dec_add _i _v () = () in 863 + let dec_skip _i () = true and dec_finish _meta _len () = () in 864 + let enc = 865 + { enc = (fun _ _ () -> Error.fail_no_encoder Meta.none ~kind:kind') } 866 + in 867 + array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt) 868 + 869 + let zero = 870 + let dec_empty () = () and dec_add _i _v () = () in 871 + let dec_skip _i () = true and dec_finish _meta _len () = () in 872 + let enc = { enc = (fun _ acc () -> acc) } in 873 + let kind = "zero" in 874 + array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt) 875 + end 876 + 877 + let list ?kind ?doc t = Array (Array.list_map ?kind ?doc t) 878 + let array ?kind ?doc t = Array (Array.array_map ?kind ?doc t) 879 + 880 + let array_as_string_map ?kind ?doc ~key t = 881 + let dec_empty () = String_map.empty in 882 + let dec_add _i elt acc = String_map.add (key elt) elt acc in 883 + let dec_finish _meta _len acc = acc in 884 + let enc f acc m = 885 + let i = ref (-1) in 886 + String_map.fold 887 + (fun _ elt acc -> 888 + incr i; 889 + f acc !i elt) 890 + m acc 891 + in 892 + let enc = Array.{ enc } in 893 + let map = Array.map ?kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t in 894 + Array map 895 + 896 + let bigarray ?kind ?doc k t = 897 + Array (Array.bigarray_map ?kind ?doc k Bigarray.c_layout t) 898 + 899 + let tuple_no_decoder ~kind meta = 900 + Error.fail_no_decoder meta ~kind:(Sort.kinded_string ~kind "tuple") 901 + 902 + let tuple_no_encoder ~kind = 903 + Error.fail_no_encoder Meta.none ~kind:(Sort.kinded_string ~kind "tuple") 904 + 905 + let error_tuple_size meta kind ~exp fnd = 906 + Error.failf meta "Expected %a elements in %a but found %a" pp_int exp pp_kind 907 + (Sort.kinded_string ~kind "tuple") 908 + pp_int fnd 909 + 910 + let t2 ?(kind = "") ?doc ?dec ?enc t = 911 + let size = 2 in 912 + let dec = 913 + match dec with 914 + | None -> fun meta _v0 _v1 -> tuple_no_decoder ~kind meta 915 + | Some dec -> fun _meta v0 v1 -> dec v0 v1 916 + in 917 + let dec_empty () = [] in 918 + let dec_add _i v acc = v :: acc in 919 + let dec_finish meta _len = function 920 + | [ v1; v0 ] -> dec meta v0 v1 921 + | l -> error_tuple_size meta kind ~exp:size (List.length l) 922 + in 923 + let enc = 924 + match enc with 925 + | None -> fun _f _acc _v -> tuple_no_encoder ~kind 926 + | Some enc -> fun f acc v -> f (f acc 0 (enc v 0)) 1 (enc v 1) 927 + in 928 + let enc = { Array.enc } in 929 + Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 930 + 931 + let t3 ?(kind = "") ?doc ?dec ?enc t = 932 + let size = 3 in 933 + let dec = 934 + match dec with 935 + | None -> fun meta _v0 _v1 _v2 -> tuple_no_decoder ~kind meta 936 + | Some dec -> fun _meta v0 v1 v2 -> dec v0 v1 v2 937 + in 938 + let dec_empty () = [] in 939 + let dec_add _i v acc = v :: acc in 940 + let dec_finish meta _len = function 941 + | [ v2; v1; v0 ] -> dec meta v0 v1 v2 942 + | l -> error_tuple_size meta kind ~exp:size (List.length l) 943 + in 944 + let enc = 945 + match enc with 946 + | None -> fun _f _acc _v -> tuple_no_encoder ~kind 947 + | Some enc -> 948 + fun f acc v -> f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2) 949 + in 950 + let enc = { Array.enc } in 951 + Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 952 + 953 + let t4 ?(kind = "") ?doc ?dec ?enc t = 954 + let size = 4 in 955 + let dec = 956 + match dec with 957 + | None -> fun meta _v0 _v1 _v2 _v3 -> tuple_no_decoder ~kind meta 958 + | Some dec -> fun _meta v0 v1 v2 v3 -> dec v0 v1 v2 v3 959 + in 960 + let dec_empty () = [] in 961 + let dec_add _i v acc = v :: acc in 962 + let dec_finish meta _len = function 963 + | [ v3; v2; v1; v0 ] -> dec meta v0 v1 v2 v3 964 + | l -> error_tuple_size meta kind ~exp:size (List.length l) 965 + in 966 + let enc = 967 + match enc with 968 + | None -> fun _f _acc _v -> tuple_no_encoder ~kind 969 + | Some enc -> 970 + fun f acc v -> 971 + f (f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2)) 3 (enc v 3) 972 + in 973 + let enc = { Array.enc } in 974 + Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 975 + 976 + let tn ?(kind = "") ?doc ~n elt = 977 + let dec_empty () = Core.Rarray.empty () in 978 + let dec_add _i v a = Core.Rarray.add_last v a in 979 + let dec_finish meta _len a = 980 + let len = Core.Rarray.length a in 981 + if len <> n then error_tuple_size meta kind ~exp:n len 982 + else Core.Rarray.to_array a 983 + in 984 + let enc = { Array.enc = Array.array_enc } in 985 + Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc elt) 986 + 987 + (* Objects *) 988 + 989 + module Object = struct 990 + (* Maps *) 991 + 992 + type ('o, 'dec) map = ('o, 'dec) object_map 993 + 994 + let default_shape = Object_basic Unknown_skip 995 + 996 + let raw_map ?(kind = "") ?(doc = "") ?(enc_meta = enc_meta_none) dec = 997 + { 998 + kind; 999 + doc; 1000 + dec; 1001 + mem_decs = String_map.empty; 1002 + mem_encs = []; 1003 + enc_meta; 1004 + shape = default_shape; 1005 + } 1006 + 1007 + let map ?kind ?doc dec = raw_map ?kind ?doc (Dec_fun dec) 1008 + 1009 + let map_with_meta ?kind ?doc ?enc_meta dec = 1010 + raw_map ?kind ?doc ?enc_meta (Dec_app (Dec_fun dec, object_meta_arg)) 1011 + 1012 + let enc_only ?(kind = "") ?doc ?enc_meta () = 1013 + let dec meta = 1014 + Error.fail_no_decoder meta ~kind:(Sort.kinded ~kind Object) 1015 + in 1016 + map_with_meta ~kind ?doc ?enc_meta dec 1017 + 1018 + let check_name_unicity m = 1019 + let add n kind = function 1020 + | None -> Some kind 1021 + | Some kind' -> 1022 + let ks _k = Sort.or_kind ~kind Object in 1023 + let k0 = ks kind and k1 = ks kind' in 1024 + invalid_arg 1025 + @@ 1026 + if String.equal k0 k1 then 1027 + Fmt.str "member %s defined twice in %s" n k0 1028 + else Fmt.str "member %s defined both in %s and %s" n k0 k1 1029 + in 1030 + let rec loop : type o dec. 1031 + string String_map.t -> (o, dec) object_map -> unit = 1032 + fun names m -> 1033 + let add_name names n = String_map.update n (add n m.kind) names in 1034 + let add_mem_enc names (Mem_enc m) = add_name names m.name in 1035 + let names = List.fold_left add_mem_enc names m.mem_encs in 1036 + match m.shape with 1037 + | Object_basic _ -> () 1038 + | Object_cases (_u, cases) -> 1039 + let names = add_name names cases.tag.name in 1040 + let check_case (Case c) = loop names c.object_map in 1041 + List.iter check_case cases.cases 1042 + in 1043 + loop String_map.empty m 1044 + 1045 + let seal mems = 1046 + let () = check_name_unicity mems in 1047 + Object { mems with mem_encs = List.rev mems.mem_encs } 1048 + 1049 + let get_object_map = function 1050 + | Object map -> map 1051 + | _ -> invalid_arg "Not an object" 1052 + 1053 + (* Members *) 1054 + 1055 + module Member = struct 1056 + type ('o, 'a) map = ('o, 'a) mem_map 1057 + 1058 + let no_enc name = 1059 + fun _v -> Error.failf Meta.none "No encoder for member %a" pp_code name 1060 + 1061 + let map ?(doc = "") ?dec_absent ?enc ?enc_omit name type' = 1062 + let id = Type.Id.make () in 1063 + let enc = match enc with None -> no_enc name | Some enc -> enc in 1064 + let enc_omit = 1065 + match enc_omit with None -> Fun.const false | Some omit -> omit 1066 + in 1067 + { name; doc; type'; id; dec_absent; enc; enc_omit } 1068 + 1069 + let app object_map mm = 1070 + let mem_decs = String_map.add mm.name (Mem_dec mm) object_map.mem_decs in 1071 + let mem_encs = Mem_enc mm :: object_map.mem_encs in 1072 + let dec = Dec_app (object_map.dec, mm.id) in 1073 + { object_map with dec; mem_decs; mem_encs } 1074 + end 1075 + 1076 + let member ?(doc = "") ?dec_absent ?enc ?enc_omit name type' map = 1077 + let mmap = Member.map ~doc ?dec_absent ?enc ?enc_omit name type' in 1078 + let mem_decs = String_map.add name (Mem_dec mmap) map.mem_decs in 1079 + let mem_encs = Mem_enc mmap :: map.mem_encs in 1080 + let dec = Dec_app (map.dec, mmap.id) in 1081 + { map with dec; mem_decs; mem_encs } 1082 + 1083 + let opt_member ?doc ?enc:e name dom map = 1084 + let dec = Option.some and enc = Option.get in 1085 + let some = Map { kind = ""; doc = ""; dom; dec; enc } in 1086 + member ?doc ~dec_absent:None ?enc:e ~enc_omit:Option.is_none name some map 1087 + 1088 + (* Case objects *) 1089 + 1090 + module Case = struct 1091 + type ('cases, 'case, 'tag) map = ('cases, 'case, 'tag) case_map 1092 + type ('cases, 'tag) t = ('cases, 'tag) case 1093 + type ('cases, 'tag) value = ('cases, 'tag) case_value 1094 + 1095 + let no_dec _ = Error.failf Meta.none "No decoder for case" 1096 + 1097 + let map ?(dec = no_dec) tag obj = 1098 + { tag; object_map = get_object_map obj; dec } 1099 + 1100 + let map_tag (c : (_, _, _) case_map) = c.tag 1101 + let make c = Case c 1102 + let tag (Case c) = map_tag c 1103 + let value c v = Case_value (c, v) 1104 + end 1105 + 1106 + let check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string = 1107 + match map.shape with 1108 + | Object_cases _ -> invalid_arg "Multiple calls to Json.Object.case_member" 1109 + | _ -> ( 1110 + match dec_absent with 1111 + | None -> () 1112 + | Some tag -> 1113 + let equal_t (Case case) = tag_compare case.tag tag = 0 in 1114 + if not (List.exists equal_t cases) then 1115 + let tag = 1116 + match tag_to_string with 1117 + | None -> "" 1118 + | Some tag_to_string -> " " ^ tag_to_string tag 1119 + in 1120 + invalid_arg ("No case for dec_absent case member value" ^ tag)) 1121 + 1122 + let case_tag_mem ?(doc = "") name type' ~dec_absent ~enc_omit = 1123 + let id = Type.Id.make () in 1124 + let enc t = t in 1125 + let enc_omit = 1126 + match enc_omit with None -> Fun.const false | Some omit -> omit 1127 + in 1128 + { name; doc; type'; id; dec_absent; enc; enc_omit } 1129 + 1130 + let case_member ?doc ?(tag_compare = Stdlib.compare) ?tag_to_string 1131 + ?dec_absent ?enc ?enc_omit ?enc_case name type' cases map = 1132 + let () = check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string in 1133 + let tag = case_tag_mem ?doc name type' ~dec_absent ~enc_omit in 1134 + let enc = match enc with None -> Member.no_enc name | Some e -> e in 1135 + let enc_case = 1136 + match enc_case with 1137 + | Some enc_case -> enc_case 1138 + | None -> 1139 + fun _case -> 1140 + Error.failf Meta.none "No case encoder for member %a" pp_code name 1141 + in 1142 + let id = Type.Id.make () in 1143 + let cases = { tag; tag_compare; tag_to_string; id; cases; enc; enc_case } in 1144 + let dec = Dec_app (map.dec, id) in 1145 + { map with dec; shape = Object_cases (None, cases) } 1146 + 1147 + (* Unknown members *) 1148 + 1149 + module Members = struct 1150 + type ('mems, 'a) enc = { 1151 + enc : 1152 + 'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc; 1153 + } 1154 + 1155 + type ('mems, 'a, 'builder) map = ('mems, 'a, 'builder) mems_map 1156 + 1157 + let mems_kind kind = Sort.kinded_string ~kind "members map" 1158 + 1159 + let map ?(kind = "") ?(doc = "") ?dec_empty ?dec_add ?dec_finish ?enc 1160 + mems_type = 1161 + let dec_empty = 1162 + match dec_empty with 1163 + | Some dec_empty -> dec_empty 1164 + | None -> 1165 + fun () -> Error.fail_no_decoder Meta.none ~kind:(mems_kind kind) 1166 + in 1167 + let dec_add = 1168 + match dec_add with 1169 + | Some dec_add -> dec_add 1170 + | None -> 1171 + fun _ _ _ _ -> 1172 + Error.fail_no_decoder Meta.none ~kind:(mems_kind kind) 1173 + in 1174 + let dec_finish = 1175 + match dec_finish with 1176 + | Some dec_finish -> dec_finish 1177 + | None -> 1178 + fun _ _ -> Error.fail_no_decoder Meta.none ~kind:(mems_kind kind) 1179 + in 1180 + let enc = 1181 + match enc with 1182 + | Some { enc } -> enc 1183 + | None -> 1184 + fun _ _ _ -> Error.fail_no_encoder Meta.none ~kind:(mems_kind kind) 1185 + in 1186 + let id = Type.Id.make () in 1187 + { kind; doc; mems_type; id; dec_empty; dec_add; dec_finish; enc } 1188 + 1189 + let string_map ?kind ?doc type' = 1190 + let dec_empty () = String_map.empty in 1191 + let dec_add _meta n v mems = String_map.add n v mems in 1192 + let dec_finish _meta mems = mems in 1193 + let enc f mems acc = 1194 + String_map.fold (fun n v acc -> f Meta.none n v acc) mems acc 1195 + in 1196 + map ?kind ?doc type' ~dec_empty ~dec_add ~dec_finish ~enc:{ enc } 1197 + end 1198 + 1199 + let set_shape_unknown_mems shape u = 1200 + match shape with 1201 + | Object_basic (Unknown_keep _) | Object_cases (Some (Unknown_keep _), _) -> 1202 + invalid_arg "Json.Object.keep_unknown already called on object" 1203 + | Object_basic _ -> Object_basic u 1204 + | Object_cases (_, cases) -> Object_cases (Some u, cases) 1205 + 1206 + let skip_unknown map = 1207 + { map with shape = set_shape_unknown_mems map.shape Unknown_skip } 1208 + 1209 + let error_unknown map = 1210 + { map with shape = set_shape_unknown_mems map.shape Unknown_error } 1211 + 1212 + let mems_noenc (mems : (_, _, _) mems_map) _o = 1213 + let kind = Sort.kinded_string ~kind:mems.kind "members" in 1214 + Error.fail_no_encoder Meta.none ~kind 1215 + 1216 + let keep_unknown ?enc mems (map : ('o, 'dec) object_map) = 1217 + let enc = match enc with None -> mems_noenc mems | Some enc -> enc in 1218 + let dec = Dec_app (map.dec, mems.id) in 1219 + let unknown = Unknown_keep (mems, enc) in 1220 + { map with dec; shape = set_shape_unknown_mems map.shape unknown } 1221 + 1222 + let zero = seal (map ~kind:"zero" ()) 1223 + 1224 + let as_string_map ?kind ?doc t = 1225 + map ?kind ?doc Fun.id 1226 + |> keep_unknown (Members.string_map t) ~enc:Fun.id 1227 + |> seal 1228 + end 1229 + 1230 + (* Ignoring *) 1231 + 1232 + let ignore : unit t = Ignore 1233 + 1234 + let zero = 1235 + let kind = "zero" in 1236 + let null = null () and dec_bool = Bool Base.ignore in 1237 + let dec_number = Number Base.ignore in 1238 + let dec_string = String Base.ignore in 1239 + let dec_array = Array.ignore and dec_object = Object.zero in 1240 + let enc () = null in 1241 + any ~kind ~dec_null:null ~dec_bool ~dec_number ~dec_string ~dec_array 1242 + ~dec_object ~enc () 1243 + 1244 + let todo ?(kind = "") ?doc ?dec_stub () = 1245 + let pp_kind ppf () = 1246 + if kind = "" then () else Fmt.pf ppf " %a" Fmt.code kind 1247 + in 1248 + let dec = 1249 + match dec_stub with 1250 + | Some v -> Fun.const v 1251 + | None -> fun _v -> Error.failf Meta.none "TODO: decode%a" pp_kind () 1252 + in 1253 + let enc _v = Error.failf Meta.none "TODO: encode%a" pp_kind () in 1254 + map ~kind ?doc ~dec ~enc ignore 1255 + 1256 + (* Generic-AST codecs. These preserve the AST shape when (de)coding. *) 1257 + 1258 + module Value = struct 1259 + (* Build codecs that map to / from the generic [Value.t] AST. *) 1260 + 1261 + let null = 1262 + let dec meta () = Value.null ~meta () in 1263 + let enc = function 1264 + | (Value.Null _ : Value.t) -> () 1265 + | j -> Error.fail_sort (Value.meta j) ~exp:Sort.Null ~fnd:(Value.sort j) 1266 + in 1267 + Null (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1268 + 1269 + let bool = 1270 + let dec meta b = Value.bool ~meta b in 1271 + let enc = function 1272 + | (Value.Bool (b, _) : Value.t) -> b 1273 + | j -> Error.fail_sort (Value.meta j) ~exp:Sort.Bool ~fnd:(Value.sort j) 1274 + in 1275 + Bool (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1276 + 1277 + let number = 1278 + let dec meta n = Value.number ~meta n in 1279 + let enc = function 1280 + | (Value.Number (n, _) : Value.t) -> n 1281 + | j -> Error.fail_sort (Value.meta j) ~exp:Sort.Number ~fnd:(Value.sort j) 1282 + in 1283 + Number (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1284 + 1285 + let string = 1286 + let dec meta s = Value.string ~meta s in 1287 + let enc = function 1288 + | (Value.String (s, _) : Value.t) -> s 1289 + | j -> Error.fail_sort (Value.meta j) ~exp:Sort.String ~fnd:(Value.sort j) 1290 + in 1291 + String (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1292 + 1293 + let t, array, mems, object' = 1294 + let rec elt = Rec any 1295 + and array_map = 1296 + lazy begin 1297 + let dec_empty () = [] in 1298 + let dec_add _i v a = v :: a in 1299 + let dec_finish meta _len a = Value.list ~meta (List.rev a) in 1300 + let enc f acc = function 1301 + | (Value.Array (a, _) : Value.t) -> Array.list_enc f acc a 1302 + | j -> 1303 + Error.fail_sort (Value.meta j) ~exp:Sort.Array ~fnd:(Value.sort j) 1304 + in 1305 + let enc = { Array.enc } in 1306 + Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta:Value.meta elt 1307 + end 1308 + and array = lazy (Array.array (Lazy.force array_map)) 1309 + and mems = 1310 + lazy begin 1311 + let dec_empty () = [] in 1312 + let dec_add meta n v mems = ((n, meta), v) :: mems in 1313 + let dec_finish _meta mems = List.rev mems in 1314 + let enc f l a = List.fold_left (fun a ((n, m), v) -> f m n v a) a l in 1315 + let enc = { Object.Members.enc } in 1316 + Object.Members.map ~dec_empty ~dec_add ~dec_finish ~enc elt 1317 + end 1318 + and object' = 1319 + lazy begin 1320 + let enc_meta = function 1321 + | (Value.Object (_, meta) : Value.t) -> meta 1322 + | j -> 1323 + Error.fail_sort (Value.meta j) ~exp:Sort.Object 1324 + ~fnd:(Value.sort j) 1325 + in 1326 + let enc = function 1327 + | (Value.Object (mems, _) : Value.t) -> mems 1328 + | j -> 1329 + Error.fail_sort (Value.meta j) ~exp:Sort.Object 1330 + ~fnd:(Value.sort j) 1331 + in 1332 + let dec meta mems : Value.t = Value.Object (mems, meta) in 1333 + Object.map_with_meta dec ~enc_meta 1334 + |> Object.keep_unknown (Lazy.force mems) ~enc 1335 + |> Object.seal 1336 + end 1337 + and any = 1338 + lazy begin 1339 + let value_array = Lazy.force array in 1340 + let value_object = Lazy.force object' in 1341 + let enc (v : Value.t) = 1342 + match v with 1343 + | Value.Null _ -> null 1344 + | Value.Bool _ -> bool 1345 + | Value.Number _ -> number 1346 + | Value.String _ -> string 1347 + | Value.Array _ -> value_array 1348 + | Value.Object _ -> value_object 1349 + in 1350 + Any 1351 + { 1352 + kind = "json"; 1353 + doc = ""; 1354 + dec_null = Some null; 1355 + dec_bool = Some bool; 1356 + dec_number = Some number; 1357 + dec_string = Some string; 1358 + dec_array = Some value_array; 1359 + dec_object = Some value_object; 1360 + enc; 1361 + } 1362 + end 1363 + in 1364 + (Lazy.force any, Lazy.force array, Lazy.force mems, Lazy.force object') 1365 + 1366 + let _ = mems 1367 + (* The [members] re-binding below is the real public value; the closed-over 1368 + [mems] above is used internally by [t]. *) 1369 + 1370 + let members = 1371 + let dec_empty () = [] in 1372 + let dec_add meta name v mems = ((name, meta), v) :: mems in 1373 + let dec_finish meta mems : Value.t = Value.Object (List.rev mems, meta) in 1374 + let enc f j acc = 1375 + match j with 1376 + | (Value.Object (ms, _) : Value.t) -> 1377 + List.fold_left (fun acc ((n, m), v) -> f m n v acc) acc ms 1378 + | j -> Error.fail_sort (Value.meta j) ~exp:Sort.Object ~fnd:(Value.sort j) 1379 + in 1380 + let enc = { Object.Members.enc } in 1381 + Object.Members.map ~dec_empty ~dec_add ~dec_finish ~enc t 1382 + end 1383 + 1384 + (* Decode / encode between generic JSON and typed values using a codec. 1385 + [decode_exn] / [encode_exn] raise [Error]; thin wrappers return results. *) 1386 + 1387 + let error_sort ~exp j = Error.fail_sort (Ast.meta j) ~exp ~fnd:(Ast.sort j) 1388 + 1389 + let error_type t fnd = 1390 + Error.fail_kinded_sort (Ast.meta fnd) ~exp:(kinded_sort t) ~fnd:(Ast.sort fnd) 1391 + 1392 + let find_all_unexpected ~mem_decs mems = 1393 + let unexpected (((n, _) as nm), _v) = 1394 + match String_map.find_opt n mem_decs with None -> Some nm | Some _ -> None 1395 + in 1396 + List.filter_map unexpected mems 1397 + 1398 + let rec decode_exn : type a. a t -> Ast.t -> a = 1399 + fun t j -> 1400 + match t with 1401 + | Null map -> ( 1402 + match (j : Ast.t) with 1403 + | Ast.Null (n, meta) -> map.dec meta n 1404 + | j -> error_type t j) 1405 + | Bool map -> ( 1406 + match (j : Ast.t) with 1407 + | Ast.Bool (b, meta) -> map.dec meta b 1408 + | j -> error_type t j) 1409 + | Number map -> ( 1410 + match (j : Ast.t) with 1411 + | Ast.Number (n, meta) -> map.dec meta n 1412 + | Ast.Null (_, meta) -> map.dec meta Float.nan 1413 + | j -> error_type t j) 1414 + | String map -> ( 1415 + match (j : Ast.t) with 1416 + | Ast.String (s, meta) -> map.dec meta s 1417 + | j -> error_type t j) 1418 + | Array map -> ( 1419 + match (j : Ast.t) with 1420 + | Ast.Array (vs, meta) -> decode_array map meta vs 1421 + | j -> error_type t j) 1422 + | Object map -> ( 1423 + match (j : Ast.t) with 1424 + | Ast.Object (mems, meta) -> decode_object map meta mems 1425 + | j -> error_type t j) 1426 + | Map map -> map.dec (decode_exn map.dom j) 1427 + | Any map -> decode_any t map j 1428 + | Rec t -> decode_exn (Lazy.force t) j 1429 + | Ignore -> () 1430 + 1431 + and decode_array : type a elt b. 1432 + (a, elt, b) array_map -> Meta.t -> Ast.t list -> a = 1433 + fun map meta vs -> 1434 + let rec next (map : (a, elt, b) array_map) meta b i = function 1435 + | [] -> map.dec_finish meta i b 1436 + | v :: vs -> 1437 + let b = 1438 + try 1439 + if map.dec_skip i b then b 1440 + else map.dec_add i (decode_exn map.elt v) b 1441 + with Error e -> fail_push_array meta map (i, Ast.meta v) e 1442 + in 1443 + next map meta b (i + 1) vs 1444 + in 1445 + next map meta (map.dec_empty ()) 0 vs 1446 + 1447 + and decode_object : type o. (o, o) object_map -> Meta.t -> Ast.object' -> o = 1448 + fun map meta mems -> 1449 + let dict = Dict.empty in 1450 + let umems = Unknown_mems None in 1451 + apply_dict map.dec 1452 + @@ decode_object_map map meta umems String_map.empty String_map.empty dict 1453 + mems 1454 + 1455 + and decode_object_map : type o. 1456 + (o, o) object_map -> 1457 + Meta.t -> 1458 + unknown_mems_option -> 1459 + mem_dec String_map.t -> 1460 + mem_dec String_map.t -> 1461 + Dict.t -> 1462 + Ast.object' -> 1463 + Dict.t = 1464 + fun map meta umems mem_miss mem_decs dict mems -> 1465 + let u _ _ _ = assert false in 1466 + let mem_miss = String_map.union u mem_miss map.mem_decs in 1467 + let mem_decs = String_map.union u mem_decs map.mem_decs in 1468 + match map.shape with 1469 + | Object_cases (umems', cases) -> 1470 + let umems' = Unknown_mems umems' in 1471 + let umems, dict = override_unknown_mems ~by:umems umems' dict in 1472 + decode_object_cases map meta umems cases mem_miss mem_decs dict [] mems 1473 + | Object_basic umems' -> ( 1474 + let umems' = Unknown_mems (Some umems') in 1475 + let umems, dict = override_unknown_mems ~by:umems umems' dict in 1476 + match umems with 1477 + | Unknown_mems (Some Unknown_skip | None) -> 1478 + let umems = Unknown_skip in 1479 + decode_object_basic map meta umems () mem_miss mem_decs dict mems 1480 + | Unknown_mems (Some (Unknown_error as umems)) -> 1481 + decode_object_basic map meta umems () mem_miss mem_decs dict mems 1482 + | Unknown_mems (Some (Unknown_keep (umap, _) as umems)) -> 1483 + let umap = umap.dec_empty () in 1484 + decode_object_basic map meta umems umap mem_miss mem_decs dict mems) 1485 + 1486 + and decode_object_basic : type o p m b. 1487 + (o, o) object_map -> 1488 + Meta.t -> 1489 + (p, m, b) unknown_mems -> 1490 + b -> 1491 + mem_dec String_map.t -> 1492 + mem_dec String_map.t -> 1493 + Dict.t -> 1494 + Ast.object' -> 1495 + Dict.t = 1496 + fun map meta umems umap mem_miss mem_decs dict -> function 1497 + | [] -> finish_object_decode map meta umems umap mem_miss dict 1498 + | (((n, nmeta) as nm), v) :: mems -> ( 1499 + match String_map.find_opt n mem_decs with 1500 + | Some (Mem_dec m) -> 1501 + let dict = 1502 + try Dict.add m.id (decode_exn m.type' v) dict 1503 + with Error e -> fail_push_object meta map nm e 1504 + in 1505 + let mem_miss = String_map.remove n mem_miss in 1506 + decode_object_basic map meta umems umap mem_miss mem_decs dict mems 1507 + | None -> ( 1508 + match umems with 1509 + | Unknown_skip -> 1510 + decode_object_basic map meta umems umap mem_miss mem_decs dict 1511 + mems 1512 + | Unknown_error -> 1513 + let fnd = nm :: find_all_unexpected ~mem_decs mems in 1514 + fail_unexpected_members meta map ~fnd 1515 + | Unknown_keep (umap', _) -> 1516 + let umap = 1517 + try umap'.dec_add nmeta n (decode_exn umap'.mems_type v) umap 1518 + with Error e -> fail_push_object meta map nm e 1519 + in 1520 + decode_object_basic map meta umems umap mem_miss mem_decs dict 1521 + mems)) 1522 + 1523 + and decode_object_cases : type o cs tg. 1524 + (o, o) object_map -> 1525 + Meta.t -> 1526 + unknown_mems_option -> 1527 + (o, cs, tg) object_cases -> 1528 + mem_dec String_map.t -> 1529 + mem_dec String_map.t -> 1530 + Dict.t -> 1531 + Ast.object' -> 1532 + Ast.object' -> 1533 + Dict.t = 1534 + fun map meta umems cases mem_miss mem_decs dict delay mems -> 1535 + let decode_case_tag map meta tag delay mems = 1536 + let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in 1537 + match List.find_opt eq_tag cases.cases with 1538 + | None -> fail_unexpected_case_tag meta map cases tag 1539 + | Some (Case case) -> 1540 + let mems = List.rev_append delay mems in 1541 + let dict = 1542 + decode_object_map case.object_map meta umems mem_miss mem_decs dict 1543 + mems 1544 + in 1545 + Dict.add cases.id (case.dec (apply_dict case.object_map.dec dict)) dict 1546 + in 1547 + match mems with 1548 + | [] -> ( 1549 + match cases.tag.dec_absent with 1550 + | Some tag -> decode_case_tag map meta tag delay [] 1551 + | None -> 1552 + let kinded_sort = object_kinded_sort map in 1553 + Error.fail_missing_members meta ~kinded_sort ~exp:[ cases.tag.name ] 1554 + ~fnd:(List.map (fun ((n, _), _) -> n) delay)) 1555 + | ((((n, meta) as nm), v) as mem) :: mems -> ( 1556 + if n = cases.tag.name then 1557 + let tag = 1558 + try decode_exn cases.tag.type' v 1559 + with Error e -> fail_push_object meta map nm e 1560 + in 1561 + decode_case_tag map meta tag delay mems 1562 + else 1563 + match String_map.find_opt n mem_decs with 1564 + | None -> 1565 + let delay = mem :: delay in 1566 + decode_object_cases map meta umems cases mem_miss mem_decs dict 1567 + delay mems 1568 + | Some (Mem_dec m) -> 1569 + let dict = 1570 + try Dict.add m.id (decode_exn m.type' v) dict 1571 + with Error e -> fail_push_object meta map nm e 1572 + in 1573 + let mem_miss = String_map.remove n mem_miss in 1574 + decode_object_cases map meta umems cases mem_miss mem_decs dict 1575 + delay mems) 1576 + 1577 + and decode_any : type a. a t -> a any_map -> Ast.t -> a = 1578 + fun t map j -> 1579 + let dec t map j = 1580 + match map with Some t -> decode_exn t j | None -> error_type t j 1581 + in 1582 + match (j : Ast.t) with 1583 + | Ast.Null _ -> dec t map.dec_null j 1584 + | Ast.Bool _ -> dec t map.dec_bool j 1585 + | Ast.Number _ -> dec t map.dec_number j 1586 + | Ast.String _ -> dec t map.dec_string j 1587 + | Ast.Array _ -> dec t map.dec_array j 1588 + | Ast.Object _ -> dec t map.dec_object j 1589 + 1590 + let decode t j = try Ok (decode_exn t j) with Error e -> Result.Error e 1591 + 1592 + (* Encode *) 1593 + 1594 + let rec encode_exn : type a. a t -> a -> Ast.t = 1595 + fun t v -> 1596 + match t with 1597 + | Null map -> Ast.null ~meta:(map.enc_meta v) (map.enc v) 1598 + | Bool map -> Ast.bool ~meta:(map.enc_meta v) (map.enc v) 1599 + | Number map -> Ast.number ~meta:(map.enc_meta v) (map.enc v) 1600 + | String map -> Ast.string ~meta:(map.enc_meta v) (map.enc v) 1601 + | Array map -> 1602 + let enc map acc i elt = 1603 + try encode_exn map.elt elt :: acc 1604 + with Error e -> fail_push_array Meta.none map (i, Meta.none) e 1605 + in 1606 + Ast.list ~meta:(map.enc_meta v) (List.rev (map.enc (enc map) [] v)) 1607 + | Object map -> 1608 + let mems = encode_object map ~do_unknown:true v [] in 1609 + Ast.Object (List.rev mems, map.enc_meta v) 1610 + | Any map -> encode_exn (map.enc v) v 1611 + | Map map -> encode_exn map.dom (map.enc v) 1612 + | Rec t -> encode_exn (Lazy.force t) v 1613 + | Ignore -> Error.fail_no_encoder Meta.none ~kind:"ignore" 1614 + 1615 + and encode_object : type o. 1616 + (o, o) object_map -> do_unknown:bool -> o -> Ast.object' -> Ast.object' = 1617 + fun map ~do_unknown o obj -> 1618 + let encode_mem map obj (Mem_enc mmap) = 1619 + try 1620 + let v = mmap.enc o in 1621 + if mmap.enc_omit v then obj 1622 + else ((mmap.name, Meta.none), encode_exn mmap.type' v) :: obj 1623 + with Error e -> fail_push_object Meta.none map (mmap.name, Meta.none) e 1624 + in 1625 + let obj = List.fold_left (encode_mem map) obj map.mem_encs in 1626 + match map.shape with 1627 + | Object_basic (Unknown_keep (umap, enc)) when do_unknown -> 1628 + encode_unknown_mems map umap (enc o) obj 1629 + | Object_basic _ -> obj 1630 + | Object_cases (u, cases) -> ( 1631 + let (Case_value (case, c)) = cases.enc_case (cases.enc o) in 1632 + let obj = 1633 + let n = (cases.tag.name, Meta.none) in 1634 + try 1635 + if cases.tag.enc_omit case.tag then obj 1636 + else (n, encode_exn cases.tag.type' case.tag) :: obj 1637 + with Error e -> fail_push_object Meta.none map n e 1638 + in 1639 + match u with 1640 + | Some (Unknown_keep (umap, enc)) -> 1641 + let obj = encode_object case.object_map ~do_unknown:false c obj in 1642 + encode_unknown_mems map umap (enc o) obj 1643 + | _ -> encode_object case.object_map ~do_unknown c obj) 1644 + 1645 + and encode_unknown_mems : type o mems a builder. 1646 + (o, o) object_map -> 1647 + (mems, a, builder) mems_map -> 1648 + mems -> 1649 + Ast.object' -> 1650 + Ast.object' = 1651 + fun map umap mems obj -> 1652 + let encode_mem map meta name v obj = 1653 + let n = (name, meta) in 1654 + let v = 1655 + try encode_exn umap.mems_type v 1656 + with Error e -> fail_push_object Meta.none map n e 1657 + in 1658 + (n, v) :: obj 1659 + in 1660 + umap.enc (encode_mem map) mems obj 1661 + 1662 + let encode t v = try Ok (encode_exn t v) with Error e -> Result.Error e 1663 + 1664 + (* Recode: decode then encode (on values). The [recode] combinator above 1665 + takes labelled [~dec]/[~enc] args; these operate on values. *) 1666 + 1667 + let value_recode_exn t v = encode_exn t (decode_exn t v) 1668 + 1669 + (* Queries and updates *) 1670 + 1671 + let const t v = 1672 + let const _ = v in 1673 + let dec = map ~dec:const ignore in 1674 + let enc = map ~enc:const t in 1675 + let enc _v = enc in 1676 + any ~dec_null:dec ~dec_bool:dec ~dec_number:dec ~dec_string:dec ~dec_array:dec 1677 + ~dec_object:dec ~enc () 1678 + 1679 + let recode ~dec:dom f ~enc = 1680 + let m = map ~dec:f dom in 1681 + let enc _v = enc in 1682 + any ~dec_null:m ~dec_bool:m ~dec_number:m ~dec_string:m ~dec_array:m 1683 + ~dec_object:m ~enc () 1684 + 1685 + let update t = 1686 + let dec v = value_recode_exn t v in 1687 + Map { kind = ""; doc = ""; dom = Value.t; dec; enc = Fun.id } 1688 + 1689 + (* Array queries *) 1690 + 1691 + let rec list_repeat n v l = if n <= 0 then l else list_repeat (n - 1) v (v :: l) 1692 + 1693 + let nth ?absent n t = 1694 + let dec_empty () = None in 1695 + let dec_skip i _v = i <> n in 1696 + let dec_add _i v _acc = Some v in 1697 + let dec_finish meta len v = 1698 + match v with 1699 + | Some v -> v 1700 + | None -> ( 1701 + match absent with 1702 + | Some v -> v 1703 + | None -> Error.fail_index_out_of_range meta ~n ~len) 1704 + in 1705 + let enc f acc v = f acc 0 v in 1706 + let enc = { Array.enc } in 1707 + Array.array (Array.map ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc t) 1708 + 1709 + let update_nth ?stub ?absent n t = 1710 + let update_elt _n t v = Ast.copy_layout v ~dst:(value_recode_exn t v) in 1711 + let rec update_array ~seen n t i acc = function 1712 + | v :: vs when i = n -> 1713 + let elt = update_elt (i, Ast.meta v) t v in 1714 + update_array ~seen:true n t (i + 1) (elt :: acc) vs 1715 + | v :: vs -> update_array ~seen n t (i + 1) (v :: acc) vs 1716 + | [] when seen -> Either.Right (List.rev acc) 1717 + | [] -> Either.Left (acc, i) 1718 + in 1719 + let do_update ?stub ?absent n t j = 1720 + match (j : Ast.t) with 1721 + | Ast.Array (vs, meta) -> 1722 + begin match update_array ~seen:false n t 0 [] vs with 1723 + | Either.Right elts -> (Ast.Array (elts, meta) : Ast.t) 1724 + | Either.Left (acc, len) -> ( 1725 + match absent with 1726 + | None -> Error.fail_index_out_of_range meta ~n ~len 1727 + | Some absent -> 1728 + let elt = encode_exn t absent in 1729 + let stub = 1730 + match stub with None -> Ast.zero elt | Some j -> j 1731 + in 1732 + Ast.Array 1733 + (List.rev (elt :: list_repeat (n - len) stub acc), meta)) 1734 + end 1735 + | j -> error_sort ~exp:Sort.Array j 1736 + in 1737 + let dec = do_update ?stub ?absent n t in 1738 + let enc j = j in 1739 + map ~dec ~enc Value.t 1740 + 1741 + let set_nth ?stub ?(allow_absent = false) t n v = 1742 + let absent = if allow_absent then Some v else None in 1743 + update_nth ?stub ?absent n (const t v) 1744 + 1745 + let delete_nth ?(allow_absent = false) n = 1746 + let dec_empty () = [] in 1747 + let dec_add i v a = if i = n then a else v :: a in 1748 + let dec_finish meta len a = 1749 + if n < len || allow_absent then Ast.list ~meta (List.rev a) 1750 + else Error.fail_index_out_of_range meta ~n ~len 1751 + in 1752 + let enc f acc = function 1753 + | (Ast.Array (a, _) : Ast.t) -> Array.list_enc f acc a 1754 + | j -> error_sort ~exp:Sort.Array j 1755 + in 1756 + let enc_meta j = Ast.meta j in 1757 + let enc = { Array.enc } in 1758 + Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta Value.t) 1759 + 1760 + let filter_map_array a b f = 1761 + let dec_empty () = [] in 1762 + let dec_add i v acc = 1763 + match f i (decode_exn a v) with 1764 + | None -> acc 1765 + | Some v' -> encode_exn b v' :: acc 1766 + in 1767 + let dec_finish meta _len acc = Ast.list ~meta (List.rev acc) in 1768 + let enc f acc = function 1769 + | (Ast.Array (a, _) : Ast.t) -> Array.list_enc f acc a 1770 + | j -> error_sort ~exp:Sort.Array j 1771 + in 1772 + let enc = { Array.enc } in 1773 + let enc_meta j = Ast.meta j in 1774 + Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta Value.t) 1775 + 1776 + let fold_array t f acc = 1777 + let dec_empty () = acc in 1778 + let dec_add = f in 1779 + let dec_finish _meta _len acc = acc in 1780 + let enc _f acc _a = acc in 1781 + let enc = { Array.enc } in 1782 + Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc t) 1783 + 1784 + (* Object queries *) 1785 + 1786 + let member ?absent name t = 1787 + Object.map Fun.id 1788 + |> Object.member name t ~enc:Fun.id ?dec_absent:absent 1789 + |> Object.seal 1790 + 1791 + let update_member ?absent name t = 1792 + let recode n t v = (n, Ast.copy_layout v ~dst:(value_recode_exn t v)) in 1793 + let rec update_object ~seen name t acc = function 1794 + | (((name', _) as n), v) :: mems when String.equal name name' -> 1795 + update_object ~seen:true name t (recode n t v :: acc) mems 1796 + | mem :: mems -> update_object ~seen name t (mem :: acc) mems 1797 + | [] when seen -> Either.Right (List.rev acc) 1798 + | [] -> Either.Left acc 1799 + in 1800 + let do_update ?absent name t = function 1801 + | (Ast.Object (mems, meta) : Ast.t) -> 1802 + let mems = 1803 + match update_object ~seen:false name t [] mems with 1804 + | Either.Right mems -> mems 1805 + | Either.Left acc -> ( 1806 + match absent with 1807 + | None -> 1808 + let fnd = Ast.member_keys mems in 1809 + Error.fail_missing_members meta ~kinded_sort:"" ~exp:[ name ] 1810 + ~fnd 1811 + | Some absent -> 1812 + let m = ((name, Meta.none), encode_exn t absent) in 1813 + List.rev (m :: acc)) 1814 + in 1815 + (Ast.Object (mems, meta) : Ast.t) 1816 + | j -> error_sort ~exp:Sort.Object j 1817 + in 1818 + let dec = do_update ?absent name t in 1819 + let enc j = j in 1820 + map ~dec ~enc Value.t 1821 + 1822 + let set_member ?(allow_absent = false) t name v = 1823 + let absent = if allow_absent then Some v else None in 1824 + update_member ?absent name (const t v) 1825 + 1826 + let update_value_object ~name ~dec_add ~dec_finish = 1827 + let mems = 1828 + let dec_empty () = (false, []) in 1829 + let enc f (_, l) a = List.fold_left (fun a ((n, m), v) -> f m n v a) a l in 1830 + let enc = { Object.Members.enc } in 1831 + Object.Members.map ~dec_empty ~dec_add ~dec_finish ~enc Value.t 1832 + in 1833 + let enc_meta = function 1834 + | (Ast.Object (_, meta) : Ast.t) -> meta 1835 + | j -> error_sort ~exp:Sort.Object j 1836 + in 1837 + let enc = function 1838 + | (Ast.Object (mems, _) : Ast.t) -> (false, mems) 1839 + | j -> error_sort ~exp:Sort.Object j 1840 + in 1841 + let dec meta (ok, mems) : Ast.t = 1842 + let fnd = Ast.member_keys mems in 1843 + if not ok then 1844 + Error.fail_missing_members meta ~kinded_sort:"" ~exp:[ name ] ~fnd 1845 + else Ast.Object (List.rev mems, meta) 1846 + in 1847 + Object.map_with_meta dec ~enc_meta 1848 + |> Object.keep_unknown mems ~enc 1849 + |> Object.seal 1850 + 1851 + let delete_member ?(allow_absent = false) name = 1852 + let dec_add meta n v (ok, mems) = 1853 + if n = name then (true, mems) else (ok, ((n, meta), v) :: mems) 1854 + in 1855 + let dec_finish _meta ((_ok, ms) as a) = 1856 + if allow_absent then (true, ms) else a 1857 + in 1858 + update_value_object ~name ~dec_add ~dec_finish 1859 + 1860 + let fold_object t f acc = 1861 + let mems = 1862 + let dec_empty () = acc and dec_add = f and dec_finish _meta acc = acc in 1863 + let enc _f _ acc = acc in 1864 + Object.Members.map t ~dec_empty ~dec_add ~dec_finish 1865 + ~enc:{ Object.Members.enc } 1866 + in 1867 + Object.map Fun.id |> Object.keep_unknown mems ~enc:Fun.id |> Object.seal 1868 + 1869 + let filter_map_object a b f = 1870 + let dec_add meta n v (_, mems) = 1871 + match f meta n (decode_exn a v) with 1872 + | None -> (true, mems) 1873 + | Some (n', v') -> (true, (n', encode_exn b v') :: mems) 1874 + in 1875 + let dec_finish _meta acc = acc in 1876 + update_value_object ~name:"" ~dec_add ~dec_finish 1877 + 1878 + (* Index queries *) 1879 + 1880 + (* Foreign path steps (introduced by other formats via the extensible 1881 + [Path.step]) are projected to [Mem <pp>]: any step pretty-prints to a 1882 + string, so treat it as a name-addressed member by that stringification. 1883 + Worst case this yields a no-op query against a JSON object that does not 1884 + hold a member of that name. *) 1885 + let step_as_mem s = Fmt.str "%a" Path.pp_step s 1886 + 1887 + let index ?absent i t = 1888 + match (i : Path.step) with 1889 + | Path.Nth (n, _) -> nth ?absent n t 1890 + | Path.Mem (n, _) -> member ?absent n t 1891 + | s -> member ?absent (step_as_mem s) t 1892 + 1893 + let set_index ?allow_absent t i v = 1894 + match (i : Path.step) with 1895 + | Path.Nth (n, _) -> set_nth ?allow_absent t n v 1896 + | Path.Mem (n, _) -> set_member ?allow_absent t n v 1897 + | s -> set_member ?allow_absent t (step_as_mem s) v 1898 + 1899 + let update_index ?stub ?absent i t = 1900 + match (i : Path.step) with 1901 + | Path.Nth (n, _) -> update_nth ?stub ?absent n t 1902 + | Path.Mem (n, _) -> update_member ?absent n t 1903 + | s -> update_member ?absent (step_as_mem s) t 1904 + 1905 + let delete_index ?allow_absent = function 1906 + | Path.Nth (n, _) -> delete_nth ?allow_absent n 1907 + | Path.Mem (n, _) -> delete_member ?allow_absent n 1908 + | s -> delete_member ?allow_absent (step_as_mem s) 1909 + 1910 + (* Path queries *) 1911 + 1912 + let path ?absent p q = 1913 + List.fold_left (fun q i -> index ?absent i q) q (Path.rev_steps p) 1914 + 1915 + let update_path ?stub ?absent p t = 1916 + match Path.rev_steps p with 1917 + | [] -> update t 1918 + | i :: is -> ( 1919 + match absent with 1920 + | None -> 1921 + let u t i = update_index i t in 1922 + List.fold_left u (update_index i t) is 1923 + | Some absent -> ( 1924 + let rec loop absent t = function 1925 + | Path.Nth (n, _) :: is -> 1926 + loop Ast.empty_array (update_nth ~absent n t) is 1927 + | Path.Mem (n, _) :: is -> 1928 + loop Ast.empty_object (update_member ~absent n t) is 1929 + | [] -> t 1930 + | s :: is -> 1931 + loop Ast.empty_object 1932 + (update_member ~absent (step_as_mem s) t) 1933 + is 1934 + in 1935 + match i with 1936 + | Path.Nth (n, _) -> 1937 + loop Ast.empty_array (update_nth ?stub ~absent n t) is 1938 + | Path.Mem (n, _) -> 1939 + loop Ast.empty_object (update_member ~absent n t) is 1940 + | s -> 1941 + loop Ast.empty_object (update_member ~absent (step_as_mem s) t) is 1942 + )) 1943 + 1944 + let null_value : Ast.t = Ast.Null ((), Meta.none) 1945 + 1946 + let delete_path ?allow_absent p = 1947 + match Path.rev_steps p with 1948 + | [] -> recode ~dec:ignore (fun () -> null_value) ~enc:Value.t 1949 + | i :: is -> 1950 + let upd del i = update_index i del in 1951 + List.fold_left upd (delete_index ?allow_absent i) is 1952 + 1953 + let set_path ?stub ?(allow_absent = false) t p v = 1954 + match Path.rev_steps p with 1955 + | [] -> recode ~dec:ignore (fun () -> encode_exn t v) ~enc:Value.t 1956 + | _ :: _ -> 1957 + let absent = if allow_absent then Some v else None in 1958 + update_path ?stub ?absent p (const t v)

+881 -15

lib/codec.mli

··· 283 283 284 284 (** {1:errors Errors} *) 285 285 286 - val error_push_array : 286 + val fail_push_array : 287 287 Meta.t -> ('array, 'elt, 'builder) array_map -> int node -> Error.t -> 'a 288 - (** [error_push_array] is like {!Error.push_array} but uses the given array 288 + (** [fail_push_array] is like {!Error.fail_push_array} but uses the given array 289 289 [meta] and array map to caracterize the context. *) 290 290 291 - val error_push_object : 291 + val fail_push_object : 292 292 Meta.t -> ('o, 'dec) object_map -> string node -> Error.t -> 'a 293 - (** [error_push_object] is like {!Error.push_object} but uses the given object 294 - [meta] and object map to caracterize the context. *) 293 + (** [fail_push_object] is like {!Error.fail_push_object} but uses the given 294 + object [meta] and object map to caracterize the context. *) 295 295 296 - val type_error : Meta.t -> 'a t -> fnd:Sort.t -> 'b 297 - (** [type_error meta ~exp ~fnd] errors when kind [exp] was expected but sort 298 - [fnd] was found. *) 296 + val fail_type_mismatch : Meta.t -> 'a t -> fnd:Sort.t -> 'b 297 + (** [fail_type_mismatch meta t ~fnd] errors when the kind expected by codec [t] 298 + does not match the actually-parsed sort [fnd]. *) 299 299 300 - val missing_mems_error : 300 + val fail_missing_members : 301 301 Meta.t -> 302 302 ('o, 'o) object_map -> 303 303 exp:mem_dec String_map.t -> 304 304 fnd:string list -> 305 305 'a 306 - (** [missing_mems_error m map exp fnd] errors when [exp] cannot be found, [fnd] 307 - can list a few members that were found. *) 306 + (** [fail_missing_members m map exp fnd] errors when [exp] cannot be found, 307 + [fnd] can list a few members that were found. *) 308 308 309 - val unexpected_mems_error : 309 + val fail_unexpected_members : 310 310 Meta.t -> ('o, 'o) object_map -> fnd:(string * Meta.t) list -> 'a 311 - (** [unexpected_mems_error meta map ~fnd] errors when [fnd] are unexpected 311 + (** [fail_unexpected_members meta map ~fnd] errors when [fnd] are unexpected 312 312 members for object [map]. *) 313 313 314 - val unexpected_case_tag_error : 314 + val fail_unexpected_case_tag : 315 315 Meta.t -> ('o, 'o) object_map -> ('o, 'd, 'tag) object_cases -> 'tag -> 'a 316 - (** [unexpected_case_tag_error meta map cases tag] is when a [tag] of a case 316 + (** [fail_unexpected_case_tag meta map cases tag] is when a [tag] of a case 317 317 member has no corresponding case. *) 318 318 319 319 (** {1:toolbox Processor toolbox} *) ··· 383 383 384 384 val pp_code : string Fmt.t 385 385 (** [pp_code] formats strings like code (in bold). *) 386 + 387 + (* ======================================================================== 388 + Codec combinators (moved from json.mli). 389 + ======================================================================== *) 390 + 391 + (** {1:combinators Codec combinators} *) 392 + 393 + module Ast = Value 394 + (** Alias for the generic JSON AST module. This stays accessible inside 395 + [open Codec] regions where the nested [Codec.Value] codec sub-module would 396 + shadow the [Value] AST module. *) 397 + 398 + type value = Value.t 399 + (** Alias for the generic JSON AST; codec signatures below produce/consume 400 + codecs over [Value.t]. *) 401 + 402 + type 'a codec = 'a t 403 + (** Alias for the codec type [t]. *) 404 + 405 + type name = Value.name 406 + (** The type for JSON member names. *) 407 + 408 + type member = Value.member 409 + (** The type for generic JSON object members. *) 410 + 411 + type object' = Value.object' 412 + (** The type for generic JSON objects. *) 413 + 414 + type number_format = Value.number_format 415 + (** The type for JSON number formatters. *) 416 + 417 + (** {1:base Base types} 418 + 419 + Read the {{!page-cookbook.base_types}cookbook} on base types. *) 420 + 421 + (** Mapping JSON base types. *) 422 + module Base : sig 423 + (** {1:maps Maps} *) 424 + 425 + type ('a, 'b) map 426 + (** The type for mapping JSON values of type ['a] to values of type ['b]. *) 427 + 428 + val map : 429 + ?kind:string -> 430 + ?doc:string -> 431 + ?dec:(Meta.t -> 'a -> 'b) -> 432 + ?enc:('b -> 'a) -> 433 + ?enc_meta:('b -> Meta.t) -> 434 + unit -> 435 + ('a, 'b) map 436 + (** [map ~kind ~doc ~dec ~enc ~enc_meta ()] maps JSON base types represented 437 + by value of type ['a] to values of type ['b] with: 438 + - [kind] names the entities represented by the map and [doc] documents 439 + them. Both default to [""]. 440 + - [dec] is used to decode values of type ['a] to values of type ['b]. Can 441 + be omitted if the map is only used for encoding, the default 442 + unconditionally errors. 443 + - [enc] is used to encode values of type ['b] to values of type ['a]. Can 444 + be omitted if the map is only used for decoding, the default 445 + unconditionally errors. 446 + - [enc_meta] is used to recover JSON metadata (source text layout 447 + information) from a value to encode. The default unconditionnaly returns 448 + {!Json.Meta.none}. 449 + 450 + {{!decenc}These functions} can be used to quickly devise [dec] and [enc] 451 + functions from standard OCaml conversion interfaces. *) 452 + 453 + val id : ('a, 'a) map 454 + (** [id] is the identity map. *) 455 + 456 + val ignore : ('a, unit) map 457 + (** [ignore] is the ignoring map. It ignores decodes and errors on encodes. *) 458 + 459 + (** {2:types JSON types} *) 460 + 461 + val null : (unit, 'a) map -> 'a t 462 + (** [null map] maps with [map] JSON nulls represented by [()] to values of 463 + type ['a]. See also {!Codec.null}. *) 464 + 465 + val bool : (bool, 'a) map -> 'a t 466 + (** [bool map] maps with [map] JSON booleans represented by [bool] values to 467 + values of type ['a]. See also {!Codec.bool}. *) 468 + 469 + val number : (float, 'a) map -> 'a t 470 + (** [number map] maps with [map] JSON nulls or numbers represented by [float] 471 + values to values of type ['a]. The [float] representation decodes JSON 472 + nulls to {!Float.nan} and lossily encodes any 473 + {{!Float.is_finite}non-finite} to JSON null 474 + ({{!page-cookbook.non_finite_numbers}explanation}). See also 475 + {!Codec.number}. *) 476 + 477 + val string : (string, 'a) map -> 'a t 478 + (** [string map] maps with [map] {e unescaped} JSON strings represented by 479 + UTF-8 encoded [string] values to values of type ['a]. See also 480 + {!Codec.string}. *) 481 + 482 + (** {1:decenc Decoding and encoding functions} 483 + 484 + These function create suitable [dec] and [enc] functions to give to 485 + {!val-map} from standard OCaml conversion interfaces. See also 486 + {!Codec.of_of_string}. *) 487 + 488 + val dec : ('a -> 'b) -> Meta.t -> 'a -> 'b 489 + (** [dec f] is a decoding function from [f]. This assumes [f] never fails. *) 490 + 491 + val dec_result : 492 + ?kind:string -> ('a -> ('b, string) result) -> Meta.t -> 'a -> 'b 493 + (** [dec f] is a decoding function from [f]. [Error _] values are given to 494 + {!Error.msg}, prefixed by [kind:] (if specified). *) 495 + 496 + val dec_failure : ?kind:string -> ('a -> 'b) -> Meta.t -> 'a -> 'b 497 + (** [dec f] is a decoding function from [f]. [Failure _] exceptions are 498 + catched and given to {!Error.msg}, prefixed by [kind:] (if specified). *) 499 + 500 + val enc : ('b -> 'a) -> 'b -> 'a 501 + (** [enc f] is an encoding function from [f]. This assumes [f] never fails. *) 502 + 503 + val enc_result : ?kind:string -> ('b -> ('a, string) result) -> 'b -> 'a 504 + (** [enc_result f] is an encoding function from [f]. [Error _] values are 505 + given to {!Error.msg}, prefixed by [kind:] (if specified). *) 506 + 507 + val enc_failure : ?kind:string -> ('b -> 'a) -> 'b -> 'a 508 + (** [enc_failure f] is an encoding function from [f]. [Failure _] exceptions 509 + are catched and given to {!Error.msg}, prefixed by [kind:] (if specified). 510 + *) 511 + end 512 + 513 + (** {2:option Nulls and options} 514 + 515 + Read the {{!page-cookbook.dealing_with_null}cookbook} on [null]s. *) 516 + 517 + val null : ?kind:string -> ?doc:string -> 'a -> 'a t 518 + (** [null v] maps JSON nulls to [v]. On encodes any value of type ['a] is 519 + encoded by null. [doc] and [kind] are given to the underlying 520 + {!Base.type-map}. See also {!Base.null}. *) 521 + 522 + val none : 'a option t 523 + (** [none] maps JSON nulls to [None]. *) 524 + 525 + val some : 'a t -> 'a option t 526 + (** [some t] maps JSON like [t] does but wraps results in [Some]. Encoding fails 527 + if the value is [None]. *) 528 + 529 + val option : ?kind:string -> ?doc:string -> 'a t -> 'a option t 530 + (** [option t] maps JSON nulls to [None] and other values by [t]. [doc] and 531 + [kind] are given to the underlying {!val-any} map. *) 532 + 533 + (** {2:booleans Booleans} *) 534 + 535 + val bool : bool t 536 + (** [bool] maps JSON booleans to [bool] values. See also {!Base.bool}. *) 537 + 538 + (** {2:numbers Numbers} 539 + 540 + Read the {{!page-cookbook.dealing_with_numbers}cookbook} on JSON numbers and 541 + their many pitfalls. *) 542 + 543 + val number : float t 544 + (** [number] maps JSON nulls or numbers to [float] values. On decodes JSON null 545 + is mapped to {!Float.nan}. On encodes any {{!Float.is_finite}non- finite} 546 + float is lossily mapped to JSON null 547 + ({{!page-cookbook.non_finite_numbers}explanation}). See also {!Base.number}, 548 + {!any_float} and the integer combinators below. *) 549 + 550 + val any_float : float t 551 + (** [any_float] is a lossless representation for IEEE 754 doubles. It maps 552 + {{!Float.is_finite}non-finite} floats by the JSON strings defined by 553 + {!Float.to_string}. This contrasts with {!val-number} which maps them to 554 + JSON null values ({{!page-cookbook.non_finite_numbers}explanation}). Note 555 + that on decodes this still maps JSON nulls to {!Float.nan} and any 556 + successful string decode of {!Float.of_string_opt} (so numbers can also be 557 + written as strings). See also {!val-number}. 558 + 559 + {b Warning.} [any_float] should only be used between parties that have 560 + agreed on such an encoding. To maximize interoperability you should use the 561 + lossy {!val-number} map. *) 562 + 563 + val float_as_hex_string : float t 564 + (** [float_as_hex_string] maps JSON strings made of IEEE 754 doubles in hex 565 + notation to float values. On encodes strings this uses the ["%h"] format 566 + string. On decodes it accepts anything sucessfully decoded by 567 + {!Float.of_string_opt}. *) 568 + 569 + val uint8 : int t 570 + (** [uint8] maps JSON numbers to unsigned 8-bit integers. JSON numbers are 571 + sucessfully decoded if after truncation they can be represented on the 572 + \[0;255\] range. Encoding errors if the integer is out of range. *) 573 + 574 + val uint16 : int t 575 + (** [uint16] maps JSON numbers to unsigned 16-bit integers. JSON numbers are 576 + sucessfully decoded if after truncation they can be represented on the 577 + \[0;65535\] range. Encoding errors if the integer is out of range. *) 578 + 579 + val int8 : int t 580 + (** [int8] maps JSON numbers to 8-bit integers. JSON numbers are sucessfully 581 + decoded if after truncation they can be represented on the \[-128;127\] 582 + range. Encoding errors if the integer is out of range. *) 583 + 584 + val int16 : int t 585 + (** [int16] maps JSON numbers to 16-bit integers. JSON numbers are sucessfully 586 + decoded if after truncation they can be represented on the \[-32768;32767\] 587 + range. Encoding errors if the integer is out of range. *) 588 + 589 + val int32 : int32 t 590 + (** [int32] maps JSON numbers to 32-bit integers. JSON numbers are sucessfully 591 + decoded if after truncation they can be represented on the [int32] range, 592 + otherwise the decoder errors. *) 593 + 594 + val int64 : int64 t 595 + (** [int64] maps truncated JSON numbers or JSON strings to 64-bit integers. 596 + - JSON numbers are sucessfully decoded if after truncation they can be 597 + represented on the [int64] range, otherwise the decoder errors. [int64] 598 + values are encoded as JSON numbers if the integer is in the 599 + \[-2{^ 53};2{^ 53}\] range. 600 + - JSON strings are decoded using {!int_of_string_opt}, this allows binary, 601 + octal, decimal and hex syntaxes and errors on overflow and syntax errors. 602 + [int64] values are encoded as JSON strings with {!Int64.to_string} when 603 + the integer is outside the \[-2{^ 53};2{^ 53}\] range. *) 604 + 605 + val int64_as_string : int64 t 606 + (** [int64_as_string] maps JSON strings to 64-bit integers. On decodes this uses 607 + {!Int64.of_string_opt} which allows binary, octal, decimal and hex syntaxes 608 + and errors on overflow and syntax errors. On encodes uses 609 + {!Int64.to_string}. *) 610 + 611 + val int : int t 612 + (** [int] maps truncated JSON numbers or JSON strings to [int] values. 613 + - JSON numbers are sucessfully decoded if after truncation they can be 614 + represented on the [int] range, otherwise the decoder errors. [int] values 615 + are encoded as JSON numbers if the integer is in the \[-2{^ 53};2{^ 53}\] 616 + range. 617 + - JSON strings are decoded using {!int_of_string_opt}, this allows binary, 618 + octal, decimal and hex syntaxes and errors on overflow and syntax errors. 619 + [int] values are encoded as JSON strings with {!Int.to_string} when the 620 + integer is outside the \[-2{^ 53};2{^ 53}\] range 621 + 622 + {b Warning.} The behaviour of this function is platform dependent, it 623 + depends on the value of {!Sys.int_size}. *) 624 + 625 + val int_as_string : int t 626 + (** [int_as_string] maps JSON strings to [int] values. On decodes this uses 627 + {!int_of_string_opt} which allows binary, octal, decimal and hex syntaxes 628 + and errors on overflow and syntax errors. On encodes uses {!Int.to_string}. 629 + 630 + {b Warning.} The behaviour of this function is platform dependent, it 631 + depends on the value of {!Sys.int_size}. *) 632 + 633 + (** {2:enums Strings and enums} 634 + 635 + Read the {{!page-cookbook.transform_strings}cookbook} on transforming 636 + strings. *) 637 + 638 + val string : string t 639 + (** [string] maps unescaped JSON strings to UTF-8 encoded [string] values. See 640 + also {!Base.string}. 641 + 642 + {b Warning.} Encoders assume OCaml [string]s have been checked for UTF-8 643 + validity. *) 644 + 645 + val of_of_string : 646 + ?kind:string -> 647 + ?doc:string -> 648 + ?enc:('a -> string) -> 649 + (string -> ('a, string) result) -> 650 + 'a t 651 + (** [of_of_string of_string] maps JSON string with a {{!Base.type-map}base map} 652 + using [of_string] for decoding and [enc] for encoding. See the 653 + {{!page-cookbook.transform_strings}cookbook}. *) 654 + 655 + val enum : 656 + ?cmp:('a -> 'a -> int) -> 657 + ?kind:string -> 658 + ?doc:string -> 659 + (string * 'a) list -> 660 + 'a t 661 + (** [enum assoc] maps JSON strings member of the [assoc] list to the 662 + corresponding OCaml value and vice versa in log(n). [cmp] is used to compare 663 + the OCaml values, it defaults to {!Stdlib.compare}. Decoding and encoding 664 + errors on strings or values not part of [assoc]. *) 665 + 666 + val binary_string : string t 667 + (** [binary_string] maps JSON strings made of an even number of hexdecimal 668 + US-ASCII upper or lower case digits to the corresponding byte sequence. On 669 + encoding uses only lower case hexadecimal digits to encode the byte 670 + sequence. *) 671 + 672 + (** {1:arrays Arrays and tuples} 673 + 674 + Read the {{!page-cookbook.dealing_with_arrays}cookbok} on arrays. *) 675 + 676 + (** Mapping JSON arrays. *) 677 + module Array : sig 678 + (** {1:maps Maps} *) 679 + 680 + type ('array, 'elt) enc = { 681 + enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; 682 + } 683 + (** The type for specifying array encoding functions. A function to fold over 684 + the elements of type ['elt] of the array of type ['array]. *) 685 + 686 + type ('array, 'elt, 'builder) map 687 + (** The type for mapping JSON arrays with elements of type ['elt] to arrays of 688 + type ['array] using values of type ['builder] to build them. *) 689 + 690 + val map : 691 + ?kind:string -> 692 + ?doc:string -> 693 + ?dec_empty:(unit -> 'builder) -> 694 + ?dec_skip:(int -> 'builder -> bool) -> 695 + ?dec_add:(int -> 'elt -> 'builder -> 'builder) -> 696 + ?dec_finish:(Meta.t -> int -> 'builder -> 'array) -> 697 + ?enc:('array, 'elt) enc -> 698 + ?enc_meta:('array -> Meta.t) -> 699 + 'elt t -> 700 + ('array, 'elt, 'builder) map 701 + (** [map elt] maps JSON arrays of type ['elt] to arrays of type ['array] built 702 + with type ['builder]. See the {!Json.Codec.Array} documentation for 703 + argument descriptions. *) 704 + 705 + val list_map : 706 + ?kind:string -> 707 + ?doc:string -> 708 + ?dec_skip:(int -> 'a list -> bool) -> 709 + 'a t -> 710 + ('a list, 'a, 'a list) map 711 + (** [list_map elt] maps JSON arrays with elements of type [elt] to [list] 712 + values. See also {!Codec.list}. *) 713 + 714 + type 'a array_builder 715 + (** The type for array builders. *) 716 + 717 + val array_map : 718 + ?kind:string -> 719 + ?doc:string -> 720 + ?dec_skip:(int -> 'a array_builder -> bool) -> 721 + 'a t -> 722 + ('a array, 'a, 'a array_builder) map 723 + (** [array_map elt] maps JSON arrays with elements of type [elt] to [array] 724 + values. See also {!Codec.array}. *) 725 + 726 + type ('a, 'b, 'c) bigarray_builder 727 + (** The type for bigarray_builders. *) 728 + 729 + val bigarray_map : 730 + ?kind:string -> 731 + ?doc:string -> 732 + ?dec_skip:(int -> ('a, 'b, 'c) bigarray_builder -> bool) -> 733 + ('a, 'b) Bigarray.kind -> 734 + 'c Bigarray.layout -> 735 + 'a t -> 736 + (('a, 'b, 'c) Bigarray.Array1.t, 'a, ('a, 'b, 'c) bigarray_builder) map 737 + (** [bigarray k l elt] maps JSON arrays with elements of type [elt] to 738 + bigarray values of kind [k] and layout [l]. See also {!Codec.bigarray}. *) 739 + 740 + (** {1:types JSON types} *) 741 + 742 + val array : ('a, _, _) map -> 'a t 743 + (** [array map] maps with [map] JSON arrays to values of type ['a]. See the 744 + the {{!section-arrays}array combinators}. *) 745 + 746 + val ignore : unit t 747 + (** [ignore] ignores JSON arrays on decoding and errors on encoding. *) 748 + 749 + val zero : unit t 750 + (** [zero] ignores JSON arrays on decoding and encodes an empty array. *) 751 + end 752 + 753 + val list : ?kind:string -> ?doc:string -> 'a t -> 'a list t 754 + (** [list t] maps JSON arrays of type [t] to [list] values. See also 755 + {!Array.list_map}. *) 756 + 757 + val array : ?kind:string -> ?doc:string -> 'a t -> 'a array t 758 + (** [array t] maps JSON arrays of type [t] to [array] values. See also 759 + {!Array.array_map}. *) 760 + 761 + val array_as_string_map : 762 + ?kind:string -> 763 + ?doc:string -> 764 + key:('a -> string) -> 765 + 'a t -> 766 + 'a Map.Make(String).t t 767 + (** [array_as_string_map ~key t] maps JSON array elements of type [t] to string 768 + maps by indexing them with [key]. If two elements have the same [key] the 769 + element with the greatest index takes over. Elements of the map are encoded 770 + to a JSON array in (binary) key order. *) 771 + 772 + val bigarray : 773 + ?kind:string -> 774 + ?doc:string -> 775 + ('a, 'b) Bigarray.kind -> 776 + 'a t -> 777 + ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t t 778 + (** [bigarray k t] maps JSON arrays of type [t] to [Bigarray.Array1.t] values. 779 + See also {!Array.bigarray_map}. *) 780 + 781 + val t2 : 782 + ?kind:string -> 783 + ?doc:string -> 784 + ?dec:('a -> 'a -> 't2) -> 785 + ?enc:('t2 -> int -> 'a) -> 786 + 'a t -> 787 + 't2 t 788 + (** [t2 ?dec ?enc t] maps JSON arrays with exactly 2 elements of type [t] to 789 + value of type ['t2]. Decodes error if there are more elements. [enc v i] 790 + must return the zero-based [i]th element. *) 791 + 792 + val t3 : 793 + ?kind:string -> 794 + ?doc:string -> 795 + ?dec:('a -> 'a -> 'a -> 't3) -> 796 + ?enc:('t3 -> int -> 'a) -> 797 + 'a t -> 798 + 't3 t 799 + (** [t3] is like {!t2} but for 3 elements. *) 800 + 801 + val t4 : 802 + ?kind:string -> 803 + ?doc:string -> 804 + ?dec:('a -> 'a -> 'a -> 'a -> 't4) -> 805 + ?enc:('t4 -> int -> 'a) -> 806 + 'a t -> 807 + 't4 t 808 + (** [t4] is like {!t2} but for 4 elements. *) 809 + 810 + val tn : ?kind:string -> ?doc:string -> n:int -> 'a t -> 'a array t 811 + (** [tn ~n t] maps JSON arrays of exactly [n] elements of type [t] to [array] 812 + values. This is {!val-array} limited by [n]. *) 813 + 814 + (** {1:objects Objects} 815 + 816 + Read the {{!page-cookbook.dealing_with_objects}cookbook} on objects. *) 817 + 818 + (** Mapping JSON objects. *) 819 + module Object : sig 820 + (** {1:maps Maps} *) 821 + 822 + type ('o, 'dec) map 823 + (** The type for mapping JSON objects to values of type ['o]. The ['dec] type 824 + is used to construct ['o] from members see {!val-mem}. *) 825 + 826 + val map : ?kind:string -> ?doc:string -> 'dec -> ('o, 'dec) map 827 + (** [map dec] is an empty JSON object decoded by function [dec]. 828 + - [kind] names the entities represented by the map and [doc] documents 829 + them. Both default to [""]. 830 + - [dec] is a constructor eventually returning a value of type ['o] to be 831 + saturated with calls to {!val-mem}, {!val-case_mem} or 832 + {!val-keep_unknown}. This is needed for decoding. Use {!enc_only} if the 833 + result is only used for encoding. *) 834 + 835 + val map_with_meta : 836 + ?kind:string -> 837 + ?doc:string -> 838 + ?enc_meta:('o -> Meta.t) -> 839 + (Meta.t -> 'dec) -> 840 + ('o, 'dec) map 841 + (** [map_with_meta dec] is like {!val-map} except [dec] receives the object's 842 + decoding metadata and [?enc_meta] is used to recover it on encoding. *) 843 + 844 + val enc_only : 845 + ?kind:string -> 846 + ?doc:string -> 847 + ?enc_meta:('o -> Meta.t) -> 848 + unit -> 849 + ('o, 'a) map 850 + (** [enc_only ()] is like {!val-map'} but can only be used for encoding. *) 851 + 852 + val seal : ('o, 'o) map -> 'o t 853 + (** [seal map] is a JSON type for objects mapped by [map]. Raises 854 + [Invalid_argument] if [map] describes a member name more than once. *) 855 + 856 + (** {1:mems Members} *) 857 + 858 + (** Member maps. 859 + 860 + Usually it's better to use {!Json.Codec.Object.member} or 861 + {!Json.Codec.Object.opt_member} directly. But this may be useful in 862 + certain abstraction contexts. *) 863 + module Member : sig 864 + type ('o, 'dec) object_map := ('o, 'dec) map 865 + 866 + type ('o, 'a) map 867 + (** The type for mapping a member object to a value ['a] stored in an OCaml 868 + value of type ['o]. *) 869 + 870 + val map : 871 + ?doc:string -> 872 + ?dec_absent:'a -> 873 + ?enc:('o -> 'a) -> 874 + ?enc_omit:('a -> bool) -> 875 + string -> 876 + 'a codec -> 877 + ('o, 'a) map 878 + (** See {!Json.Codec.Object.member}. *) 879 + 880 + val app : ('o, 'a -> 'b) object_map -> ('o, 'a) map -> ('o, 'b) object_map 881 + (** [app map mmap] applies the member map [mmap] to the contructor of the 882 + object map [map]. In turn this adds the [mmap] member definition to the 883 + object described by [map]. *) 884 + end 885 + 886 + val member : 887 + ?doc:string -> 888 + ?dec_absent:'a -> 889 + ?enc:('o -> 'a) -> 890 + ?enc_omit:('a -> bool) -> 891 + string -> 892 + 'a codec -> 893 + ('o, 'a -> 'b) map -> 894 + ('o, 'b) map 895 + (** [member name t map] is a member named [name] of type [t] for an object of 896 + type ['o] being constructed by [map]. 897 + - [doc] is a documentation string for the member. Defaults to [""]. 898 + - [dec_absent], if specified, is the value used for the decoding direction 899 + when the member named [name] is missing. If unspecified decoding errors 900 + when the member is absent. 901 + - [enc] is used to project the member's value from the object 902 + representation ['o] for encoding to JSON with [t]. It can be omitted if 903 + the result is only used for decoding. 904 + - [enc_omit] is for the encoding direction. If the member value returned 905 + by [enc] returns [true] on [enc_omit], the member is omited in the 906 + encoded JSON object. Defaults to [Fun.const false]. *) 907 + 908 + val opt_member : 909 + ?doc:string -> 910 + ?enc:('o -> 'a option) -> 911 + string -> 912 + 'a codec -> 913 + ('o, 'a option -> 'b) map -> 914 + ('o, 'b) map 915 + (** [opt_member name t map] is: 916 + {[ 917 + let dec_absent = None and enc_omit = Option.is_none in 918 + Json.Codec.Object.member name (Json.Codec.some t) map ~dec_absent 919 + ~enc_omit 920 + ]} *) 921 + 922 + (** {1:cases Case objects} 923 + 924 + Read the {{!page-cookbook.cases}cookbook} on case objects. *) 925 + 926 + (** Case objects. *) 927 + module Case : sig 928 + (** {1:maps Maps} *) 929 + 930 + type 'a codec := 'a codec 931 + 932 + type ('cases, 'case, 'tag) map 933 + (** The type for mapping a case object. *) 934 + 935 + val map : 936 + ?dec:('case -> 'cases) -> 'tag -> 'case codec -> ('cases, 'case, 'tag) map 937 + (** [map ~dec v obj] defines the object map [obj] as being the case for the 938 + tag value [v] of the case member. [dec] indicates how to inject the 939 + object case into the type common to all cases. 940 + 941 + Raises [Invalid_argument] if [obj] is not a direct result of {!seal}, 942 + that is if [obj] does not describe an object. *) 943 + 944 + val map_tag : ('cases, 'case, 'tag) map -> 'tag 945 + (** [map_tag m] is [m]'s tag. *) 946 + 947 + (** {1:cases Cases} *) 948 + 949 + type ('cases, 'tag) t 950 + (** The type for a case of the type ['cases]. *) 951 + 952 + val make : ('cases, 'case, 'tag) map -> ('cases, 'tag) t 953 + (** [make map] is [map] as a case. *) 954 + 955 + val tag : ('cases, 'tag) t -> 'tag 956 + (** [tag c] is the tag of [c]. *) 957 + 958 + (** {1:case Case values} *) 959 + 960 + type ('cases, 'tag) value 961 + (** The type for case values. *) 962 + 963 + val value : ('cases, 'case, 'tag) map -> 'case -> ('cases, 'tag) value 964 + (** [value map v] is a case value [v] described by [map]. *) 965 + end 966 + 967 + val case_member : 968 + ?doc:string -> 969 + ?tag_compare:('tag -> 'tag -> int) -> 970 + ?tag_to_string:('tag -> string) -> 971 + ?dec_absent:'tag -> 972 + ?enc:('o -> 'cases) -> 973 + ?enc_omit:('tag -> bool) -> 974 + ?enc_case:('cases -> ('cases, 'tag) Case.value) -> 975 + string -> 976 + 'tag codec -> 977 + ('cases, 'tag) Case.t list -> 978 + ('o, 'cases -> 'a) map -> 979 + ('o, 'a) map 980 + (** [case_member name t cases map] is mostly like {!val-member} except the 981 + member [name] selects an object representation according to the member 982 + value of type [t]. *) 983 + 984 + (** {1:unknown_members Unknown members} 985 + 986 + Read the {{!page-cookbook.unknown_members}cookbook}. *) 987 + 988 + (** Uniform members. *) 989 + module Members : sig 990 + (** {1:maps Maps} *) 991 + 992 + type 'a codec := 'a codec 993 + 994 + type ('mems, 'a) enc = { 995 + enc : 996 + 'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc; 997 + } 998 + (** The type for specifying unknown members encoding function. *) 999 + 1000 + type ('mems, 'a, 'builder) map 1001 + (** The type for mapping members of uniform type ['a] to values of type 1002 + ['mems] using a builder of type ['builder]. *) 1003 + 1004 + val map : 1005 + ?kind:string -> 1006 + ?doc:string -> 1007 + ?dec_empty:(unit -> 'builder) -> 1008 + ?dec_add:(Meta.t -> string -> 'a -> 'builder -> 'builder) -> 1009 + ?dec_finish:(Meta.t -> 'builder -> 'mems) -> 1010 + ?enc:('mems, 'a) enc -> 1011 + 'a codec -> 1012 + ('mems, 'a, 'builder) map 1013 + (** [map type'] maps unknown members of uniform type ['a] to values of type 1014 + ['mems] built with type ['builder]. *) 1015 + 1016 + val string_map : 1017 + ?kind:string -> 1018 + ?doc:string -> 1019 + 'a codec -> 1020 + ('a Stdlib.Map.Make(String).t, 'a, 'a Stdlib.Map.Make(String).t) map 1021 + (** [string_map t] collects unknown member by name and types their values 1022 + with [t]. *) 1023 + end 1024 + 1025 + val skip_unknown : ('o, 'dec) map -> ('o, 'dec) map 1026 + (** [skip_unknown map] makes [map] skip unknown members. *) 1027 + 1028 + val error_unknown : ('o, 'dec) map -> ('o, 'dec) map 1029 + (** [error_unknown map] makes [map] error on unknown members. *) 1030 + 1031 + val keep_unknown : 1032 + ?enc:('o -> 'mems) -> 1033 + ('mems, _, _) Members.map -> 1034 + ('o, 'mems -> 'a) map -> 1035 + ('o, 'a) map 1036 + (** [keep_unknown mems map] makes [map] keep unknown member with [mems]. *) 1037 + 1038 + (** {1:types JSON types} *) 1039 + 1040 + val as_string_map : 1041 + ?kind:string -> 1042 + ?doc:string -> 1043 + 'a codec -> 1044 + 'a Stdlib.Map.Make(String).t codec 1045 + (** [as_string_map t] maps object to key-value maps of type [t]. *) 1046 + 1047 + val zero : unit codec 1048 + (** [zero] ignores JSON objects on decoding and encodes an empty object. *) 1049 + end 1050 + 1051 + (** {1:any Any value} 1052 + 1053 + Per {{:https://www.rfc-editor.org/rfc/rfc8259#section-3}RFC 8259 § 3}, a 1054 + JSON {e value} is one of [null], [true]/[false], a number, a string, an 1055 + array, or an object. *) 1056 + 1057 + val any : 1058 + ?kind:string -> 1059 + ?doc:string -> 1060 + ?dec_null:'a t -> 1061 + ?dec_bool:'a t -> 1062 + ?dec_number:'a t -> 1063 + ?dec_string:'a t -> 1064 + ?dec_array:'a t -> 1065 + ?dec_object:'a t -> 1066 + ?enc:('a -> 'a t) -> 1067 + unit -> 1068 + 'a t 1069 + (** [any ()] maps subsets of JSON values of different 1070 + {{:https://www.rfc-editor.org/rfc/rfc8259#section-3}sorts} to values of type 1071 + ['a]. *) 1072 + 1073 + (** {1:maps Maps & recursion} *) 1074 + 1075 + val map : 1076 + ?kind:string -> 1077 + ?doc:string -> 1078 + ?dec:('a -> 'b) -> 1079 + ?enc:('b -> 'a) -> 1080 + 'a t -> 1081 + 'b t 1082 + (** [map t] changes the type of [t] from ['a] to ['b]. For mapping base types 1083 + use {!Base.map}. *) 1084 + 1085 + val iter : 1086 + ?kind:string -> 1087 + ?doc:string -> 1088 + ?dec:('a -> unit) -> 1089 + ?enc:('a -> unit) -> 1090 + 'a t -> 1091 + 'a t 1092 + (** [iter ?enc dec t] applies [dec] on decoding and [enc] on encoding but 1093 + otherwise behaves like [t] does. *) 1094 + 1095 + val fix : 'a t Lazy.t -> 'a t 1096 + (** [fix] maps recursive JSON values. *) 1097 + 1098 + (** {1:ignoring Ignoring} *) 1099 + 1100 + val ignore : unit t 1101 + (** [ignore] lossily maps all JSON values to [()] on decoding and errors on 1102 + encoding. *) 1103 + 1104 + val zero : unit t 1105 + (** [zero] lossily maps all JSON values to [()] on decoding and encodes JSON 1106 + nulls. *) 1107 + 1108 + val todo : ?kind:string -> ?doc:string -> ?dec_stub:'a -> unit -> 'a t 1109 + (** [todo ?dec_stub ()] maps all JSON values to [dec_stub] if specified (errors 1110 + otherwise) and errors on encoding. *) 1111 + 1112 + (** {1:generic_ast Generic AST codecs} 1113 + 1114 + Codecs that preserve the generic {!value} AST. *) 1115 + 1116 + module Value : sig 1117 + val t : value t 1118 + (** [t] maps any JSON value to its generic representation. Use {!val-any} with 1119 + [dec_*] arguments to restrict to a subset of sorts. *) 1120 + 1121 + val null : value t 1122 + (** [null] decodes JSON nulls to {!Null} and encodes {!Null} values. *) 1123 + 1124 + val bool : value t 1125 + (** [bool] decodes JSON booleans to {!Bool} and encodes {!Bool} values. *) 1126 + 1127 + val number : value t 1128 + (** [number] decodes JSON numbers to {!Number} and encodes {!Number} values. 1129 + *) 1130 + 1131 + val string : value t 1132 + (** [string] decodes JSON strings to {!String} and encodes {!String} values. 1133 + *) 1134 + 1135 + val array : value t 1136 + (** [array] decodes JSON arrays to {!Array} and encodes {!Array} values. *) 1137 + 1138 + val object' : value t 1139 + (** [object'] decodes JSON objects to {!Object} and encodes {!Object} values. 1140 + *) 1141 + 1142 + val members : (value, value, member list) Object.Members.map 1143 + (** [members] is a {!Object.Members.map} for the generic {!member list} type. 1144 + *) 1145 + end 1146 + 1147 + (** {1:queries Queries and updates} 1148 + 1149 + Queries are lossy or aggregating decodes. Updates yield codecs that decode 1150 + to generic {!value} values but transform the data along the way. They allow 1151 + to process JSON data without having to fully model it. *) 1152 + 1153 + val const : 'a t -> 'a -> 'a t 1154 + (** [const t v] maps any JSON value to [v] on decodes and unconditionally 1155 + encodes [v] with [t]. *) 1156 + 1157 + val recode : dec:'a t -> ('a -> 'b) -> enc:'b t -> 'b t 1158 + (** [recode ~dec f ~enc] maps on decodes like [dec] does followed by [f] and on 1159 + encodes uses [enc]. *) 1160 + 1161 + val update : 'a t -> value t 1162 + (** [update t] decodes any JSON with [t] and directly encodes it back with [t] 1163 + to yield the decode result. *) 1164 + 1165 + (** {2:array_queries Arrays} *) 1166 + 1167 + val nth : ?absent:'a -> int -> 'a t -> 'a t 1168 + (** [nth n t] decodes the [n]th index of a JSON array with [t]. *) 1169 + 1170 + val set_nth : ?stub:value -> ?allow_absent:bool -> 'a t -> int -> 'a -> value t 1171 + (** [set_nth t n v] on decodes sets the [n]th value to [v]. *) 1172 + 1173 + val update_nth : ?stub:value -> ?absent:'a -> int -> 'a t -> value t 1174 + (** [update_nth n t] recodes the [n]th value of a JSON array with [t]. *) 1175 + 1176 + val delete_nth : ?allow_absent:bool -> int -> value t 1177 + (** [delete_nth n] drops the [n]th index of a JSON array. *) 1178 + 1179 + val filter_map_array : 'a t -> 'b t -> (int -> 'a -> 'b option) -> value t 1180 + (** [filter_map_array a b f] maps the [a] elements with [f] to [b] elements or 1181 + deletes them on [None]. *) 1182 + 1183 + val fold_array : 'a t -> (int -> 'a -> 'b -> 'b) -> 'b -> 'b t 1184 + (** [fold_array t f acc] folds [f] over the [t] elements of a JSON array. *) 1185 + 1186 + (** {2:object_queries Objects} *) 1187 + 1188 + val member : ?absent:'a -> string -> 'a t -> 'a t 1189 + (** [member name t] decodes the member named [name] of a JSON object with [t]. 1190 + *) 1191 + 1192 + val set_member : ?allow_absent:bool -> 'a t -> string -> 'a -> value t 1193 + (** [set_member t name v] sets the member value of [name] to an encoding of [v]. 1194 + *) 1195 + 1196 + val update_member : ?absent:'a -> string -> 'a t -> value t 1197 + (** [update_member name t] recodes the member value of [name]. *) 1198 + 1199 + val delete_member : ?allow_absent:bool -> string -> value t 1200 + (** [delete_member name] deletes the member named [name]. *) 1201 + 1202 + val filter_map_object : 1203 + 'a t -> 'b t -> (Meta.t -> string -> 'a -> (name * 'b) option) -> value t 1204 + (** [filter_map_object a b f] maps the [a] members with [f] to [(n, b)] members 1205 + or deletes them on [None]. *) 1206 + 1207 + val fold_object : 'a t -> (Meta.t -> string -> 'a -> 'b -> 'b) -> 'b -> 'b t 1208 + (** [fold_object t f acc] folds [f] over the [t] members of a JSON object. *) 1209 + 1210 + (** {2:index_queries Indices} *) 1211 + 1212 + val index : ?absent:'a -> Path.step -> 'a t -> 'a t 1213 + (** [index] uses {!val-nth} or {!val-mem} on the given index. *) 1214 + 1215 + val set_index : ?allow_absent:bool -> 'a t -> Path.step -> 'a -> value t 1216 + (** [set_index] uses {!set_nth} or {!set_mem} on the given index. *) 1217 + 1218 + val update_index : ?stub:value -> ?absent:'a -> Path.step -> 'a t -> value t 1219 + (** [update_index] uses {!update_nth} or {!update_mem}. *) 1220 + 1221 + val delete_index : ?allow_absent:bool -> Path.step -> value t 1222 + (** [delete_index] uses {!delete_nth} or {!delete_mem}. *) 1223 + 1224 + (** {2:path_queries Paths} *) 1225 + 1226 + val path : ?absent:'a -> Path.t -> 'a t -> 'a t 1227 + (** [path p t] decodes with [t] on the last index of [p]. *) 1228 + 1229 + val set_path : 1230 + ?stub:value -> ?allow_absent:bool -> 'a t -> Path.t -> 'a -> value t 1231 + (** [set_path t p v] sets the last index of [p]. *) 1232 + 1233 + val update_path : ?stub:value -> ?absent:'a -> Path.t -> 'a t -> value t 1234 + (** [update_path p t] updates the last index of [p] with [t]. *) 1235 + 1236 + val delete_path : ?allow_absent:bool -> Path.t -> value t 1237 + (** [delete_path p] deletes the last index of [p]. *) 1238 + 1239 + (** {1:runtime Runtime} *) 1240 + 1241 + val decode : 'a t -> value -> ('a, Error.t) result 1242 + (** [decode t v] decodes [v] as a value of type ['a] according to [t]. *) 1243 + 1244 + val decode_exn : 'a t -> value -> 'a 1245 + (** [decode_exn] is like {!val-decode} but raises the exception {!Error}. *) 1246 + 1247 + val encode : 'a t -> 'a -> (value, Error.t) result 1248 + (** [encode t v] encodes [v] as a generic JSON value according to [t]. *) 1249 + 1250 + val encode_exn : 'a t -> 'a -> value 1251 + (** [encode_exn] is like {!val-encode} but raises the exception {!Error}. *)

+1

lib/core.ml

··· 173 173 174 174 let pf = Fmt.pf 175 175 let str = Fmt.str 176 + let kstr = Fmt.kstr 176 177 let nop = Fmt.nop 177 178 let sp = Fmt.sp 178 179 let char = Fmt.char

+3

lib/core.mli

··· 75 75 val str : ('a, Format.formatter, unit, string) format4 -> 'a 76 76 (** [str] is {!Fmt.str}: format to a fresh string. *) 77 77 78 + val kstr : (string -> 'b) -> ('a, Format.formatter, unit, 'b) format4 -> 'a 79 + (** [kstr k fmt] is like {!str} but applies [k] to the result. *) 80 + 78 81 val disable_ansi_styler : unit -> unit 79 82 (** [disable_ansi_styler ()] turns off ANSI color/bold escapes. *) 80 83

+97 -31

lib/error.ml

··· 1 - (* Json-specific error module. Extends Loc.Error with JSON-typed error 2 - kinds and high-level message helpers used by the codec. *) 1 + (* Json-specific error module. JSON-typed error kinds plus high-level message 2 + helpers used by the codec. 3 + 4 + Every typed error ships as a pair: 5 + - [foo] builds an [Error.t] without raising. 6 + - [fail_foo] raises with the same error. *) 3 7 4 8 module Fmt = Core.Fmt 5 9 module Sort = Sort 10 + module Meta = Loc.Meta 11 + module Context = Loc.Context 6 12 13 + type 'a node = 'a Loc.node 14 + type byte_pos = Loc.byte_pos 15 + type line_num = Loc.line_num 7 16 type kind = Loc.Error.kind = .. 8 17 9 18 type Loc.Error.kind += ··· 22 31 Fmt.pf ppf "Expected %a but found %a" Fmt.code exp Sort.pp fnd) 23 32 | _ -> None) 24 33 25 - type t = Loc.Error.t = { ctx : Loc.Context.t; meta : Loc.Meta.t; kind : kind } 34 + type t = Loc.Error.t = { ctx : Context.t; meta : Meta.t; kind : kind } 26 35 27 36 let kind_to_string = Loc.Error.kind_to_string 28 37 let v = Loc.Error.v 29 38 let msg = Loc.Error.msg 30 - let raise = Loc.Error.raise 31 - let fail = Loc.Error.fail 32 - let failf = Loc.Error.failf 33 - let msgf = Loc.Error.failf 34 - let push_array = Loc.Error.push_array 35 - let push_object = Loc.Error.push_object 39 + let raise e = Stdlib.raise (Loc.Error e) 40 + let fail = Loc.Error.raise 41 + let msgf meta fmt = Fmt.kstr (fun s -> msg ~ctx:Context.empty ~meta s) fmt 42 + let failf meta fmt = Fmt.kstr (fun s -> Loc.Error.fail meta s) fmt 43 + 44 + (* Context pushers: both transform-only (t -> t) and raising (t -> 'a) *) 45 + 46 + let push_array sort n (e : t) : t = 47 + { e with ctx = Context.push_nth sort n e.ctx } 48 + 49 + let push_object sort n (e : t) : t = 50 + { e with ctx = Context.push_mem sort n e.ctx } 51 + 52 + let fail_push_array = Loc.Error.push_array 53 + let fail_push_object = Loc.Error.push_object 36 54 let adjust_context = Loc.Error.adjust_context 37 55 let pp = Loc.Error.pp 38 56 let to_string = Loc.Error.to_string 39 57 let puterr = Loc.Error.puterr 40 - let disable_ansi_styler = Fmt.disable_ansi_styler 58 + 59 + (* Private Fmt helpers used by the typed builders below. *) 41 60 let pp_kind = Fmt.code 42 - let pp_kind_opt ppf kind = if kind = "" then () else pp_kind ppf kind 43 61 let pp_int ppf i = Fmt.code ppf (Int.to_string i) 44 62 63 + (* Typed errors — (builder, raiser) pairs. 64 + 65 + Each [fail_foo] mirrors [foo] but raises directly via the underlying 66 + [failf] / [fail] primitives. *) 67 + 45 68 let expected meta exp ~fnd = 46 69 msgf meta "Expected %a but found %a" Fmt.code exp Fmt.code fnd 70 + 71 + let fail_expected meta exp ~fnd = 72 + failf meta "Expected %a but found %a" Fmt.code exp Fmt.code fnd 47 73 48 74 let sort meta ~exp ~fnd = 49 - raise ~ctx:Loc.Context.empty ~meta (Sort_mismatch { exp; fnd }) 75 + v ~ctx:Context.empty ~meta (Sort_mismatch { exp; fnd }) 76 + 77 + let fail_sort meta ~exp ~fnd = 78 + fail ~ctx:Context.empty ~meta (Sort_mismatch { exp; fnd }) 50 79 51 80 let kinded_sort meta ~exp ~fnd = 52 - raise ~ctx:Loc.Context.empty ~meta (Kinded_sort_mismatch { exp; fnd }) 81 + v ~ctx:Context.empty ~meta (Kinded_sort_mismatch { exp; fnd }) 53 82 54 - let missing_mems meta ~kinded_sort ~exp ~fnd = 55 - let pp_miss ppf m = 56 - Fmt.pf ppf "@[%a%a@]" Fmt.code m Fmt.similar_mems (m, fnd) 57 - in 83 + let fail_kinded_sort meta ~exp ~fnd = 84 + fail ~ctx:Context.empty ~meta (Kinded_sort_mismatch { exp; fnd }) 85 + 86 + let pp_missing fnd ppf m = 87 + Fmt.pf ppf "@[%a%a@]" Fmt.code m Fmt.similar_mems (m, fnd) 88 + 89 + let missing_members meta ~kinded_sort ~exp ~fnd = 58 90 match exp with 59 91 | [ n ] -> 60 92 msgf meta "@[<v>Missing member %a in %a%a@]" Fmt.code n Fmt.code 61 93 kinded_sort Fmt.similar_mems (n, fnd) 62 94 | exp -> 63 95 msgf meta "@[<v1>Missing members in %a:@,%a@]" Fmt.code kinded_sort 64 - (Fmt.list pp_miss) exp 96 + (Fmt.list (pp_missing fnd)) 97 + exp 65 98 66 - let unexpected_mems meta ~kinded_sort ~exp ~fnd = 67 - let pp_unexp ppf m = 68 - Fmt.pf ppf " @[%a%a@]" Fmt.code m Fmt.should_it_be_mem (m, exp) 69 - in 99 + let fail_missing_members meta ~kinded_sort ~exp ~fnd = 100 + match exp with 101 + | [ n ] -> 102 + failf meta "@[<v>Missing member %a in %a%a@]" Fmt.code n Fmt.code 103 + kinded_sort Fmt.similar_mems (n, fnd) 104 + | exp -> 105 + failf meta "@[<v1>Missing members in %a:@,%a@]" Fmt.code kinded_sort 106 + (Fmt.list (pp_missing fnd)) 107 + exp 108 + 109 + let pp_unexpected exp ppf m = 110 + Fmt.pf ppf " @[%a%a@]" Fmt.code m Fmt.should_it_be_mem (m, exp) 111 + 112 + let unexpected_members meta ~kinded_sort ~exp ~fnd = 70 113 match fnd with 71 114 | [ (u, _) ] -> 72 115 msgf meta "@[<v>Unexpected member %a for %a%a@]" Fmt.code u Fmt.code 73 116 kinded_sort Fmt.should_it_be_mem (u, exp) 74 117 | us -> 75 118 msgf meta "@[<v1>Unexpected members for %a:@,%a@]" Fmt.code kinded_sort 76 - (Fmt.list pp_unexp) (List.map fst us) 119 + (Fmt.list (pp_unexpected exp)) 120 + (List.map fst us) 77 121 78 - let unexpected_case_tag meta ~kinded_sort ~mem_name ~exp ~fnd = 122 + let fail_unexpected_members meta ~kinded_sort ~exp ~fnd = 123 + match fnd with 124 + | [ (u, _) ] -> 125 + failf meta "@[<v>Unexpected member %a for %a%a@]" Fmt.code u Fmt.code 126 + kinded_sort Fmt.should_it_be_mem (u, exp) 127 + | us -> 128 + failf meta "@[<v1>Unexpected members for %a:@,%a@]" Fmt.code kinded_sort 129 + (Fmt.list (pp_unexpected exp)) 130 + (List.map fst us) 131 + 132 + let unexpected_case_tag meta ~kinded_sort ~member_name ~exp ~fnd = 79 133 let pp_kind ppf () = 80 - Fmt.pf ppf "member %a value in %a" Fmt.code mem_name Fmt.code kinded_sort 134 + Fmt.pf ppf "member %a value in %a" Fmt.code member_name Fmt.code kinded_sort 81 135 in 82 136 msgf meta "@[%a@]" (Fmt.out_of_dom ~pp_kind ()) (fnd, exp) 83 137 138 + let fail_unexpected_case_tag meta ~kinded_sort ~member_name ~exp ~fnd = 139 + let pp_kind ppf () = 140 + Fmt.pf ppf "member %a value in %a" Fmt.code member_name Fmt.code kinded_sort 141 + in 142 + failf meta "@[%a@]" (Fmt.out_of_dom ~pp_kind ()) (fnd, exp) 143 + 84 144 let index_out_of_range meta ~n ~len = 85 145 msgf meta "Index %a out of range [%a;%a]" pp_int n pp_int 0 pp_int (len - 1) 86 146 147 + let fail_index_out_of_range meta ~n ~len = 148 + failf meta "Index %a out of range [%a;%a]" pp_int n pp_int 0 pp_int (len - 1) 149 + 87 150 let number_range meta ~kind n = 88 151 msgf meta "Number %a not in %a range" Fmt.code 89 152 (Fmt.str "%a" Fmt.json_number n) 90 153 Fmt.code kind 91 154 92 - let parse_string_number meta ~kind s = 93 - msgf meta "String %a does not parse to %a value" Fmt.json_string s pp_kind 94 - kind 155 + let fail_number_range meta ~kind n = 156 + failf meta "Number %a not in %a range" Fmt.code 157 + (Fmt.str "%a" Fmt.json_number n) 158 + Fmt.code kind 95 159 96 160 let integer_range meta ~kind n = 97 161 msgf meta "Integer %a not in %a range" pp_int n pp_kind kind 98 162 163 + let fail_integer_range meta ~kind n = 164 + failf meta "Integer %a not in %a range" pp_int n pp_kind kind 165 + 99 166 let no_decoder meta ~kind = msgf meta "No decoder for %a" pp_kind kind 167 + let fail_no_decoder meta ~kind = failf meta "No decoder for %a" pp_kind kind 100 168 let no_encoder meta ~kind = msgf meta "No encoder for %a" pp_kind kind 101 - let decode_todo meta ~kind_opt:k = msgf meta "TODO: decode%a" pp_kind_opt k 102 - let encode_todo meta ~kind_opt:k = msgf meta "TODO: encode%a" pp_kind_opt k 103 - let msg_with_kind meta ~kind e = msgf meta "%a: %s" pp_kind kind e 169 + let fail_no_encoder meta ~kind = failf meta "No encoder for %a" pp_kind kind

+127 -87

lib/error.mli

··· 1 - (** JSON-specific error helpers. Extends {!Loc.Error} with typed error kinds and 2 - high-level message helpers used by the codec. *) 1 + (** JSON-specific error helpers. JSON-typed error kinds plus high-level message 2 + helpers used by the codec. 3 + 4 + Every typed error comes in two flavours: 5 + - [foo] builds an [Error.t]. 6 + - [fail_foo] raises {!Json.exception-Error} with the same error. 7 + 8 + The primitive raiser is {!fail}; every [fail_foo] is {!fail} applied to the 9 + corresponding builder. *) 3 10 4 11 module Sort = Sort 12 + module Meta = Loc.Meta 13 + module Context = Loc.Context 14 + 15 + type 'a node = 'a Loc.node 16 + (** An AST node: data plus its metadata. *) 17 + 18 + type byte_pos = Loc.byte_pos 19 + (** Zero-based, absolute byte position in source text. *) 20 + 21 + type line_num = Loc.line_num 22 + (** One-based line number. *) 5 23 6 24 type kind = Loc.Error.kind = .. 7 - (** The type for error kinds. This is an alias for the extensible 8 - {!Loc.Error.kind}, re-exported so JSON-specific constructors appear in the 9 - same type. *) 25 + (** The type for error kinds. Extensible: each codec library adds its own typed 26 + constructors and registers a printer. *) 10 27 11 28 type Loc.Error.kind += 12 29 | Sort_mismatch of { exp : Sort.t; fnd : Sort.t } 13 30 | Kinded_sort_mismatch of { exp : string; fnd : Sort.t } 14 31 15 32 val kind_to_string : kind -> string 16 - (** [kind_to_string k] is a human-readable rendering of [k], using the printers 17 - registered with {!Loc.Error.register_kind_printer}. *) 33 + (** [kind_to_string k] renders [k] via the registered printers. *) 34 + 35 + type t = Loc.Error.t = { ctx : Context.t; meta : Meta.t; kind : kind } 36 + (** The type for errors: a context, a source meta and a kind. *) 37 + 38 + (** {1:primitives Primitives} *) 39 + 40 + val v : ctx:Context.t -> meta:Meta.t -> kind -> t 41 + (** [v ~ctx ~meta k] builds a fresh error with the given ctx, meta and kind. *) 42 + 43 + val msg : ctx:Context.t -> meta:Meta.t -> string -> t 44 + (** [msg ~ctx ~meta s] builds a plain-message error. *) 45 + 46 + val msgf : Meta.t -> ('a, Format.formatter, unit, t) format4 -> 'a 47 + (** [msgf meta fmt] builds an error with an empty context and a formatted 48 + message. *) 18 49 19 - type t = Loc.Error.t = { ctx : Loc.Context.t; meta : Loc.Meta.t; kind : kind } 20 - (** The type for errors: a context, a meta and a kind. *) 50 + val raise : t -> 'a 51 + (** [raise e] raises {!Json.exception-Error} (shadows {!Stdlib.raise}; use with 52 + care when [open Error]). *) 21 53 22 - val v : ctx:Loc.Context.t -> meta:Loc.Meta.t -> kind -> t 23 - (** [v ~ctx ~meta k] is a fresh error. *) 54 + val fail : ctx:Context.t -> meta:Meta.t -> kind -> 'a 55 + (** [fail ~ctx ~meta k] raises {!Json.exception-Error} with the given args. 56 + [fail = raise (v ~ctx ~meta k)]. *) 24 57 25 - val msg : ctx:Loc.Context.t -> meta:Loc.Meta.t -> string -> t 26 - (** [msg ~ctx ~meta s] is a fresh error with a plain {!Loc.Error.Msg} kind. *) 58 + val failf : Meta.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a 59 + (** [failf meta fmt] raises an error with empty context and the given formatted 60 + message. *) 27 61 28 - val raise : ctx:Loc.Context.t -> meta:Loc.Meta.t -> kind -> 'a 29 - (** [raise ~ctx ~meta k] raises [Loc.Error.Error (v ~ctx ~meta k)]. *) 62 + (** {1:context Context pushers} 30 63 31 - val fail : Loc.Meta.t -> string -> 'a 32 - (** [fail meta s] raises with an empty context and message [s]. *) 64 + Walk up from a leaf error, extending its context as decoding unwinds. *) 33 65 34 - val failf : Loc.Meta.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a 35 - (** [failf meta fmt] is {!fail} with a formatted message. *) 66 + val push_array : string node -> int node -> t -> t 67 + (** [push_array kinded_sort i e] extends [e]'s context with an array frame. *) 36 68 37 - val msgf : Loc.Meta.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a 38 - (** [msgf] is a synonym for {!failf}. *) 69 + val push_object : string node -> string node -> t -> t 70 + (** [push_object kinded_sort n e] extends [e]'s context with an object-member 71 + frame. *) 39 72 40 - val push_array : string Loc.node -> int Loc.node -> t -> 'a 41 - (** [push_array kinded_sort i e] re-raises [e] with context extended to show it 42 - occurred in the [i]-th element of an array of the given kinded sort. *) 73 + val fail_push_array : string node -> int node -> t -> 'a 74 + (** [fail_push_array] is {!fail} applied to {!push_array}. *) 43 75 44 - val push_object : string Loc.node -> string Loc.node -> t -> 'a 45 - (** [push_object kinded_sort n e] re-raises [e] with context extended to show it 46 - occurred in member [n] of an object of the given kinded sort. *) 76 + val fail_push_object : string node -> string node -> t -> 'a 77 + (** [fail_push_object] is {!fail} applied to {!push_object}. *) 47 78 48 79 val adjust_context : 49 - first_byte:Loc.byte_pos -> 50 - first_line_num:Loc.line_num -> 51 - first_line_byte:Loc.byte_pos -> 80 + first_byte:byte_pos -> 81 + first_line_num:line_num -> 82 + first_line_byte:byte_pos -> 52 83 t -> 53 84 'a 54 85 (** [adjust_context ~first_byte ~first_line_num ~first_line_byte e] re-raises 55 - [e] with its context meta adjusted to encompass the given source positions. 56 - *) 86 + [e] with its innermost context's meta adjusted. *) 87 + 88 + (** {1:fmt Formatting} *) 57 89 58 90 val pp : t Fmt.t 59 91 (** [pp] formats an error with its context and kind. *) 60 92 61 93 val to_string : t -> string 62 - (** [to_string e] is {!pp} applied to a fresh buffer. *) 94 + (** [to_string e] is [e] formatted as a string. *) 63 95 64 96 val puterr : unit Fmt.t 65 97 (** [puterr] prints [Error:] in bold red. *) 66 98 67 - val disable_ansi_styler : unit -> unit 68 - (** [disable_ansi_styler ()] turns off ANSI color/bold output in error 69 - formatting. *) 99 + (** {1:typed Typed errors — (builder, raiser) pairs} *) 70 100 71 - val pp_kind : string Fmt.t 72 - (** [pp_kind] formats a kind string as code (bold). *) 101 + val expected : Meta.t -> string -> fnd:string -> t 102 + (** [expected meta exp ~fnd] builds ["Expected [exp] but found [fnd]"]. *) 73 103 74 - val pp_kind_opt : string Fmt.t 75 - (** [pp_kind_opt] is {!pp_kind} but prints nothing when the kind is empty. *) 104 + val fail_expected : Meta.t -> string -> fnd:string -> 'a 105 + (** [fail_expected] is {!fail} applied to {!expected}. *) 76 106 77 - val pp_int : int Fmt.t 78 - (** [pp_int] formats an integer as code (bold). *) 107 + val sort : Meta.t -> exp:Sort.t -> fnd:Sort.t -> t 108 + (** [sort meta ~exp ~fnd] builds a {!Sort_mismatch} error. *) 79 109 80 - (** {1:helpers High-level helpers} *) 110 + val fail_sort : Meta.t -> exp:Sort.t -> fnd:Sort.t -> 'a 111 + (** [fail_sort] is {!fail} applied to {!sort}. *) 81 112 82 - val expected : Loc.Meta.t -> string -> fnd:string -> 'a 83 - (** [expected meta exp ~fnd] raises with message 84 - ["Expected [exp] but found [fnd]"]. *) 113 + val kinded_sort : Meta.t -> exp:string -> fnd:Sort.t -> t 114 + (** [kinded_sort meta ~exp ~fnd] builds a {!Kinded_sort_mismatch} error. *) 85 115 86 - val sort : Loc.Meta.t -> exp:Sort.t -> fnd:Sort.t -> 'a 87 - (** [sort meta ~exp ~fnd] raises [Sort_mismatch]. *) 116 + val fail_kinded_sort : Meta.t -> exp:string -> fnd:Sort.t -> 'a 117 + (** [fail_kinded_sort] is {!fail} applied to {!kinded_sort}. *) 88 118 89 - val kinded_sort : Loc.Meta.t -> exp:string -> fnd:Sort.t -> 'a 90 - (** [kinded_sort meta ~exp ~fnd] raises [Kinded_sort_mismatch]. *) 119 + val missing_members : 120 + Meta.t -> kinded_sort:string -> exp:string list -> fnd:string list -> t 121 + (** [missing_members meta ~kinded_sort ~exp ~fnd] builds a "missing members" 122 + error listing members absent from an object of [kinded_sort]. [fnd] lists 123 + the members that are present (used for hints). *) 91 124 92 - val missing_mems : 93 - Loc.Meta.t -> kinded_sort:string -> exp:string list -> fnd:string list -> 'a 94 - (** [missing_mems meta ~kinded_sort ~exp ~fnd] raises with a message listing the 95 - members in [exp] that were missing from an object of [kinded_sort]. [fnd] 96 - lists the found members (used for "did you mean" hints). *) 125 + val fail_missing_members : 126 + Meta.t -> kinded_sort:string -> exp:string list -> fnd:string list -> 'a 127 + 128 + val unexpected_members : 129 + Meta.t -> 130 + kinded_sort:string -> 131 + exp:string list -> 132 + fnd:(string * Meta.t) list -> 133 + t 134 + (** [unexpected_members meta ~kinded_sort ~exp ~fnd] builds an error listing 135 + [fnd] members not in [exp] for an object of [kinded_sort]. *) 97 136 98 - val unexpected_mems : 99 - Loc.Meta.t -> 137 + val fail_unexpected_members : 138 + Meta.t -> 100 139 kinded_sort:string -> 101 140 exp:string list -> 102 - fnd:(string * Loc.Meta.t) list -> 141 + fnd:(string * Meta.t) list -> 103 142 'a 104 - (** [unexpected_mems meta ~kinded_sort ~exp ~fnd] raises with a message listing 105 - the unexpected members in [fnd] for an object of [kinded_sort]. [exp] lists 106 - the allowed members (used for hints). *) 107 143 108 144 val unexpected_case_tag : 109 - Loc.Meta.t -> 145 + Meta.t -> 146 + kinded_sort:string -> 147 + member_name:string -> 148 + exp:string list -> 149 + fnd:string -> 150 + t 151 + (** [unexpected_case_tag meta ~kinded_sort ~member_name ~exp ~fnd] builds an 152 + error for when the tag member carries the unexpected value [fnd]; [exp] 153 + lists the allowed tag values. *) 154 + 155 + val fail_unexpected_case_tag : 156 + Meta.t -> 110 157 kinded_sort:string -> 111 - mem_name:string -> 158 + member_name:string -> 112 159 exp:string list -> 113 160 fnd:string -> 114 161 'a 115 - (** [unexpected_case_tag meta ~kinded_sort ~mem_name ~exp ~fnd] raises when the 116 - tag member [mem_name] of an object of [kinded_sort] carries the unexpected 117 - value [fnd]; [exp] lists the allowed tag values. *) 162 + 163 + val index_out_of_range : Meta.t -> n:int -> len:int -> t 164 + (** [index_out_of_range meta ~n ~len] builds 165 + ["Index [n] out of range [0; [len]-1]"]. *) 118 166 119 - val index_out_of_range : Loc.Meta.t -> n:int -> len:int -> 'a 120 - (** [index_out_of_range meta ~n ~len] raises "Index [n] out of range \[0; 121 - [len]-1\]". *) 167 + val fail_index_out_of_range : Meta.t -> n:int -> len:int -> 'a 122 168 123 - val number_range : Loc.Meta.t -> kind:string -> float -> 'a 124 - (** [number_range meta ~kind n] raises "Number [n] not in [kind] range". *) 169 + val number_range : Meta.t -> kind:string -> float -> t 170 + (** [number_range meta ~kind n] builds ["Number [n] not in [kind] range"]. *) 125 171 126 - val parse_string_number : Loc.Meta.t -> kind:string -> string -> 'a 127 - (** [parse_string_number meta ~kind s] raises "String [s] does not parse to a 128 - [kind] value". *) 172 + val fail_number_range : Meta.t -> kind:string -> float -> 'a 129 173 130 - val integer_range : Loc.Meta.t -> kind:string -> int -> 'a 131 - (** [integer_range meta ~kind n] raises "Integer [n] not in [kind] range". *) 174 + val integer_range : Meta.t -> kind:string -> int -> t 175 + (** [integer_range meta ~kind n] builds ["Integer [n] not in [kind] range"]. *) 132 176 133 - val no_decoder : Loc.Meta.t -> kind:string -> 'a 134 - (** [no_decoder meta ~kind] raises "No decoder for [kind]". *) 177 + val fail_integer_range : Meta.t -> kind:string -> int -> 'a 135 178 136 - val no_encoder : Loc.Meta.t -> kind:string -> 'a 137 - (** [no_encoder meta ~kind] raises "No encoder for [kind]". *) 179 + val no_decoder : Meta.t -> kind:string -> t 180 + (** [no_decoder meta ~kind] builds ["No decoder for [kind]"]. *) 138 181 139 - val decode_todo : Loc.Meta.t -> kind_opt:string -> 'a 140 - (** [decode_todo meta ~kind_opt] raises "TODO: decode [kind_opt]". *) 182 + val fail_no_decoder : Meta.t -> kind:string -> 'a 141 183 142 - val encode_todo : Loc.Meta.t -> kind_opt:string -> 'a 143 - (** [encode_todo meta ~kind_opt] raises "TODO: encode [kind_opt]". *) 184 + val no_encoder : Meta.t -> kind:string -> t 185 + (** [no_encoder meta ~kind] builds ["No encoder for [kind]"]. *) 144 186 145 - val msg_with_kind : Loc.Meta.t -> kind:string -> string -> 'a 146 - (** [msg_with_kind meta ~kind e] raises ["[kind]: [e]"] — a generic wrapper when 147 - callers already have a formatted error message. *) 187 + val fail_no_encoder : Meta.t -> kind:string -> 'a

+32 -1620

lib/json.ml

··· 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 module Fmt = Core.Fmt 7 - 8 - let pp_int ppf i = Fmt.code ppf (Int.to_string i) 9 - 10 7 module Meta = Loc.Meta 11 8 12 9 type 'a node = 'a * Meta.t ··· 15 12 module Context = Loc.Context 16 13 module Sort = Sort 17 14 15 + type fpath = Loc.fpath 16 + 18 17 exception Error = Loc.Error 19 18 20 19 module Error = Error 21 20 22 21 (* Public alias for codecs. *) 22 + 23 + module Codec = Codec 23 24 24 25 type 'a codec = 'a Codec.t 25 26 ··· 45 46 everything from [Codec] and adds the public combinator surface, 46 47 [Base]/[Array]/[Object] sub-submodules, and [Value] codecs. *) 47 48 48 - module Codec = struct 49 - include Codec 50 - 51 - (* Keep an alias to the internal [Value] module so we can still reach 52 - [Value.meta] / [Value.sort] etc. after defining a [Value] submodule of 53 - AST-preserving codecs (which shadows the library-level [Value]). *) 54 - module Ast = Value 55 - 56 - let enc_meta_none _v = Meta.none 57 - 58 - (* Base types *) 59 - 60 - module Base = struct 61 - type ('a, 'b) map = ('a, 'b) base_map 62 - 63 - let base_map_sort = "base map" 64 - 65 - let map ?(kind = "") ?(doc = "") ?dec ?enc ?(enc_meta = enc_meta_none) () = 66 - let dec = 67 - match dec with 68 - | Some dec -> dec 69 - | None -> 70 - let kind = Sort.kinded_string ~kind base_map_sort in 71 - fun meta _v -> Error.no_decoder meta ~kind 72 - in 73 - let enc = 74 - match enc with 75 - | Some enc -> enc 76 - | None -> 77 - let kind = Sort.kinded_string ~kind base_map_sort in 78 - fun _v -> Error.no_encoder Meta.none ~kind 79 - in 80 - { kind; doc; dec; enc; enc_meta } 81 - 82 - let id = 83 - let dec _meta v = v and enc = Fun.id in 84 - { kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none } 85 - 86 - let ignore = 87 - let kind = "ignore" in 88 - let dec _meta _v = () in 89 - let enc _v = 90 - let kind = Sort.kinded_string ~kind base_map_sort in 91 - Error.no_encoder Meta.none ~kind 92 - in 93 - { kind; doc = ""; dec; enc; enc_meta = enc_meta_none } 94 - 95 - let null map = Null map 96 - let bool map = Bool map 97 - let number map = Number map 98 - let string map = String map 99 - let dec dec = fun _meta v -> dec v 100 - 101 - let dec_result ?(kind = "") dec = 102 - let kind = Sort.kinded_string ~kind base_map_sort in 103 - fun meta v -> 104 - match dec v with 105 - | Ok v -> v 106 - | Error e -> Error.msg_with_kind meta ~kind e 107 - 108 - let dec_failure ?(kind = "") dec = 109 - let kind = Sort.kinded_string ~kind base_map_sort in 110 - fun meta v -> 111 - try dec v with Failure e -> Error.msg_with_kind meta ~kind e 112 - 113 - let enc = Fun.id 114 - 115 - let enc_result ?(kind = "") enc = 116 - let kind = Sort.kinded_string ~kind base_map_sort in 117 - fun v -> 118 - match enc v with 119 - | Ok v -> v 120 - | Error e -> Error.msg_with_kind Meta.none ~kind e 121 - 122 - let enc_failure ?(kind = "") enc = 123 - let kind = Sort.kinded_string ~kind base_map_sort in 124 - fun v -> 125 - try enc v with Failure e -> Error.msg_with_kind Meta.none ~kind e 126 - end 127 - 128 - (* Any JSON value (RFC 8259 s. 3) *) 129 - 130 - let any ?(kind = "") ?(doc = "") ?dec_null ?dec_bool ?dec_number ?dec_string 131 - ?dec_array ?dec_object ?enc () = 132 - let enc = 133 - match enc with 134 - | Some enc -> enc 135 - | None -> 136 - let kind = Sort.kinded_string ~kind "value" in 137 - fun _v -> Error.no_encoder Meta.none ~kind 138 - in 139 - Any 140 - { 141 - kind; 142 - doc; 143 - dec_null; 144 - dec_bool; 145 - dec_number; 146 - dec_string; 147 - dec_array; 148 - dec_object; 149 - enc; 150 - } 151 - 152 - (* Maps and recursion *) 153 - 154 - let map ?(kind = "") ?(doc = "") ?dec ?enc dom = 155 - let map_sort = "map" in 156 - let dec = 157 - match dec with 158 - | Some dec -> dec 159 - | None -> 160 - let kind = Sort.kinded_string ~kind map_sort in 161 - fun _v -> Error.no_decoder Meta.none ~kind 162 - in 163 - let enc = 164 - match enc with 165 - | Some enc -> enc 166 - | None -> 167 - let kind = Sort.kinded_string ~kind map_sort in 168 - fun _v -> Error.no_encoder Meta.none ~kind 169 - in 170 - Map { kind; doc; dom; dec; enc } 171 - 172 - let iter ?(kind = "") ?(doc = "") ?dec ?enc dom = 173 - let dec = 174 - match dec with 175 - | None -> Fun.id 176 - | Some dec -> 177 - fun v -> 178 - dec v; 179 - v 180 - in 181 - let enc = 182 - match enc with 183 - | None -> Fun.id 184 - | Some enc -> 185 - fun v -> 186 - enc v; 187 - v 188 - in 189 - Map { kind; doc; dom; dec; enc } 190 - 191 - let fix t = Rec t 192 - 193 - (* Nulls and options *) 194 - 195 - let null ?kind ?doc v = 196 - let dec _meta () = v and enc _meta = () in 197 - Null (Base.map ?doc ?kind ~dec ~enc ()) 198 - 199 - let none = 200 - let none = 201 - let dec _meta _v = None and enc _ = () in 202 - { kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none } 203 - in 204 - Null none 205 - 206 - let some t = map ~dec:Option.some ~enc:Option.get t 207 - 208 - let option : type a. ?kind:string -> ?doc:string -> a t -> a option t = 209 - fun ?kind ?doc t -> 210 - let some = some t in 211 - let enc = function None -> none | Some _ -> some in 212 - match t with 213 - | Null _ -> any ?doc ?kind ~dec_null:none ~enc () 214 - | Bool _ -> any ?doc ?kind ~dec_null:none ~dec_bool:some ~enc () 215 - | Number _ -> any ?doc ?kind ~dec_null:none ~dec_number:some ~enc () 216 - | String _ -> any ?doc ?kind ~dec_null:none ~dec_string:some ~enc () 217 - | Array _ -> any ?doc ?kind ~dec_null:none ~dec_array:some ~enc () 218 - | Object _ -> any ?doc ?kind ~dec_null:none ~dec_object:some ~enc () 219 - | Any _ | Map _ | Rec _ | Ignore -> 220 - any ?doc ?kind ~dec_null:none ~dec_bool:some ~dec_number:some 221 - ~dec_string:some ~dec_array:some ~dec_object:some ~enc () 222 - 223 - (* Booleans *) 224 - 225 - let bool = Bool Base.id 226 - 227 - (* Numbers *) 228 - 229 - let[@inline] check_finite_number meta ~kind v = 230 - if Float.is_finite v then () 231 - else Error.kinded_sort meta ~exp:(Sort.kinded ~kind Number) ~fnd:Sort.Null 232 - 233 - let number = Number Base.id 234 - 235 - let any_float = 236 - let kind = "float" in 237 - let finite = number in 238 - let non_finite = 239 - let dec m v = 240 - match Float.of_string_opt v with 241 - | Some v -> v 242 - | None -> Error.parse_string_number m ~kind v 243 - in 244 - Base.string (Base.map ~kind ~dec ~enc:Float.to_string ()) 245 - in 246 - let enc v = if Float.is_finite v then finite else non_finite in 247 - any ~kind ~dec_null:finite ~dec_number:finite ~dec_string:non_finite ~enc () 248 - 249 - let float_as_hex_string = 250 - let kind = "float" in 251 - let dec meta v = 252 - match Float.of_string_opt v with 253 - | Some v -> v 254 - | None -> Error.parse_string_number meta ~kind v 255 - in 256 - let enc v = Fmt.str "%h" v in 257 - Base.string (Base.map ~kind ~dec ~enc ()) 258 - 259 - let uint8 = 260 - let kind = "uint8" in 261 - let dec meta v = 262 - check_finite_number meta ~kind v; 263 - if Core.Number.in_exact_uint8_range v then Int.of_float v 264 - else Error.number_range meta ~kind v 265 - in 266 - let enc v = 267 - if Core.Number.int_is_uint8 v then Int.to_float v 268 - else Error.integer_range Meta.none ~kind v 269 - in 270 - Base.number (Base.map ~kind ~dec ~enc ()) 271 - 272 - let uint16 = 273 - let kind = "uint16" in 274 - let dec meta v = 275 - check_finite_number meta ~kind v; 276 - if Core.Number.in_exact_uint16_range v then Int.of_float v 277 - else Error.number_range meta ~kind v 278 - in 279 - let enc v = 280 - if Core.Number.int_is_uint16 v then Int.to_float v 281 - else Error.integer_range Meta.none ~kind v 282 - in 283 - Base.number (Base.map ~kind ~dec ~enc ()) 284 - 285 - let int8 = 286 - let kind = "int8" in 287 - let dec meta v = 288 - check_finite_number meta ~kind v; 289 - if Core.Number.in_exact_int8_range v then Int.of_float v 290 - else Error.number_range meta ~kind v 291 - in 292 - let enc v = 293 - if Core.Number.int_is_int8 v then Int.to_float v 294 - else Error.integer_range Meta.none ~kind v 295 - in 296 - Base.number (Base.map ~kind ~dec ~enc ()) 297 - 298 - let int16 = 299 - let kind = "int16" in 300 - let dec meta v = 301 - check_finite_number meta ~kind v; 302 - if Core.Number.in_exact_int16_range v then Int.of_float v 303 - else Error.number_range meta ~kind v 304 - in 305 - let enc v = 306 - if Core.Number.int_is_int16 v then Int.to_float v 307 - else Error.integer_range Meta.none ~kind v 308 - in 309 - Base.number (Base.map ~kind ~dec ~enc ()) 310 - 311 - let int32 = 312 - let kind = "int32" in 313 - let dec meta v = 314 - check_finite_number meta ~kind v; 315 - if Core.Number.in_exact_int32_range v then Int32.of_float v 316 - else Error.number_range meta ~kind v 317 - in 318 - let enc = Int32.to_float in 319 - Base.number (Base.map ~kind ~dec ~enc ()) 320 - 321 - let int64_as_string = 322 - let kind = "int64" in 323 - let dec meta v = 324 - match Int64.of_string_opt v with 325 - | Some v -> v 326 - | None -> Error.parse_string_number meta ~kind v 327 - in 328 - Base.string (Base.map ~kind ~dec ~enc:Int64.to_string ()) 329 - 330 - let int64_number = 331 - let kind = "int64" in 332 - let dec meta v = 333 - if Core.Number.in_exact_int64_range v then Int64.of_float v 334 - else Error.number_range meta ~kind v 335 - in 336 - Base.number (Base.map ~kind ~dec ~enc:Int64.to_float ()) 337 - 338 - let int64 = 339 - let dec_number = int64_number and dec_string = int64_as_string in 340 - let enc v = 341 - if Core.Number.can_store_exact_int64 v then int64_number 342 - else int64_as_string 343 - in 344 - any ~kind:"int64" ~dec_number ~dec_string ~enc () 345 - 346 - let int_as_string = 347 - let kind = "OCaml int" in 348 - let dec meta v = 349 - match int_of_string_opt v with 350 - | Some v -> v 351 - | None -> Error.parse_string_number meta ~kind v 352 - in 353 - Base.string (Base.map ~kind ~dec ~enc:Int.to_string ()) 354 - 355 - let int_number = 356 - let kind = "OCaml int" in 357 - let dec meta v = 358 - if Core.Number.in_exact_int_range v then Int.of_float v 359 - else Error.number_range meta ~kind v 360 - in 361 - Base.number (Base.map ~kind ~dec ~enc:Int.to_float ()) 362 - 363 - let int = 364 - let enc v = 365 - if Core.Number.can_store_exact_int v then int_number else int_as_string 366 - in 367 - let dec_number = int_number and dec_string = int_as_string in 368 - any ~kind:"OCaml int" ~dec_number ~dec_string ~enc () 369 - 370 - (* Strings and enums *) 371 - 372 - let string = String Base.id 373 - 374 - let of_of_string ?kind ?doc ?enc of_string = 375 - let dec = Base.dec_result ?kind of_string in 376 - let enc = match enc with None -> None | Some enc -> Some (Base.enc enc) in 377 - Base.string (Base.map ?kind ?doc ?enc ~dec ()) 378 - 379 - let enum (type a) ?(cmp = Stdlib.compare) ?(kind = "") ?doc assoc = 380 - let kind = Sort.kinded_string ~kind "enum" in 381 - let dec_map = 382 - let add m (k, v) = String_map.add k v m in 383 - let m = List.fold_left add String_map.empty assoc in 384 - fun k -> String_map.find_opt k m 385 - in 386 - let enc_map = 387 - let module M = Map.Make (struct 388 - type t = a 389 - 390 - let compare = cmp 391 - end) in 392 - let add m (k, v) = M.add v k m in 393 - let m = List.fold_left add M.empty assoc in 394 - fun v -> M.find_opt v m 395 - in 396 - let dec meta s = 397 - match dec_map s with 398 - | Some v -> v 399 - | None -> 400 - let kind = Sort.kinded ~kind String in 401 - let pp_kind ppf () = Fmt.pf ppf "%a value" pp_code kind in 402 - Error.msgf meta "%a" 403 - (Fmt.out_of_dom ~pp_kind ()) 404 - (s, List.map fst assoc) 405 - in 406 - let enc v = 407 - match enc_map v with 408 - | Some s -> s 409 - | None -> 410 - Error.msgf Meta.none "Encode %a: unknown enum value" pp_code kind 411 - in 412 - Base.string (Base.map ~kind ?doc ~dec ~enc ()) 413 - 414 - let binary_string = 415 - let kind = "hex" in 416 - let kind' = Sort.kinded ~kind String in 417 - let dec = Base.dec_result ~kind:kind' Core.binary_string_of_hex in 418 - let enc = Base.enc Core.binary_string_to_hex in 419 - Base.string (Base.map ~kind ~dec ~enc ()) 420 - 421 - (* Arrays and tuples *) 422 - 423 - module Array = struct 424 - type ('array, 'elt, 'builder) map = ('array, 'elt, 'builder) array_map 425 - 426 - type ('array, 'elt) enc = { 427 - enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; 428 - } 429 - 430 - let array_kind kind = Sort.kinded ~kind Sort.Array 431 - let default_skip _i _builder = false 432 - 433 - let map ?(kind = "") ?(doc = "") ?dec_empty ?dec_skip ?dec_add ?dec_finish 434 - ?enc ?(enc_meta = enc_meta_none) elt = 435 - let dec_empty = 436 - match dec_empty with 437 - | Some dec_empty -> dec_empty 438 - | None -> fun () -> Error.no_decoder Meta.none ~kind:(array_kind kind) 439 - in 440 - let dec_skip = Option.value ~default:default_skip dec_skip in 441 - let dec_add = 442 - match dec_add with 443 - | Some dec_add -> dec_add 444 - | None -> 445 - fun _ _ _ -> Error.no_decoder Meta.none ~kind:(array_kind kind) 446 - in 447 - let dec_finish = 448 - match dec_finish with 449 - | Some dec_finish -> dec_finish 450 - | None -> 451 - fun _ _ _ -> Error.no_decoder Meta.none ~kind:(array_kind kind) 452 - in 453 - let enc = 454 - match enc with 455 - | Some { enc } -> enc 456 - | None -> 457 - fun _ _ _ -> Error.no_encoder Meta.none ~kind:(array_kind kind) 458 - in 459 - { 460 - kind; 461 - doc; 462 - elt; 463 - dec_empty; 464 - dec_add; 465 - dec_skip; 466 - dec_finish; 467 - enc; 468 - enc_meta; 469 - } 470 - 471 - let list_enc f acc l = 472 - let rec loop f acc i = function 473 - | [] -> acc 474 - | v :: l -> loop f (f acc i v) (i + 1) l 475 - in 476 - loop f acc 0 l 477 - 478 - let list_map ?kind ?doc ?dec_skip elt = 479 - let dec_empty () = [] in 480 - let dec_add _i v l = v :: l in 481 - let dec_finish _meta _len l = List.rev l in 482 - let enc = { enc = list_enc } in 483 - map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt 484 - 485 - type 'a array_builder = 'a Core.Rarray.t 486 - 487 - let array_enc f acc a = 488 - let acc = ref acc in 489 - for i = 0 to Stdlib.Array.length a - 1 do 490 - acc := f !acc i (Stdlib.Array.unsafe_get a i) 491 - done; 492 - !acc 493 - 494 - let array_map ?kind ?doc ?dec_skip elt = 495 - let dec_empty () = Core.Rarray.empty () in 496 - let dec_add _i v a = Core.Rarray.add_last v a in 497 - let dec_finish _meta _len a = Core.Rarray.to_array a in 498 - let enc = { enc = array_enc } in 499 - map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt 500 - 501 - type ('a, 'b, 'c) bigarray_builder = ('a, 'b, 'c) Core.Rbigarray1.t 502 - 503 - let bigarray_map ?kind ?doc ?dec_skip k l elt = 504 - let dec_empty _meta = Core.Rbigarray1.empty k l in 505 - let dec_add _i v a = Core.Rbigarray1.add_last v a in 506 - let dec_finish _meta _len a = Core.Rbigarray1.to_bigarray a in 507 - let enc f acc a = 508 - let acc = ref acc in 509 - for i = 0 to Bigarray.Array1.dim a - 1 do 510 - acc := f !acc i (Bigarray.Array1.unsafe_get a i) 511 - done; 512 - !acc 513 - in 514 - let enc = { enc } in 515 - map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt 516 - 517 - let array map = Array map 518 - 519 - let stub_elt = 520 - Map 521 - { 522 - kind = ""; 523 - doc = ""; 524 - dom = Base.(null id); 525 - enc = (fun _ -> assert false); 526 - dec = (fun _ -> assert false); 527 - } 528 - 529 - let ignore = 530 - let kind = "ignore" in 531 - let kind' = Sort.kinded ~kind Array in 532 - let dec_empty () = () and dec_add _i _v () = () in 533 - let dec_skip _i () = true and dec_finish _meta _len () = () in 534 - let enc = 535 - { enc = (fun _ _ () -> Error.no_encoder Meta.none ~kind:kind') } 536 - in 537 - array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt) 538 - 539 - let zero = 540 - let dec_empty () = () and dec_add _i _v () = () in 541 - let dec_skip _i () = true and dec_finish _meta _len () = () in 542 - let enc = { enc = (fun _ acc () -> acc) } in 543 - let kind = "zero" in 544 - array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt) 545 - end 546 - 547 - let list ?kind ?doc t = Array (Array.list_map ?kind ?doc t) 548 - let array ?kind ?doc t = Array (Array.array_map ?kind ?doc t) 549 - 550 - let array_as_string_map ?kind ?doc ~key t = 551 - let dec_empty () = String_map.empty in 552 - let dec_add _i elt acc = String_map.add (key elt) elt acc in 553 - let dec_finish _meta _len acc = acc in 554 - let enc f acc m = 555 - let i = ref (-1) in 556 - String_map.fold 557 - (fun _ elt acc -> 558 - incr i; 559 - f acc !i elt) 560 - m acc 561 - in 562 - let enc = Array.{ enc } in 563 - let map = Array.map ?kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t in 564 - Array map 565 - 566 - let bigarray ?kind ?doc k t = 567 - Array (Array.bigarray_map ?kind ?doc k Bigarray.c_layout t) 568 - 569 - let tuple_no_decoder ~kind meta = 570 - Error.no_decoder meta ~kind:(Sort.kinded_string ~kind "tuple") 571 - 572 - let tuple_no_encoder ~kind = 573 - Error.no_encoder Meta.none ~kind:(Sort.kinded_string ~kind "tuple") 574 - 575 - let error_tuple_size meta kind ~exp fnd = 576 - Error.msgf meta "Expected %a elements in %a but found %a" pp_int exp pp_kind 577 - (Sort.kinded_string ~kind "tuple") 578 - pp_int fnd 579 - 580 - let t2 ?(kind = "") ?doc ?dec ?enc t = 581 - let size = 2 in 582 - let dec = 583 - match dec with 584 - | None -> fun meta _v0 _v1 -> tuple_no_decoder ~kind meta 585 - | Some dec -> fun _meta v0 v1 -> dec v0 v1 586 - in 587 - let dec_empty () = [] in 588 - let dec_add _i v acc = v :: acc in 589 - let dec_finish meta _len = function 590 - | [ v1; v0 ] -> dec meta v0 v1 591 - | l -> error_tuple_size meta kind ~exp:size (List.length l) 592 - in 593 - let enc = 594 - match enc with 595 - | None -> fun _f _acc _v -> tuple_no_encoder ~kind 596 - | Some enc -> fun f acc v -> f (f acc 0 (enc v 0)) 1 (enc v 1) 597 - in 598 - let enc = { Array.enc } in 599 - Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 600 - 601 - let t3 ?(kind = "") ?doc ?dec ?enc t = 602 - let size = 3 in 603 - let dec = 604 - match dec with 605 - | None -> fun meta _v0 _v1 _v2 -> tuple_no_decoder ~kind meta 606 - | Some dec -> fun _meta v0 v1 v2 -> dec v0 v1 v2 607 - in 608 - let dec_empty () = [] in 609 - let dec_add _i v acc = v :: acc in 610 - let dec_finish meta _len = function 611 - | [ v2; v1; v0 ] -> dec meta v0 v1 v2 612 - | l -> error_tuple_size meta kind ~exp:size (List.length l) 613 - in 614 - let enc = 615 - match enc with 616 - | None -> fun _f _acc _v -> tuple_no_encoder ~kind 617 - | Some enc -> 618 - fun f acc v -> f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2) 619 - in 620 - let enc = { Array.enc } in 621 - Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 622 - 623 - let t4 ?(kind = "") ?doc ?dec ?enc t = 624 - let size = 4 in 625 - let dec = 626 - match dec with 627 - | None -> fun meta _v0 _v1 _v2 _v3 -> tuple_no_decoder ~kind meta 628 - | Some dec -> fun _meta v0 v1 v2 v3 -> dec v0 v1 v2 v3 629 - in 630 - let dec_empty () = [] in 631 - let dec_add _i v acc = v :: acc in 632 - let dec_finish meta _len = function 633 - | [ v3; v2; v1; v0 ] -> dec meta v0 v1 v2 v3 634 - | l -> error_tuple_size meta kind ~exp:size (List.length l) 635 - in 636 - let enc = 637 - match enc with 638 - | None -> fun _f _acc _v -> tuple_no_encoder ~kind 639 - | Some enc -> 640 - fun f acc v -> 641 - f (f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2)) 3 (enc v 3) 642 - in 643 - let enc = { Array.enc } in 644 - Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 645 - 646 - let tn ?(kind = "") ?doc ~n elt = 647 - let dec_empty () = Core.Rarray.empty () in 648 - let dec_add _i v a = Core.Rarray.add_last v a in 649 - let dec_finish meta _len a = 650 - let len = Core.Rarray.length a in 651 - if len <> n then error_tuple_size meta kind ~exp:n len 652 - else Core.Rarray.to_array a 653 - in 654 - let enc = { Array.enc = Array.array_enc } in 655 - Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc elt) 656 - 657 - (* Objects *) 658 - 659 - module Object = struct 660 - (* Maps *) 661 - 662 - type ('o, 'dec) map = ('o, 'dec) object_map 663 - 664 - let default_shape = Object_basic Unknown_skip 665 - 666 - let raw_map ?(kind = "") ?(doc = "") ?(enc_meta = enc_meta_none) dec = 667 - { 668 - kind; 669 - doc; 670 - dec; 671 - mem_decs = String_map.empty; 672 - mem_encs = []; 673 - enc_meta; 674 - shape = default_shape; 675 - } 676 - 677 - let map ?kind ?doc dec = raw_map ?kind ?doc (Dec_fun dec) 678 - 679 - let map_with_meta ?kind ?doc ?enc_meta dec = 680 - raw_map ?kind ?doc ?enc_meta (Dec_app (Dec_fun dec, object_meta_arg)) 681 - 682 - let enc_only ?(kind = "") ?doc ?enc_meta () = 683 - let dec meta = Error.no_decoder meta ~kind:(Sort.kinded ~kind Object) in 684 - map_with_meta ~kind ?doc ?enc_meta dec 685 - 686 - let check_name_unicity m = 687 - let add n kind = function 688 - | None -> Some kind 689 - | Some kind' -> 690 - let ks _k = Sort.or_kind ~kind Object in 691 - let k0 = ks kind and k1 = ks kind' in 692 - invalid_arg 693 - @@ 694 - if String.equal k0 k1 then 695 - Fmt.str "member %s defined twice in %s" n k0 696 - else Fmt.str "member %s defined both in %s and %s" n k0 k1 697 - in 698 - let rec loop : type o dec. 699 - string String_map.t -> (o, dec) object_map -> unit = 700 - fun names m -> 701 - let add_name names n = String_map.update n (add n m.kind) names in 702 - let add_mem_enc names (Mem_enc m) = add_name names m.name in 703 - let names = List.fold_left add_mem_enc names m.mem_encs in 704 - match m.shape with 705 - | Object_basic _ -> () 706 - | Object_cases (_u, cases) -> 707 - let names = add_name names cases.tag.name in 708 - let check_case (Case c) = loop names c.object_map in 709 - List.iter check_case cases.cases 710 - in 711 - loop String_map.empty m 712 - 713 - let seal mems = 714 - let () = check_name_unicity mems in 715 - Object { mems with mem_encs = List.rev mems.mem_encs } 716 - 717 - let get_object_map = function 718 - | Object map -> map 719 - | _ -> invalid_arg "Not an object" 720 - 721 - (* Members *) 722 - 723 - module Member = struct 724 - type ('o, 'a) map = ('o, 'a) mem_map 725 - 726 - let no_enc name = 727 - fun _v -> Error.msgf Meta.none "No encoder for member %a" pp_code name 728 - 729 - let map ?(doc = "") ?dec_absent ?enc ?enc_omit name type' = 730 - let id = Type.Id.make () in 731 - let enc = match enc with None -> no_enc name | Some enc -> enc in 732 - let enc_omit = 733 - match enc_omit with None -> Fun.const false | Some omit -> omit 734 - in 735 - { name; doc; type'; id; dec_absent; enc; enc_omit } 736 - 737 - let app object_map mm = 738 - let mem_decs = 739 - String_map.add mm.name (Mem_dec mm) object_map.mem_decs 740 - in 741 - let mem_encs = Mem_enc mm :: object_map.mem_encs in 742 - let dec = Dec_app (object_map.dec, mm.id) in 743 - { object_map with dec; mem_decs; mem_encs } 744 - end 745 - 746 - let member ?(doc = "") ?dec_absent ?enc ?enc_omit name type' map = 747 - let mmap = Member.map ~doc ?dec_absent ?enc ?enc_omit name type' in 748 - let mem_decs = String_map.add name (Mem_dec mmap) map.mem_decs in 749 - let mem_encs = Mem_enc mmap :: map.mem_encs in 750 - let dec = Dec_app (map.dec, mmap.id) in 751 - { map with dec; mem_decs; mem_encs } 752 - 753 - let opt_member ?doc ?enc:e name dom map = 754 - let dec = Option.some and enc = Option.get in 755 - let some = Map { kind = ""; doc = ""; dom; dec; enc } in 756 - member ?doc ~dec_absent:None ?enc:e ~enc_omit:Option.is_none name some map 757 - 758 - (* Case objects *) 759 - 760 - module Case = struct 761 - type ('cases, 'case, 'tag) map = ('cases, 'case, 'tag) case_map 762 - type ('cases, 'tag) t = ('cases, 'tag) case 763 - type ('cases, 'tag) value = ('cases, 'tag) case_value 764 - 765 - let no_dec _ = Error.msgf Meta.none "No decoder for case" 766 - 767 - let map ?(dec = no_dec) tag obj = 768 - { tag; object_map = get_object_map obj; dec } 769 - 770 - let map_tag c = c.tag 771 - let make c = Case c 772 - let tag (Case c) = map_tag c 773 - let value c v = Case_value (c, v) 774 - end 775 - 776 - let check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string = 777 - match map.shape with 778 - | Object_cases _ -> 779 - invalid_arg "Multiple calls to Json.Object.case_member" 780 - | _ -> ( 781 - match dec_absent with 782 - | None -> () 783 - | Some tag -> 784 - let equal_t (Case case) = tag_compare case.tag tag = 0 in 785 - if not (List.exists equal_t cases) then 786 - let tag = 787 - match tag_to_string with 788 - | None -> "" 789 - | Some tag_to_string -> " " ^ tag_to_string tag 790 - in 791 - invalid_arg ("No case for dec_absent case member value" ^ tag)) 792 - 793 - let case_tag_mem ?(doc = "") name type' ~dec_absent ~enc_omit = 794 - let id = Type.Id.make () in 795 - let enc t = t in 796 - let enc_omit = 797 - match enc_omit with None -> Fun.const false | Some omit -> omit 798 - in 799 - { name; doc; type'; id; dec_absent; enc; enc_omit } 800 - 801 - let case_member ?doc ?(tag_compare = Stdlib.compare) ?tag_to_string 802 - ?dec_absent ?enc ?enc_omit ?enc_case name type' cases map = 803 - let () = 804 - check_case_mem map cases ~dec_absent ~tag_compare ~tag_to_string 805 - in 806 - let tag = case_tag_mem ?doc name type' ~dec_absent ~enc_omit in 807 - let enc = match enc with None -> Member.no_enc name | Some e -> e in 808 - let enc_case = 809 - match enc_case with 810 - | Some enc_case -> enc_case 811 - | None -> 812 - fun _case -> 813 - Error.msgf Meta.none "No case encoder for member %a" pp_code name 814 - in 815 - let id = Type.Id.make () in 816 - let cases = 817 - { tag; tag_compare; tag_to_string; id; cases; enc; enc_case } 818 - in 819 - let dec = Dec_app (map.dec, id) in 820 - { map with dec; shape = Object_cases (None, cases) } 821 - 822 - (* Unknown members *) 823 - 824 - module Members = struct 825 - type ('mems, 'a) enc = { 826 - enc : 827 - 'acc. 828 - (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc; 829 - } 830 - 831 - type ('mems, 'a, 'builder) map = ('mems, 'a, 'builder) mems_map 832 - 833 - let mems_kind kind = Sort.kinded_string ~kind "members map" 834 - 835 - let map ?(kind = "") ?(doc = "") ?dec_empty ?dec_add ?dec_finish ?enc 836 - mems_type = 837 - let dec_empty = 838 - match dec_empty with 839 - | Some dec_empty -> dec_empty 840 - | None -> fun () -> Error.no_decoder Meta.none ~kind:(mems_kind kind) 841 - in 842 - let dec_add = 843 - match dec_add with 844 - | Some dec_add -> dec_add 845 - | None -> 846 - fun _ _ _ _ -> Error.no_decoder Meta.none ~kind:(mems_kind kind) 847 - in 848 - let dec_finish = 849 - match dec_finish with 850 - | Some dec_finish -> dec_finish 851 - | None -> fun _ _ -> Error.no_decoder Meta.none ~kind:(mems_kind kind) 852 - in 853 - let enc = 854 - match enc with 855 - | Some { enc } -> enc 856 - | None -> 857 - fun _ _ _ -> Error.no_encoder Meta.none ~kind:(mems_kind kind) 858 - in 859 - let id = Type.Id.make () in 860 - { kind; doc; mems_type; id; dec_empty; dec_add; dec_finish; enc } 861 - 862 - let string_map ?kind ?doc type' = 863 - let dec_empty () = String_map.empty in 864 - let dec_add _meta n v mems = String_map.add n v mems in 865 - let dec_finish _meta mems = mems in 866 - let enc f mems acc = 867 - String_map.fold (fun n v acc -> f Meta.none n v acc) mems acc 868 - in 869 - map ?kind ?doc type' ~dec_empty ~dec_add ~dec_finish ~enc:{ enc } 870 - end 871 - 872 - let set_shape_unknown_mems shape u = 873 - match shape with 874 - | Object_basic (Unknown_keep _) | Object_cases (Some (Unknown_keep _), _) 875 - -> 876 - invalid_arg "Json.Object.keep_unknown already called on object" 877 - | Object_basic _ -> Object_basic u 878 - | Object_cases (_, cases) -> Object_cases (Some u, cases) 879 - 880 - let skip_unknown map = 881 - { map with shape = set_shape_unknown_mems map.shape Unknown_skip } 882 - 883 - let error_unknown map = 884 - { map with shape = set_shape_unknown_mems map.shape Unknown_error } 885 - 886 - let mems_noenc (mems : (_, _, _) mems_map) _o = 887 - let kind = Sort.kinded_string ~kind:mems.kind "members" in 888 - Error.no_encoder Meta.none ~kind 889 - 890 - let keep_unknown ?enc mems (map : ('o, 'dec) object_map) = 891 - let enc = match enc with None -> mems_noenc mems | Some enc -> enc in 892 - let dec = Dec_app (map.dec, mems.id) in 893 - let unknown = Unknown_keep (mems, enc) in 894 - { map with dec; shape = set_shape_unknown_mems map.shape unknown } 895 - 896 - let zero = seal (map ~kind:"zero" ()) 897 - 898 - let as_string_map ?kind ?doc t = 899 - map ?kind ?doc Fun.id 900 - |> keep_unknown (Members.string_map t) ~enc:Fun.id 901 - |> seal 902 - end 903 - 904 - (* Ignoring *) 905 - 906 - let ignore : unit t = Ignore 907 - 908 - let zero = 909 - let kind = "zero" in 910 - let null = null () and dec_bool = Bool Base.ignore in 911 - let dec_number = Number Base.ignore in 912 - let dec_string = String Base.ignore in 913 - let dec_array = Array.ignore and dec_object = Object.zero in 914 - let enc () = null in 915 - any ~kind ~dec_null:null ~dec_bool ~dec_number ~dec_string ~dec_array 916 - ~dec_object ~enc () 917 - 918 - let todo ?(kind = "") ?doc ?dec_stub () = 919 - let dec = 920 - match dec_stub with 921 - | Some v -> Fun.const v 922 - | None -> fun _v -> Error.decode_todo Meta.none ~kind_opt:kind 923 - in 924 - let enc _v = Error.encode_todo Meta.none ~kind_opt:kind in 925 - map ~kind ?doc ~dec ~enc ignore 926 - 927 - (* Generic-AST codecs. These preserve the AST shape when (de)coding. *) 928 - 929 - module Value = struct 930 - (* Build codecs that map to / from the generic [Value.t] AST. *) 931 - 932 - let null = 933 - let dec meta () = Value.null ~meta () in 934 - let enc = function 935 - | (Value.Null _ : Value.t) -> () 936 - | j -> Error.sort (Value.meta j) ~exp:Sort.Null ~fnd:(Value.sort j) 937 - in 938 - Null (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 939 - 940 - let bool = 941 - let dec meta b = Value.bool ~meta b in 942 - let enc = function 943 - | (Value.Bool (b, _) : Value.t) -> b 944 - | j -> Error.sort (Value.meta j) ~exp:Sort.Bool ~fnd:(Value.sort j) 945 - in 946 - Bool (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 947 - 948 - let number = 949 - let dec meta n = Value.number ~meta n in 950 - let enc = function 951 - | (Value.Number (n, _) : Value.t) -> n 952 - | j -> Error.sort (Value.meta j) ~exp:Sort.Number ~fnd:(Value.sort j) 953 - in 954 - Number (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 955 - 956 - let string = 957 - let dec meta s = Value.string ~meta s in 958 - let enc = function 959 - | (Value.String (s, _) : Value.t) -> s 960 - | j -> Error.sort (Value.meta j) ~exp:Sort.String ~fnd:(Value.sort j) 961 - in 962 - String (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 963 - 964 - let t, array, mems, object' = 965 - let rec elt = Rec any 966 - and array_map = 967 - lazy begin 968 - let dec_empty () = [] in 969 - let dec_add _i v a = v :: a in 970 - let dec_finish meta _len a = Value.list ~meta (List.rev a) in 971 - let enc f acc = function 972 - | (Value.Array (a, _) : Value.t) -> Array.list_enc f acc a 973 - | j -> Error.sort (Value.meta j) ~exp:Sort.Array ~fnd:(Value.sort j) 974 - in 975 - let enc = { Array.enc } in 976 - Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta:Value.meta 977 - elt 978 - end 979 - and array = lazy (Array.array (Lazy.force array_map)) 980 - and mems = 981 - lazy begin 982 - let dec_empty () = [] in 983 - let dec_add meta n v mems = ((n, meta), v) :: mems in 984 - let dec_finish _meta mems = List.rev mems in 985 - let enc f l a = List.fold_left (fun a ((n, m), v) -> f m n v a) a l in 986 - let enc = { Object.Members.enc } in 987 - Object.Members.map ~dec_empty ~dec_add ~dec_finish ~enc elt 988 - end 989 - and object' = 990 - lazy begin 991 - let enc_meta = function 992 - | (Value.Object (_, meta) : Value.t) -> meta 993 - | j -> 994 - Error.sort (Value.meta j) ~exp:Sort.Object ~fnd:(Value.sort j) 995 - in 996 - let enc = function 997 - | (Value.Object (mems, _) : Value.t) -> mems 998 - | j -> 999 - Error.sort (Value.meta j) ~exp:Sort.Object ~fnd:(Value.sort j) 1000 - in 1001 - let dec meta mems : Value.t = Value.Object (mems, meta) in 1002 - Object.map_with_meta dec ~enc_meta 1003 - |> Object.keep_unknown (Lazy.force mems) ~enc 1004 - |> Object.seal 1005 - end 1006 - and any = 1007 - lazy begin 1008 - let value_array = Lazy.force array in 1009 - let value_object = Lazy.force object' in 1010 - let enc (v : Value.t) = 1011 - match v with 1012 - | Value.Null _ -> null 1013 - | Value.Bool _ -> bool 1014 - | Value.Number _ -> number 1015 - | Value.String _ -> string 1016 - | Value.Array _ -> value_array 1017 - | Value.Object _ -> value_object 1018 - in 1019 - Any 1020 - { 1021 - kind = "json"; 1022 - doc = ""; 1023 - dec_null = Some null; 1024 - dec_bool = Some bool; 1025 - dec_number = Some number; 1026 - dec_string = Some string; 1027 - dec_array = Some value_array; 1028 - dec_object = Some value_object; 1029 - enc; 1030 - } 1031 - end 1032 - in 1033 - (Lazy.force any, Lazy.force array, Lazy.force mems, Lazy.force object') 1034 - 1035 - let _ = mems 1036 - (* The [mems] re-binding below is the real public [mems]; the closed-over 1037 - one above is used internally by [t]. *) 1038 - 1039 - let mems = 1040 - let dec_empty () = [] in 1041 - let dec_add meta name v mems = ((name, meta), v) :: mems in 1042 - let dec_finish meta mems : Value.t = Value.Object (List.rev mems, meta) in 1043 - let enc f j acc = 1044 - match j with 1045 - | (Value.Object (ms, _) : Value.t) -> 1046 - List.fold_left (fun acc ((n, m), v) -> f m n v acc) acc ms 1047 - | j -> Error.sort (Value.meta j) ~exp:Sort.Object ~fnd:(Value.sort j) 1048 - in 1049 - let enc = { Object.Members.enc } in 1050 - Object.Members.map ~dec_empty ~dec_add ~dec_finish ~enc t 1051 - end 1052 - 1053 - (* Decode / encode between generic JSON and typed values using a codec. 1054 - [decode_exn] / [encode_exn] raise [Error]; thin wrappers return results. *) 1055 - 1056 - let error_sort ~exp j = Error.sort (Ast.meta j) ~exp ~fnd:(Ast.sort j) 1057 - 1058 - let error_type t fnd = 1059 - Error.kinded_sort (Ast.meta fnd) ~exp:(kinded_sort t) ~fnd:(Ast.sort fnd) 1060 - 1061 - let find_all_unexpected ~mem_decs mems = 1062 - let unexpected (((n, _) as nm), _v) = 1063 - match String_map.find_opt n mem_decs with 1064 - | None -> Some nm 1065 - | Some _ -> None 1066 - in 1067 - List.filter_map unexpected mems 1068 - 1069 - let rec decode_exn : type a. a t -> Ast.t -> a = 1070 - fun t j -> 1071 - match t with 1072 - | Null map -> ( 1073 - match (j : Ast.t) with 1074 - | Ast.Null (n, meta) -> map.dec meta n 1075 - | j -> error_type t j) 1076 - | Bool map -> ( 1077 - match (j : Ast.t) with 1078 - | Ast.Bool (b, meta) -> map.dec meta b 1079 - | j -> error_type t j) 1080 - | Number map -> ( 1081 - match (j : Ast.t) with 1082 - | Ast.Number (n, meta) -> map.dec meta n 1083 - | Ast.Null (_, meta) -> map.dec meta Float.nan 1084 - | j -> error_type t j) 1085 - | String map -> ( 1086 - match (j : Ast.t) with 1087 - | Ast.String (s, meta) -> map.dec meta s 1088 - | j -> error_type t j) 1089 - | Array map -> ( 1090 - match (j : Ast.t) with 1091 - | Ast.Array (vs, meta) -> decode_array map meta vs 1092 - | j -> error_type t j) 1093 - | Object map -> ( 1094 - match (j : Ast.t) with 1095 - | Ast.Object (mems, meta) -> decode_object map meta mems 1096 - | j -> error_type t j) 1097 - | Map map -> map.dec (decode_exn map.dom j) 1098 - | Any map -> decode_any t map j 1099 - | Rec t -> decode_exn (Lazy.force t) j 1100 - | Ignore -> () 1101 - 1102 - and decode_array : type a elt b. 1103 - (a, elt, b) array_map -> Meta.t -> Ast.t list -> a = 1104 - fun map meta vs -> 1105 - let rec next (map : (a, elt, b) array_map) meta b i = function 1106 - | [] -> map.dec_finish meta i b 1107 - | v :: vs -> 1108 - let b = 1109 - try 1110 - if map.dec_skip i b then b 1111 - else map.dec_add i (decode_exn map.elt v) b 1112 - with Error e -> error_push_array meta map (i, Ast.meta v) e 1113 - in 1114 - next map meta b (i + 1) vs 1115 - in 1116 - next map meta (map.dec_empty ()) 0 vs 1117 - 1118 - and decode_object : type o. (o, o) object_map -> Meta.t -> Ast.object' -> o = 1119 - fun map meta mems -> 1120 - let dict = Dict.empty in 1121 - let umems = Unknown_mems None in 1122 - apply_dict map.dec 1123 - @@ decode_object_map map meta umems String_map.empty String_map.empty dict 1124 - mems 1125 - 1126 - and decode_object_map : type o. 1127 - (o, o) object_map -> 1128 - Meta.t -> 1129 - unknown_mems_option -> 1130 - mem_dec String_map.t -> 1131 - mem_dec String_map.t -> 1132 - Dict.t -> 1133 - Ast.object' -> 1134 - Dict.t = 1135 - fun map meta umems mem_miss mem_decs dict mems -> 1136 - let u _ _ _ = assert false in 1137 - let mem_miss = String_map.union u mem_miss map.mem_decs in 1138 - let mem_decs = String_map.union u mem_decs map.mem_decs in 1139 - match map.shape with 1140 - | Object_cases (umems', cases) -> 1141 - let umems' = Unknown_mems umems' in 1142 - let umems, dict = override_unknown_mems ~by:umems umems' dict in 1143 - decode_object_cases map meta umems cases mem_miss mem_decs dict [] mems 1144 - | Object_basic umems' -> ( 1145 - let umems' = Unknown_mems (Some umems') in 1146 - let umems, dict = override_unknown_mems ~by:umems umems' dict in 1147 - match umems with 1148 - | Unknown_mems (Some Unknown_skip | None) -> 1149 - let umems = Unknown_skip in 1150 - decode_object_basic map meta umems () mem_miss mem_decs dict mems 1151 - | Unknown_mems (Some (Unknown_error as umems)) -> 1152 - decode_object_basic map meta umems () mem_miss mem_decs dict mems 1153 - | Unknown_mems (Some (Unknown_keep (umap, _) as umems)) -> 1154 - let umap = umap.dec_empty () in 1155 - decode_object_basic map meta umems umap mem_miss mem_decs dict mems) 1156 - 1157 - and decode_object_basic : type o p m b. 1158 - (o, o) object_map -> 1159 - Meta.t -> 1160 - (p, m, b) unknown_mems -> 1161 - b -> 1162 - mem_dec String_map.t -> 1163 - mem_dec String_map.t -> 1164 - Dict.t -> 1165 - Ast.object' -> 1166 - Dict.t = 1167 - fun map meta umems umap mem_miss mem_decs dict -> function 1168 - | [] -> finish_object_decode map meta umems umap mem_miss dict 1169 - | (((n, nmeta) as nm), v) :: mems -> ( 1170 - match String_map.find_opt n mem_decs with 1171 - | Some (Mem_dec m) -> 1172 - let dict = 1173 - try Dict.add m.id (decode_exn m.type' v) dict 1174 - with Error e -> error_push_object meta map nm e 1175 - in 1176 - let mem_miss = String_map.remove n mem_miss in 1177 - decode_object_basic map meta umems umap mem_miss mem_decs dict mems 1178 - | None -> ( 1179 - match umems with 1180 - | Unknown_skip -> 1181 - decode_object_basic map meta umems umap mem_miss mem_decs dict 1182 - mems 1183 - | Unknown_error -> 1184 - let fnd = nm :: find_all_unexpected ~mem_decs mems in 1185 - unexpected_mems_error meta map ~fnd 1186 - | Unknown_keep (umap', _) -> 1187 - let umap = 1188 - try umap'.dec_add nmeta n (decode_exn umap'.mems_type v) umap 1189 - with Error e -> error_push_object meta map nm e 1190 - in 1191 - decode_object_basic map meta umems umap mem_miss mem_decs dict 1192 - mems)) 1193 - 1194 - and decode_object_cases : type o cs tg. 1195 - (o, o) object_map -> 1196 - Meta.t -> 1197 - unknown_mems_option -> 1198 - (o, cs, tg) object_cases -> 1199 - mem_dec String_map.t -> 1200 - mem_dec String_map.t -> 1201 - Dict.t -> 1202 - Ast.object' -> 1203 - Ast.object' -> 1204 - Dict.t = 1205 - fun map meta umems cases mem_miss mem_decs dict delay mems -> 1206 - let decode_case_tag map meta tag delay mems = 1207 - let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in 1208 - match List.find_opt eq_tag cases.cases with 1209 - | None -> unexpected_case_tag_error meta map cases tag 1210 - | Some (Case case) -> 1211 - let mems = List.rev_append delay mems in 1212 - let dict = 1213 - decode_object_map case.object_map meta umems mem_miss mem_decs dict 1214 - mems 1215 - in 1216 - Dict.add cases.id 1217 - (case.dec (apply_dict case.object_map.dec dict)) 1218 - dict 1219 - in 1220 - match mems with 1221 - | [] -> ( 1222 - match cases.tag.dec_absent with 1223 - | Some tag -> decode_case_tag map meta tag delay [] 1224 - | None -> 1225 - let kinded_sort = object_kinded_sort map in 1226 - Error.missing_mems meta ~kinded_sort ~exp:[ cases.tag.name ] 1227 - ~fnd:(List.map (fun ((n, _), _) -> n) delay)) 1228 - | ((((n, meta) as nm), v) as mem) :: mems -> ( 1229 - if n = cases.tag.name then 1230 - let tag = 1231 - try decode_exn cases.tag.type' v 1232 - with Error e -> error_push_object meta map nm e 1233 - in 1234 - decode_case_tag map meta tag delay mems 1235 - else 1236 - match String_map.find_opt n mem_decs with 1237 - | None -> 1238 - let delay = mem :: delay in 1239 - decode_object_cases map meta umems cases mem_miss mem_decs dict 1240 - delay mems 1241 - | Some (Mem_dec m) -> 1242 - let dict = 1243 - try Dict.add m.id (decode_exn m.type' v) dict 1244 - with Error e -> error_push_object meta map nm e 1245 - in 1246 - let mem_miss = String_map.remove n mem_miss in 1247 - decode_object_cases map meta umems cases mem_miss mem_decs dict 1248 - delay mems) 1249 - 1250 - and decode_any : type a. a t -> a any_map -> Ast.t -> a = 1251 - fun t map j -> 1252 - let dec t map j = 1253 - match map with Some t -> decode_exn t j | None -> error_type t j 1254 - in 1255 - match (j : Ast.t) with 1256 - | Ast.Null _ -> dec t map.dec_null j 1257 - | Ast.Bool _ -> dec t map.dec_bool j 1258 - | Ast.Number _ -> dec t map.dec_number j 1259 - | Ast.String _ -> dec t map.dec_string j 1260 - | Ast.Array _ -> dec t map.dec_array j 1261 - | Ast.Object _ -> dec t map.dec_object j 1262 - 1263 - let decode t j = try Ok (decode_exn t j) with Error e -> Result.Error e 1264 - 1265 - (* Encode *) 1266 - 1267 - let rec encode_exn : type a. a t -> a -> Ast.t = 1268 - fun t v -> 1269 - match t with 1270 - | Null map -> Ast.null ~meta:(map.enc_meta v) (map.enc v) 1271 - | Bool map -> Ast.bool ~meta:(map.enc_meta v) (map.enc v) 1272 - | Number map -> Ast.number ~meta:(map.enc_meta v) (map.enc v) 1273 - | String map -> Ast.string ~meta:(map.enc_meta v) (map.enc v) 1274 - | Array map -> 1275 - let enc map acc i elt = 1276 - try encode_exn map.elt elt :: acc 1277 - with Error e -> error_push_array Meta.none map (i, Meta.none) e 1278 - in 1279 - Ast.list ~meta:(map.enc_meta v) (List.rev (map.enc (enc map) [] v)) 1280 - | Object map -> 1281 - let mems = encode_object map ~do_unknown:true v [] in 1282 - Ast.Object (List.rev mems, map.enc_meta v) 1283 - | Any map -> encode_exn (map.enc v) v 1284 - | Map map -> encode_exn map.dom (map.enc v) 1285 - | Rec t -> encode_exn (Lazy.force t) v 1286 - | Ignore -> Error.no_encoder Meta.none ~kind:"ignore" 1287 - 1288 - and encode_object : type o. 1289 - (o, o) object_map -> do_unknown:bool -> o -> Ast.object' -> Ast.object' = 1290 - fun map ~do_unknown o obj -> 1291 - let encode_mem map obj (Mem_enc mmap) = 1292 - try 1293 - let v = mmap.enc o in 1294 - if mmap.enc_omit v then obj 1295 - else ((mmap.name, Meta.none), encode_exn mmap.type' v) :: obj 1296 - with Error e -> error_push_object Meta.none map (mmap.name, Meta.none) e 1297 - in 1298 - let obj = List.fold_left (encode_mem map) obj map.mem_encs in 1299 - match map.shape with 1300 - | Object_basic (Unknown_keep (umap, enc)) when do_unknown -> 1301 - encode_unknown_mems map umap (enc o) obj 1302 - | Object_basic _ -> obj 1303 - | Object_cases (u, cases) -> ( 1304 - let (Case_value (case, c)) = cases.enc_case (cases.enc o) in 1305 - let obj = 1306 - let n = (cases.tag.name, Meta.none) in 1307 - try 1308 - if cases.tag.enc_omit case.tag then obj 1309 - else (n, encode_exn cases.tag.type' case.tag) :: obj 1310 - with Error e -> error_push_object Meta.none map n e 1311 - in 1312 - match u with 1313 - | Some (Unknown_keep (umap, enc)) -> 1314 - let obj = encode_object case.object_map ~do_unknown:false c obj in 1315 - encode_unknown_mems map umap (enc o) obj 1316 - | _ -> encode_object case.object_map ~do_unknown c obj) 1317 - 1318 - and encode_unknown_mems : type o mems a builder. 1319 - (o, o) object_map -> 1320 - (mems, a, builder) mems_map -> 1321 - mems -> 1322 - Ast.object' -> 1323 - Ast.object' = 1324 - fun map umap mems obj -> 1325 - let encode_mem map meta name v obj = 1326 - let n = (name, meta) in 1327 - let v = 1328 - try encode_exn umap.mems_type v 1329 - with Error e -> error_push_object Meta.none map n e 1330 - in 1331 - (n, v) :: obj 1332 - in 1333 - umap.enc (encode_mem map) mems obj 1334 - 1335 - let encode t v = try Ok (encode_exn t v) with Error e -> Result.Error e 1336 - 1337 - (* Recode: decode then encode (on values). The [recode] combinator above 1338 - takes labelled [~dec]/[~enc] args; these operate on values. *) 1339 - 1340 - let value_recode_exn t v = encode_exn t (decode_exn t v) 1341 - 1342 - (* Queries and updates *) 1343 - 1344 - let const t v = 1345 - let const _ = v in 1346 - let dec = map ~dec:const ignore in 1347 - let enc = map ~enc:const t in 1348 - let enc _v = enc in 1349 - any ~dec_null:dec ~dec_bool:dec ~dec_number:dec ~dec_string:dec 1350 - ~dec_array:dec ~dec_object:dec ~enc () 1351 - 1352 - let recode ~dec:dom f ~enc = 1353 - let m = map ~dec:f dom in 1354 - let enc _v = enc in 1355 - any ~dec_null:m ~dec_bool:m ~dec_number:m ~dec_string:m ~dec_array:m 1356 - ~dec_object:m ~enc () 1357 - 1358 - let update t = 1359 - let dec v = value_recode_exn t v in 1360 - Map { kind = ""; doc = ""; dom = Value.t; dec; enc = Fun.id } 1361 - 1362 - (* Array queries *) 1363 - 1364 - let rec list_repeat n v l = 1365 - if n <= 0 then l else list_repeat (n - 1) v (v :: l) 1366 - 1367 - let nth ?absent n t = 1368 - let dec_empty () = None in 1369 - let dec_skip i _v = i <> n in 1370 - let dec_add _i v _acc = Some v in 1371 - let dec_finish meta len v = 1372 - match v with 1373 - | Some v -> v 1374 - | None -> ( 1375 - match absent with 1376 - | Some v -> v 1377 - | None -> Error.index_out_of_range meta ~n ~len) 1378 - in 1379 - let enc f acc v = f acc 0 v in 1380 - let enc = { Array.enc } in 1381 - Array.array (Array.map ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc t) 1382 - 1383 - let update_nth ?stub ?absent n t = 1384 - let update_elt _n t v = Ast.copy_layout v ~dst:(value_recode_exn t v) in 1385 - let rec update_array ~seen n t i acc = function 1386 - | v :: vs when i = n -> 1387 - let elt = update_elt (i, Ast.meta v) t v in 1388 - update_array ~seen:true n t (i + 1) (elt :: acc) vs 1389 - | v :: vs -> update_array ~seen n t (i + 1) (v :: acc) vs 1390 - | [] when seen -> Either.Right (List.rev acc) 1391 - | [] -> Either.Left (acc, i) 1392 - in 1393 - let do_update ?stub ?absent n t j = 1394 - match (j : Ast.t) with 1395 - | Ast.Array (vs, meta) -> 1396 - begin match update_array ~seen:false n t 0 [] vs with 1397 - | Either.Right elts -> (Ast.Array (elts, meta) : Ast.t) 1398 - | Either.Left (acc, len) -> ( 1399 - match absent with 1400 - | None -> Error.index_out_of_range meta ~n ~len 1401 - | Some absent -> 1402 - let elt = encode_exn t absent in 1403 - let stub = 1404 - match stub with None -> Ast.zero elt | Some j -> j 1405 - in 1406 - Ast.Array 1407 - (List.rev (elt :: list_repeat (n - len) stub acc), meta)) 1408 - end 1409 - | j -> error_sort ~exp:Sort.Array j 1410 - in 1411 - let dec = do_update ?stub ?absent n t in 1412 - let enc j = j in 1413 - map ~dec ~enc Value.t 1414 - 1415 - let set_nth ?stub ?(allow_absent = false) t n v = 1416 - let absent = if allow_absent then Some v else None in 1417 - update_nth ?stub ?absent n (const t v) 1418 - 1419 - let delete_nth ?(allow_absent = false) n = 1420 - let dec_empty () = [] in 1421 - let dec_add i v a = if i = n then a else v :: a in 1422 - let dec_finish meta len a = 1423 - if n < len || allow_absent then Ast.list ~meta (List.rev a) 1424 - else Error.index_out_of_range meta ~n ~len 1425 - in 1426 - let enc f acc = function 1427 - | (Ast.Array (a, _) : Ast.t) -> Array.list_enc f acc a 1428 - | j -> error_sort ~exp:Sort.Array j 1429 - in 1430 - let enc_meta j = Ast.meta j in 1431 - let enc = { Array.enc } in 1432 - Array.array 1433 - (Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta Value.t) 1434 - 1435 - let filter_map_array a b f = 1436 - let dec_empty () = [] in 1437 - let dec_add i v acc = 1438 - match f i (decode_exn a v) with 1439 - | None -> acc 1440 - | Some v' -> encode_exn b v' :: acc 1441 - in 1442 - let dec_finish meta _len acc = Ast.list ~meta (List.rev acc) in 1443 - let enc f acc = function 1444 - | (Ast.Array (a, _) : Ast.t) -> Array.list_enc f acc a 1445 - | j -> error_sort ~exp:Sort.Array j 1446 - in 1447 - let enc = { Array.enc } in 1448 - let enc_meta j = Ast.meta j in 1449 - Array.array 1450 - (Array.map ~dec_empty ~dec_add ~dec_finish ~enc ~enc_meta Value.t) 1451 - 1452 - let fold_array t f acc = 1453 - let dec_empty () = acc in 1454 - let dec_add = f in 1455 - let dec_finish _meta _len acc = acc in 1456 - let enc _f acc _a = acc in 1457 - let enc = { Array.enc } in 1458 - Array.array (Array.map ~dec_empty ~dec_add ~dec_finish ~enc t) 1459 - 1460 - (* Object queries *) 1461 - 1462 - let mem ?absent name t = 1463 - Object.map Fun.id 1464 - |> Object.member name t ~enc:Fun.id ?dec_absent:absent 1465 - |> Object.seal 1466 - 1467 - let update_mem ?absent name t = 1468 - let update_mem n t v = (n, Ast.copy_layout v ~dst:(value_recode_exn t v)) in 1469 - let rec update_object ~seen name t acc = function 1470 - | (((name', _) as n), v) :: mems when String.equal name name' -> 1471 - update_object ~seen:true name t (update_mem n t v :: acc) mems 1472 - | mem :: mems -> update_object ~seen name t (mem :: acc) mems 1473 - | [] when seen -> Either.Right (List.rev acc) 1474 - | [] -> Either.Left acc 1475 - in 1476 - let do_update ?absent name t = function 1477 - | (Ast.Object (mems, meta) : Ast.t) -> 1478 - let mems = 1479 - match update_object ~seen:false name t [] mems with 1480 - | Either.Right mems -> mems 1481 - | Either.Left acc -> ( 1482 - match absent with 1483 - | None -> 1484 - let fnd = Ast.member_keys mems in 1485 - Error.missing_mems meta ~kinded_sort:"" ~exp:[ name ] ~fnd 1486 - | Some absent -> 1487 - let m = ((name, Meta.none), encode_exn t absent) in 1488 - List.rev (m :: acc)) 1489 - in 1490 - (Ast.Object (mems, meta) : Ast.t) 1491 - | j -> error_sort ~exp:Sort.Object j 1492 - in 1493 - let dec = do_update ?absent name t in 1494 - let enc j = j in 1495 - map ~dec ~enc Value.t 1496 - 1497 - let set_mem ?(allow_absent = false) t name v = 1498 - let absent = if allow_absent then Some v else None in 1499 - update_mem ?absent name (const t v) 1500 - 1501 - let update_value_object ~name ~dec_add ~dec_finish = 1502 - let mems = 1503 - let dec_empty () = (false, []) in 1504 - let enc f (_, l) a = 1505 - List.fold_left (fun a ((n, m), v) -> f m n v a) a l 1506 - in 1507 - let enc = { Object.Members.enc } in 1508 - Object.Members.map ~dec_empty ~dec_add ~dec_finish ~enc Value.t 1509 - in 1510 - let enc_meta = function 1511 - | (Ast.Object (_, meta) : Ast.t) -> meta 1512 - | j -> error_sort ~exp:Sort.Object j 1513 - in 1514 - let enc = function 1515 - | (Ast.Object (mems, _) : Ast.t) -> (false, mems) 1516 - | j -> error_sort ~exp:Sort.Object j 1517 - in 1518 - let dec meta (ok, mems) : Ast.t = 1519 - let fnd = Ast.member_keys mems in 1520 - if not ok then Error.missing_mems meta ~kinded_sort:"" ~exp:[ name ] ~fnd 1521 - else Ast.Object (List.rev mems, meta) 1522 - in 1523 - Object.map_with_meta dec ~enc_meta 1524 - |> Object.keep_unknown mems ~enc 1525 - |> Object.seal 1526 - 1527 - let delete_mem ?(allow_absent = false) name = 1528 - let dec_add meta n v (ok, mems) = 1529 - if n = name then (true, mems) else (ok, ((n, meta), v) :: mems) 1530 - in 1531 - let dec_finish _meta ((_ok, ms) as a) = 1532 - if allow_absent then (true, ms) else a 1533 - in 1534 - update_value_object ~name ~dec_add ~dec_finish 1535 - 1536 - let fold_object t f acc = 1537 - let mems = 1538 - let dec_empty () = acc and dec_add = f and dec_finish _meta acc = acc in 1539 - let enc _f _ acc = acc in 1540 - Object.Members.map t ~dec_empty ~dec_add ~dec_finish 1541 - ~enc:{ Object.Members.enc } 1542 - in 1543 - Object.map Fun.id |> Object.keep_unknown mems ~enc:Fun.id |> Object.seal 1544 - 1545 - let filter_map_object a b f = 1546 - let dec_add meta n v (_, mems) = 1547 - match f meta n (decode_exn a v) with 1548 - | None -> (true, mems) 1549 - | Some (n', v') -> (true, (n', encode_exn b v') :: mems) 1550 - in 1551 - let dec_finish _meta acc = acc in 1552 - update_value_object ~name:"" ~dec_add ~dec_finish 1553 - 1554 - (* Index queries *) 1555 - 1556 - (* Foreign path steps (introduced by other formats via the extensible 1557 - [Path.step]) are projected to [Mem <pp>]: any step pretty-prints to a 1558 - string, so treat it as a name-addressed member by that stringification. 1559 - Worst case this yields a no-op query against a JSON object that does not 1560 - hold a member of that name. *) 1561 - let step_as_mem s = Fmt.str "%a" Path.pp_step s 1562 - 1563 - let index ?absent i t = 1564 - match (i : Path.step) with 1565 - | Path.Nth (n, _) -> nth ?absent n t 1566 - | Path.Mem (n, _) -> mem ?absent n t 1567 - | s -> mem ?absent (step_as_mem s) t 1568 - 1569 - let set_index ?allow_absent t i v = 1570 - match (i : Path.step) with 1571 - | Path.Nth (n, _) -> set_nth ?allow_absent t n v 1572 - | Path.Mem (n, _) -> set_mem ?allow_absent t n v 1573 - | s -> set_mem ?allow_absent t (step_as_mem s) v 1574 - 1575 - let update_index ?stub ?absent i t = 1576 - match (i : Path.step) with 1577 - | Path.Nth (n, _) -> update_nth ?stub ?absent n t 1578 - | Path.Mem (n, _) -> update_mem ?absent n t 1579 - | s -> update_mem ?absent (step_as_mem s) t 1580 - 1581 - let delete_index ?allow_absent = function 1582 - | Path.Nth (n, _) -> delete_nth ?allow_absent n 1583 - | Path.Mem (n, _) -> delete_mem ?allow_absent n 1584 - | s -> delete_mem ?allow_absent (step_as_mem s) 1585 - 1586 - (* Path queries *) 1587 - 1588 - let path ?absent p q = 1589 - List.fold_left (fun q i -> index ?absent i q) q (Path.rev_steps p) 1590 - 1591 - let update_path ?stub ?absent p t = 1592 - match Path.rev_steps p with 1593 - | [] -> update t 1594 - | i :: is -> ( 1595 - match absent with 1596 - | None -> 1597 - let u t i = update_index i t in 1598 - List.fold_left u (update_index i t) is 1599 - | Some absent -> ( 1600 - let rec loop absent t = function 1601 - | Path.Nth (n, _) :: is -> 1602 - loop Ast.empty_array (update_nth ~absent n t) is 1603 - | Path.Mem (n, _) :: is -> 1604 - loop Ast.empty_object (update_mem ~absent n t) is 1605 - | [] -> t 1606 - | s :: is -> 1607 - loop Ast.empty_object 1608 - (update_mem ~absent (step_as_mem s) t) 1609 - is 1610 - in 1611 - match i with 1612 - | Path.Nth (n, _) -> 1613 - loop Ast.empty_array (update_nth ?stub ~absent n t) is 1614 - | Path.Mem (n, _) -> 1615 - loop Ast.empty_object (update_mem ~absent n t) is 1616 - | s -> 1617 - loop Ast.empty_object (update_mem ~absent (step_as_mem s) t) is) 1618 - ) 1619 - 1620 - let null_value : Ast.t = Ast.Null ((), Meta.none) 1621 - 1622 - let delete_path ?allow_absent p = 1623 - match Path.rev_steps p with 1624 - | [] -> recode ~dec:ignore (fun () -> null_value) ~enc:Value.t 1625 - | i :: is -> 1626 - let upd del i = update_index i del in 1627 - List.fold_left upd (delete_index ?allow_absent i) is 1628 - 1629 - let set_path ?stub ?(allow_absent = false) t p v = 1630 - match Path.rev_steps p with 1631 - | [] -> recode ~dec:ignore (fun () -> encode_exn t v) ~enc:Value.t 1632 - | _ :: _ -> 1633 - let absent = if allow_absent then Some v else None in 1634 - update_path ?stub ?absent p (const t v) 1635 - end 1636 - 1637 49 (* Top-level wrappers over generic-value decode / encode / recode. *) 1638 50 1639 51 let decode t j = Codec.decode t j ··· 1860 272 | u when is_number_start u -> Sort.Number 1861 273 | _ -> err_not_json_value d 1862 274 1863 - let type_error d t = 1864 - Codec.type_error (error_meta d) t ~fnd:(current_json_sort d) 275 + let fail_type_mismatch d t = 276 + Codec.fail_type_mismatch (error_meta d) t ~fnd:(current_json_sort d) 1865 277 1866 278 (* Errors for constants *) 1867 279 ··· 2412 824 | Null map -> ( 2413 825 match d.u with 2414 826 | 0x006E (* n *) -> map.dec (read_json_null d) () 2415 - | _ -> type_error d t) 827 + | _ -> fail_type_mismatch d t) 2416 828 | Bool map -> ( 2417 829 match d.u with 2418 830 | 0x0066 (* f *) -> map.dec (read_json_false d) false 2419 831 | 0x0074 (* t *) -> map.dec (read_json_true d) true 2420 - | _ -> type_error d t) 832 + | _ -> fail_type_mismatch d t) 2421 833 | Number map -> ( 2422 834 match d.u with 2423 835 | u when is_number_start u -> 2424 836 let meta = read_json_number d in 2425 837 map.dec meta (token_pop_float d ~meta) 2426 838 | 0x006E (* n *) -> map.dec (read_json_null d) Float.nan 2427 - | _ -> type_error d t) 839 + | _ -> fail_type_mismatch d t) 2428 840 | String map -> ( 2429 841 match d.u with 2430 842 | 0x0022 (* DQUOTE *) -> 2431 843 let meta = read_json_string d in 2432 844 map.dec meta (token_pop d) 2433 - | _ -> type_error d t) 845 + | _ -> fail_type_mismatch d t) 2434 846 | Array map -> ( 2435 847 match d.u with 2436 848 | 0x005B (* [ *) -> decode_array d map 2437 - | _ -> type_error d t) 849 + | _ -> fail_type_mismatch d t) 2438 850 | Object map -> ( 2439 851 match d.u with 2440 852 | 0x007B (* { *) -> decode_object d map 2441 - | _ -> type_error d t) 853 + | _ -> fail_type_mismatch d t) 2442 854 | Map map -> map.dec (parse d map.dom) 2443 855 | Any map -> decode_any d t map 2444 856 | Rec t -> parse d (Lazy.force t) ··· 2473 885 error_meta_to_current ~first_byte ~first_line_num 2474 886 ~first_line_byte d 2475 887 in 2476 - Codec.error_push_array (error_meta d) map (!i, imeta) e 888 + Codec.fail_push_array (error_meta d) map (!i, imeta) e 2477 889 end; 2478 890 incr i; 2479 891 match ··· 2519 931 error_meta_to_current d ~first_byte ~first_line_num ~first_line_byte 2520 932 else meta 2521 933 in 2522 - Error.raise ~ctx ~meta kind 934 + Error.fail ~ctx ~meta kind 2523 935 | Error e -> 2524 936 Error.adjust_context ~first_byte ~first_line_num ~first_line_byte e 2525 937 in ··· 2557 969 | Error e -> raise_notrace (Error e) 2558 970 in 2559 971 Dict.add m.id v dict 2560 - with Error e -> Codec.error_push_object (error_meta d) map nm e 972 + with Error e -> Codec.fail_push_object (error_meta d) map nm e 2561 973 in 2562 974 let mem_miss = String_map.remove name mem_miss in 2563 975 loop d map mem_miss mem_decs rem_delay dict delay) ··· 2596 1008 decode_object_basic d map u () mem_miss mem_decs dict 2597 1009 else 2598 1010 let fnd = List.map fst delay in 2599 - Codec.unexpected_mems_error (error_meta d) map ~fnd 1011 + Codec.fail_unexpected_members (error_meta d) map ~fnd 2600 1012 | Unknown_mems (Some (Unknown_keep (umap, _) as u)) -> 2601 1013 let add_delay umems (((n, meta) as nm), v) = 2602 1014 try ··· 2607 1019 | Error e -> raise_notrace (Error e) 2608 1020 in 2609 1021 umap.dec_add meta n v umems 2610 - with Error e -> Codec.error_push_object (error_meta d) map nm e 1022 + with Error e -> Codec.fail_push_object (error_meta d) map nm e 2611 1023 in 2612 1024 let umems = List.fold_left add_delay (umap.dec_empty ()) delay in 2613 1025 decode_object_basic d map u umems mem_miss mem_decs dict) ··· 2642 1054 let dict = 2643 1055 try Dict.add mem.id (parse d mem.type') dict 2644 1056 with Error e -> 2645 - Codec.error_push_object (error_meta d) map (name, meta) e 1057 + Codec.fail_push_object (error_meta d) map (name, meta) e 2646 1058 in 2647 1059 read_json_mem_sep d; 2648 1060 decode_object_basic d map u umap mem_miss mem_decs dict ··· 2654 1066 let () = 2655 1067 try parse d Codec.ignore 2656 1068 with Error e -> 2657 - Codec.error_push_object (error_meta d) map 1069 + Codec.fail_push_object (error_meta d) map 2658 1070 (token_pop d, meta) 2659 1071 e 2660 1072 in ··· 2663 1075 | Unknown_error -> 2664 1076 let name = token_pop d in 2665 1077 let fnd = [ (name, meta) ] in 2666 - Codec.unexpected_mems_error (error_meta d) map ~fnd 1078 + Codec.fail_unexpected_members (error_meta d) map ~fnd 2667 1079 | Unknown_keep (umap', _) -> 2668 1080 let name = token_pop d in 2669 1081 let umap = 2670 1082 try umap'.dec_add meta name (parse d umap'.mems_type) umap 2671 1083 with Error e -> 2672 - Codec.error_push_object (error_meta d) map (name, meta) e 1084 + Codec.fail_push_object (error_meta d) map (name, meta) e 2673 1085 in 2674 1086 read_json_mem_sep d; 2675 1087 decode_object_basic d map u umap mem_miss mem_decs dict) ··· 2692 1104 let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in 2693 1105 match List.find_opt eq_tag cases.cases with 2694 1106 | None -> ( 2695 - try Codec.unexpected_case_tag_error (error_meta d) map cases tag 1107 + try Codec.fail_unexpected_case_tag (error_meta d) map cases tag 2696 1108 with Error e -> 2697 - Codec.error_push_object (error_meta d) map (cases.tag.name, nmeta) e) 1109 + Codec.fail_push_object (error_meta d) map (cases.tag.name, nmeta) e) 2698 1110 | Some (Case case) -> 2699 1111 if sep then read_json_mem_sep d; 2700 1112 let dict = ··· 2711 1123 | None -> 2712 1124 let fnd = List.map (fun ((n, _), _) -> n) delay in 2713 1125 let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in 2714 - Codec.missing_mems_error (error_meta d) map ~exp ~fnd) 1126 + Codec.fail_missing_members (error_meta d) map ~exp ~fnd) 2715 1127 | 0x0022 -> 2716 1128 let meta = read_json_name d in 2717 1129 let name = token_pop d in ··· 2719 1131 let tag = 2720 1132 try parse d cases.tag.type' 2721 1133 with Error e -> 2722 - Codec.error_push_object (error_meta d) map (name, meta) e 1134 + Codec.fail_push_object (error_meta d) map (name, meta) e 2723 1135 in 2724 1136 decode_case_tag ~sep:true map umems cases mem_miss mem_decs meta tag 2725 1137 delay ··· 2730 1142 let dict = 2731 1143 try Dict.add mem.id (parse d mem.type') dict 2732 1144 with Error e -> 2733 - Codec.error_push_object (error_meta d) map (name, meta) e 1145 + Codec.fail_push_object (error_meta d) map (name, meta) e 2734 1146 in 2735 1147 read_json_mem_sep d; 2736 1148 decode_object_case d map umems cases mem_miss mem_decs delay dict ··· 2740 1152 let v = 2741 1153 try parse d Codec.Value.t 2742 1154 with Error e -> 2743 - Codec.error_push_object (error_meta d) map (name, meta) e 1155 + Codec.fail_push_object (error_meta d) map (name, meta) e 2744 1156 in 2745 1157 let delay = ((name, meta), v) :: delay in 2746 1158 read_json_mem_sep d; ··· 2752 1164 and decode_any : type a. decoder -> a t -> a any_map -> a = 2753 1165 fun d t map -> 2754 1166 let case d t map = 2755 - match map with None -> type_error d t | Some t -> parse d t 1167 + match map with None -> fail_type_mismatch d t | Some t -> parse d t 2756 1168 in 2757 1169 match d.u with 2758 1170 | 0x006E (* n *) -> case d t map.dec_null ··· 2977 1389 try 2978 1390 write ~nest map.elt e v; 2979 1391 e 2980 - with Error e -> Codec.error_push_array Meta.none map (i, Meta.none) e 1392 + with Error e -> Codec.fail_push_array Meta.none map (i, Meta.none) e 2981 1393 in 2982 1394 match e.format with 2983 1395 | Minify -> ··· 2999 1411 try 3000 1412 write ~nest map.elt e v; 3001 1413 e 3002 - with Error e -> Codec.error_push_array Meta.none map (i, Meta.none) e 1414 + with Error e -> Codec.fail_push_array Meta.none map (i, Meta.none) e 3003 1415 in 3004 1416 let array_not_empty e = 3005 1417 e.o_next = 0 || not (Bytes.get e.o (e.o_next - 1) = '[') ··· 3063 1475 false 3064 1476 end 3065 1477 with Error e -> 3066 - Codec.error_push_object Meta.none map (mmap.name, Meta.none) e 1478 + Codec.fail_push_object Meta.none map (mmap.name, Meta.none) e 3067 1479 in 3068 1480 match map.shape with 3069 1481 | Object_basic u -> ··· 3108 1520 encode_mem_name e meta n; 3109 1521 write ~nest umap.mems_type e v; 3110 1522 false 3111 - with Error e -> Codec.error_push_object Meta.none map (n, Meta.none) e 1523 + with Error e -> Codec.fail_push_object Meta.none map (n, Meta.none) e 3112 1524 in 3113 1525 umap.enc (encode_unknown_mem ~nest map umap e) mems start 3114 1526

+20 -1215

lib/json.mli

··· 43 43 module Context = Loc.Context 44 44 (** Navigation contexts (path + source loc + active sort). *) 45 45 46 + type fpath = Loc.fpath 47 + (** File path used by decoders for error reporting. *) 48 + 46 49 module Sort = Sort 47 50 (** Sorts of JSON values ({!Sort.Null}, {!Sort.Bool}, {!Sort.Number}, 48 51 {!Sort.String}, {!Sort.Array}, {!Sort.Object}). Labels used in structured 49 - error contexts and {!Loc.Path} frames. *) 50 - 51 - (** Encoding, decoding and query errors. *) 52 - module Error : sig 53 - (** {1:kinds Kinds of errors} *) 54 - 55 - type kind = Loc.Error.kind = .. 56 - (** The type for kind of errors. *) 57 - 58 - val kind_to_string : kind -> string 59 - (** [kind_to_string kind] is [kind] as a string. *) 60 - 61 - (** {1:errors Errors} *) 62 - 63 - type t = Loc.Error.t = { ctx : Context.t; meta : Meta.t; kind : kind } 64 - (** The type for errors. *) 65 - 66 - val v : ctx:Context.t -> meta:Meta.t -> kind -> t 67 - (** [v ~ctx ~meta k] constructs an error with a typed kind. *) 68 - 69 - val msg : ctx:Context.t -> meta:Meta.t -> string -> t 70 - (** [msg ~ctx ~meta s] constructs an error from a plain string. *) 71 - 72 - val raise : ctx:Context.t -> meta:Meta.t -> kind -> 'a 73 - (** [raise ~ctx ~meta k] raises an error with a typed kind. *) 74 - 75 - val fail : Meta.t -> string -> 'a 76 - (** [fail meta s] raises an error with empty context and message [s]. *) 77 - 78 - val failf : Meta.t -> ('a, Stdlib.Format.formatter, unit, 'b) format4 -> 'a 79 - (** [failf meta Fmt.t] is like {!fail} but formats the message. *) 80 - 81 - val expected : Meta.t -> string -> fnd:string -> 'a 82 - (** [expected meta Fmt.t exp ~fnd] is 83 - [msgf "Expected %s but found %s" exp fnd]. *) 84 - 85 - val push_array : string node -> int node -> t -> 'a 86 - (** [push_array kinded_sort n e] contextualises [e] as an error in the [n]th 87 - element of an array of kinded sort [kinded_sort]. *) 88 - 89 - val push_object : string node -> string node -> t -> 'a 90 - (** [push_object kinded_sort n e] contextualises [e] as an error in the member 91 - [n] of an object of kinded sort [kinded_sort]. *) 52 + error contexts and {!Path} frames. *) 92 53 93 - val adjust_context : 94 - first_byte:Loc.byte_pos -> 95 - first_line_num:Loc.line_num -> 96 - first_line_byte:Loc.byte_pos -> 97 - t -> 98 - 'a 99 - (** [adjust_context ~first_byte ~first_line_num ~first_line_byte] adjusts the 100 - error's context's meta to encompass the given positions. *) 101 - 102 - (** {1:fmt Formatting} *) 103 - 104 - val to_string : t -> string 105 - (** [error_to_string e] formats [e] using {!val-pp} to a string. *) 106 - 107 - val pp : t Fmt.t 108 - (** [pp_error] formats errors. *) 109 - 110 - val puterr : unit Fmt.t 111 - (** [puterr] formats [Error:] in red. *) 112 - 113 - (** {1:typed Typed helpers} *) 114 - 115 - val sort : Meta.t -> exp:Sort.t -> fnd:Sort.t -> 'a 116 - (** [sort meta ~exp ~fnd] raises [Sort_mismatch]. *) 117 - 118 - val kinded_sort : Meta.t -> exp:string -> fnd:Sort.t -> 'a 119 - (** [kinded_sort meta ~exp ~fnd] raises [Kinded_sort_mismatch]. *) 120 - 121 - (**/**) 122 - 123 - val disable_ansi_styler : unit -> unit 124 - 125 - (**/**) 126 - end 54 + module Error = Error 55 + (** Typed JSON errors. Every error shape ships as a pair: [foo] builds a {!t}, 56 + [fail_foo] raises it. See {!Error} for the full menu. *) 127 57 128 58 exception Error of Error.t 129 59 (** The exception raised on map errors. *) ··· 156 86 type number_format = Value.number_format 157 87 (** The type for JSON number formatters. *) 158 88 89 + module Codec = Codec 90 + (** Codec combinators. See {!module:Codec}. *) 91 + 159 92 type 'a codec = 'a Codec.t 160 93 (** The type for JSON codecs: a bidirectional map between JSON values and OCaml 161 94 values. Build codecs with {!module-Codec}. *) ··· 169 102 string carrying the error message, so this function always produces valid 170 103 JSON. *) 171 104 172 - (** {1:codec Codec combinators} 173 - 174 - Codec combinators describe how OCaml values map to and from JSON values. 175 - Most users open {!Codec} to build codecs: 176 - {[ 177 - let open Json.Codec in … 178 - ]} *) 179 - 180 - (** Codec combinators and the low-level codec representation. *) 181 - module Codec : sig 182 - (** {1:types Types} *) 183 - 184 - type value := t 185 - (** Destructive alias: inside this module, [value] refers to the outer 186 - {!Json.t} AST (so the codec type [t] below can shadow the AST without 187 - losing access to it). *) 188 - 189 - (** The type for JSON types (codecs). Constructors are re-exported below in 190 - the {{!types_group}mutual types block}. *) 191 - type 'a t = 'a Codec.t = 192 - | Null : (unit, 'a) Codec.base_map -> 'a t 193 - | Bool : (bool, 'a) Codec.base_map -> 'a t 194 - | Number : (float, 'a) Codec.base_map -> 'a t 195 - | String : (string, 'a) Codec.base_map -> 'a t 196 - | Array : ('a, 'elt, 'builder) Codec.array_map -> 'a t 197 - | Object : ('o, 'o) Codec.object_map -> 'o t 198 - | Any : 'a Codec.any_map -> 'a t 199 - | Map : ('b, 'a) Codec.map -> 'a t 200 - | Rec : 'a t Lazy.t -> 'a t 201 - | Ignore : unit t (** *) 202 - 203 - val kinded_sort : 'a t -> string 204 - (** [kinded_sort t] is a human readable string describing the JSON values 205 - typed by [t]. This combines the kind of the map with the {{!Sort}sort}(s) 206 - of JSON value mapped by [t]. For example if [t] is an object map and the 207 - kind specified for the {{!Object.val-map}map} is ["T"] then this is 208 - ["T object"], if the kind is empty this is simply ["object"]. See also 209 - {!Sort.kinded}. *) 210 - 211 - val kind : 'a t -> string 212 - (** [kind t] is the [kind] of the underlying map. If the kind is an empty 213 - string this falls back to mention the {{!Sort}sort}. For example if [t] is 214 - an object map and the kind specified for the {{!Object.val-map}map} is 215 - ["T"] then this is ["T"], if the kind is empty then this is ["object"]. 216 - See also {!Sort.or_kind}. *) 217 - 218 - val doc : 'a t -> string 219 - (** [doc t] is a documentation string for the JSON values typed by [t]. *) 220 - 221 - val with_doc : ?kind:string -> ?doc:string -> 'a t -> 'a t 222 - (** [with_doc ?kind ?doc t] is [t] with its {!doc} or {!kind} updated to the 223 - corresponding values if specified. *) 224 - 225 - (** {1:base Base types} 226 - 227 - Read the {{!page-cookbook.base_types}cookbook} on base types. *) 228 - 229 - (** Mapping JSON base types. *) 230 - module Base : sig 231 - (** {1:maps Maps} *) 232 - 233 - type ('a, 'b) map 234 - (** The type for mapping JSON values of type ['a] to values of type ['b]. *) 235 - 236 - val map : 237 - ?kind:string -> 238 - ?doc:string -> 239 - ?dec:(Meta.t -> 'a -> 'b) -> 240 - ?enc:('b -> 'a) -> 241 - ?enc_meta:('b -> Meta.t) -> 242 - unit -> 243 - ('a, 'b) map 244 - (** [map ~kind ~doc ~dec ~enc ~enc_meta ()] maps JSON base types represented 245 - by value of type ['a] to values of type ['b] with: 246 - - [kind] names the entities represented by the map and [doc] documents 247 - them. Both default to [""]. 248 - - [dec] is used to decode values of type ['a] to values of type ['b]. 249 - Can be omitted if the map is only used for encoding, the default 250 - unconditionally errors. 251 - - [enc] is used to encode values of type ['b] to values of type ['a]. 252 - Can be omitted if the map is only used for decoding, the default 253 - unconditionally errors. 254 - - [enc_meta] is used to recover JSON metadata (source text layout 255 - information) from a value to encode. The default unconditionnaly 256 - returns {!Json.Meta.none}. 257 - 258 - {{!decenc}These functions} can be used to quickly devise [dec] and [enc] 259 - functions from standard OCaml conversion interfaces. *) 260 - 261 - val id : ('a, 'a) map 262 - (** [id] is the identity map. *) 263 - 264 - val ignore : ('a, unit) map 265 - (** [ignore] is the ignoring map. It ignores decodes and errors on encodes. 266 - *) 267 - 268 - (** {2:types JSON types} *) 269 - 270 - val null : (unit, 'a) map -> 'a t 271 - (** [null map] maps with [map] JSON nulls represented by [()] to values of 272 - type ['a]. See also {!Codec.null}. *) 273 - 274 - val bool : (bool, 'a) map -> 'a t 275 - (** [bool map] maps with [map] JSON booleans represented by [bool] values to 276 - values of type ['a]. See also {!Codec.bool}. *) 277 - 278 - val number : (float, 'a) map -> 'a t 279 - (** [number map] maps with [map] JSON nulls or numbers represented by 280 - [float] values to values of type ['a]. The [float] representation 281 - decodes JSON nulls to {!Float.nan} and lossily encodes any 282 - {{!Float.is_finite}non-finite} to JSON null 283 - ({{!page-cookbook.non_finite_numbers}explanation}). See also 284 - {!Codec.number}. *) 285 - 286 - val string : (string, 'a) map -> 'a t 287 - (** [string map] maps with [map] {e unescaped} JSON strings represented by 288 - UTF-8 encoded [string] values to values of type ['a]. See also 289 - {!Codec.string}. *) 290 - 291 - (** {1:decenc Decoding and encoding functions} 292 - 293 - These function create suitable [dec] and [enc] functions to give to 294 - {!val-map} from standard OCaml conversion interfaces. See also 295 - {!Codec.of_of_string}. *) 296 - 297 - val dec : ('a -> 'b) -> Meta.t -> 'a -> 'b 298 - (** [dec f] is a decoding function from [f]. This assumes [f] never fails. 299 - *) 300 - 301 - val dec_result : 302 - ?kind:string -> ('a -> ('b, string) result) -> Meta.t -> 'a -> 'b 303 - (** [dec f] is a decoding function from [f]. [Error _] values are given to 304 - {!Error.msg}, prefixed by [kind:] (if specified). *) 305 - 306 - val dec_failure : ?kind:string -> ('a -> 'b) -> Meta.t -> 'a -> 'b 307 - (** [dec f] is a decoding function from [f]. [Failure _] exceptions are 308 - catched and given to {!Error.msg}, prefixed by [kind:] (if specified). 309 - *) 310 - 311 - val enc : ('b -> 'a) -> 'b -> 'a 312 - (** [enc f] is an encoding function from [f]. This assumes [f] never fails. 313 - *) 314 - 315 - val enc_result : ?kind:string -> ('b -> ('a, string) result) -> 'b -> 'a 316 - (** [enc_result f] is an encoding function from [f]. [Error _] values are 317 - given to {!Error.msg}, prefixed by [kind:] (if specified). *) 318 - 319 - val enc_failure : ?kind:string -> ('b -> 'a) -> 'b -> 'a 320 - (** [enc_failure f] is an encoding function from [f]. [Failure _] exceptions 321 - are catched and given to {!Error.msg}, prefixed by [kind:] (if 322 - specified). *) 323 - end 324 - 325 - (** {2:option Nulls and options} 326 - 327 - Read the {{!page-cookbook.dealing_with_null}cookbook} on [null]s. *) 328 - 329 - val null : ?kind:string -> ?doc:string -> 'a -> 'a t 330 - (** [null v] maps JSON nulls to [v]. On encodes any value of type ['a] is 331 - encoded by null. [doc] and [kind] are given to the underlying 332 - {!Base.type-map}. See also {!Base.null}. *) 333 - 334 - val none : 'a option t 335 - (** [none] maps JSON nulls to [None]. *) 336 - 337 - val some : 'a t -> 'a option t 338 - (** [some t] maps JSON like [t] does but wraps results in [Some]. Encoding 339 - fails if the value is [None]. *) 340 - 341 - val option : ?kind:string -> ?doc:string -> 'a t -> 'a option t 342 - (** [option t] maps JSON nulls to [None] and other values by [t]. [doc] and 343 - [kind] are given to the underlying {!val-any} map. *) 344 - 345 - (** {2:booleans Booleans} *) 346 - 347 - val bool : bool t 348 - (** [bool] maps JSON booleans to [bool] values. See also {!Base.bool}. *) 349 - 350 - (** {2:numbers Numbers} 351 - 352 - Read the {{!page-cookbook.dealing_with_numbers}cookbook} on JSON numbers 353 - and their many pitfalls. *) 354 - 355 - val number : float t 356 - (** [number] maps JSON nulls or numbers to [float] values. On decodes JSON 357 - null is mapped to {!Float.nan}. On encodes any 358 - {{!Float.is_finite}non- finite} float is lossily mapped to JSON null 359 - ({{!page-cookbook.non_finite_numbers}explanation}). See also 360 - {!Base.number}, {!any_float} and the integer combinators below. *) 361 - 362 - val any_float : float t 363 - (** [any_float] is a lossless representation for IEEE 754 doubles. It maps 364 - {{!Float.is_finite}non-finite} floats by the JSON strings defined by 365 - {!Float.to_string}. This contrasts with {!val-number} which maps them to 366 - JSON null values ({{!page-cookbook.non_finite_numbers}explanation}). Note 367 - that on decodes this still maps JSON nulls to {!Float.nan} and any 368 - successful string decode of {!Float.of_string_opt} (so numbers can also be 369 - written as strings). See also {!val-number}. 370 - 371 - {b Warning.} [any_float] should only be used between parties that have 372 - agreed on such an encoding. To maximize interoperability you should use 373 - the lossy {!val-number} map. *) 374 - 375 - val float_as_hex_string : float t 376 - (** [float_as_hex_string] maps JSON strings made of IEEE 754 doubles in hex 377 - notation to float values. On encodes strings this uses the ["%h"] format 378 - string. On decodes it accepts anything sucessfully decoded by 379 - {!Float.of_string_opt}. *) 380 - 381 - val uint8 : int t 382 - (** [uint8] maps JSON numbers to unsigned 8-bit integers. JSON numbers are 383 - sucessfully decoded if after truncation they can be represented on the 384 - \[0;255\] range. Encoding errors if the integer is out of range. *) 385 - 386 - val uint16 : int t 387 - (** [uint16] maps JSON numbers to unsigned 16-bit integers. JSON numbers are 388 - sucessfully decoded if after truncation they can be represented on the 389 - \[0;65535\] range. Encoding errors if the integer is out of range. *) 390 - 391 - val int8 : int t 392 - (** [int8] maps JSON numbers to 8-bit integers. JSON numbers are sucessfully 393 - decoded if after truncation they can be represented on the \[-128;127\] 394 - range. Encoding errors if the integer is out of range. *) 395 - 396 - val int16 : int t 397 - (** [int16] maps JSON numbers to 16-bit integers. JSON numbers are sucessfully 398 - decoded if after truncation they can be represented on the 399 - \[-32768;32767\] range. Encoding errors if the integer is out of range. *) 400 - 401 - val int32 : int32 t 402 - (** [int32] maps JSON numbers to 32-bit integers. JSON numbers are sucessfully 403 - decoded if after truncation they can be represented on the [int32] range, 404 - otherwise the decoder errors. *) 405 - 406 - val int64 : int64 t 407 - (** [int64] maps truncated JSON numbers or JSON strings to 64-bit integers. 408 - - JSON numbers are sucessfully decoded if after truncation they can be 409 - represented on the [int64] range, otherwise the decoder errors. [int64] 410 - values are encoded as JSON numbers if the integer is in the 411 - \[-2{^ 53};2{^ 53}\] range. 412 - - JSON strings are decoded using {!int_of_string_opt}, this allows binary, 413 - octal, decimal and hex syntaxes and errors on overflow and syntax 414 - errors. [int64] values are encoded as JSON strings with 415 - {!Int64.to_string} when the integer is outside the \[-2{^ 53};2{^ 53}\] 416 - range. *) 417 - 418 - val int64_as_string : int64 t 419 - (** [int64_as_string] maps JSON strings to 64-bit integers. On decodes this 420 - uses {!Int64.of_string_opt} which allows binary, octal, decimal and hex 421 - syntaxes and errors on overflow and syntax errors. On encodes uses 422 - {!Int64.to_string}. *) 423 - 424 - val int : int t 425 - (** [int] maps truncated JSON numbers or JSON strings to [int] values. 426 - - JSON numbers are sucessfully decoded if after truncation they can be 427 - represented on the [int] range, otherwise the decoder errors. [int] 428 - values are encoded as JSON numbers if the integer is in the 429 - \[-2{^ 53};2{^ 53}\] range. 430 - - JSON strings are decoded using {!int_of_string_opt}, this allows binary, 431 - octal, decimal and hex syntaxes and errors on overflow and syntax 432 - errors. [int] values are encoded as JSON strings with {!Int.to_string} 433 - when the integer is outside the \[-2{^ 53};2{^ 53}\] range 434 - 435 - {b Warning.} The behaviour of this function is platform dependent, it 436 - depends on the value of {!Sys.int_size}. *) 437 - 438 - val int_as_string : int t 439 - (** [int_as_string] maps JSON strings to [int] values. On decodes this uses 440 - {!int_of_string_opt} which allows binary, octal, decimal and hex syntaxes 441 - and errors on overflow and syntax errors. On encodes uses 442 - {!Int.to_string}. 443 - 444 - {b Warning.} The behaviour of this function is platform dependent, it 445 - depends on the value of {!Sys.int_size}. *) 446 - 447 - (** {2:enums Strings and enums} 448 - 449 - Read the {{!page-cookbook.transform_strings}cookbook} on transforming 450 - strings. *) 451 - 452 - val string : string t 453 - (** [string] maps unescaped JSON strings to UTF-8 encoded [string] values. See 454 - also {!Base.string}. 455 - 456 - {b Warning.} Encoders assume OCaml [string]s have been checked for UTF-8 457 - validity. *) 458 - 459 - val of_of_string : 460 - ?kind:string -> 461 - ?doc:string -> 462 - ?enc:('a -> string) -> 463 - (string -> ('a, string) result) -> 464 - 'a t 465 - (** [of_of_string of_string] maps JSON string with a 466 - {{!Base.type-map}base map} using [of_string] for decoding and [enc] for 467 - encoding. See the {{!page-cookbook.transform_strings}cookbook}. *) 468 - 469 - val enum : 470 - ?cmp:('a -> 'a -> int) -> 471 - ?kind:string -> 472 - ?doc:string -> 473 - (string * 'a) list -> 474 - 'a t 475 - (** [enum assoc] maps JSON strings member of the [assoc] list to the 476 - corresponding OCaml value and vice versa in log(n). [cmp] is used to 477 - compare the OCaml values, it defaults to {!Stdlib.compare}. Decoding and 478 - encoding errors on strings or values not part of [assoc]. *) 479 - 480 - val binary_string : string t 481 - (** [binary_string] maps JSON strings made of an even number of hexdecimal 482 - US-ASCII upper or lower case digits to the corresponding byte sequence. On 483 - encoding uses only lower case hexadecimal digits to encode the byte 484 - sequence. *) 485 - 486 - (** {1:arrays Arrays and tuples} 487 - 488 - Read the {{!page-cookbook.dealing_with_arrays}cookbok} on arrays. *) 489 - 490 - (** Mapping JSON arrays. *) 491 - module Array : sig 492 - (** {1:maps Maps} *) 493 - 494 - type ('array, 'elt) enc = { 495 - enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; 496 - } 497 - (** The type for specifying array encoding functions. A function to fold 498 - over the elements of type ['elt] of the array of type ['array]. *) 499 - 500 - type ('array, 'elt, 'builder) map 501 - (** The type for mapping JSON arrays with elements of type ['elt] to arrays 502 - of type ['array] using values of type ['builder] to build them. *) 503 - 504 - val map : 505 - ?kind:string -> 506 - ?doc:string -> 507 - ?dec_empty:(unit -> 'builder) -> 508 - ?dec_skip:(int -> 'builder -> bool) -> 509 - ?dec_add:(int -> 'elt -> 'builder -> 'builder) -> 510 - ?dec_finish:(Meta.t -> int -> 'builder -> 'array) -> 511 - ?enc:('array, 'elt) enc -> 512 - ?enc_meta:('array -> Meta.t) -> 513 - 'elt t -> 514 - ('array, 'elt, 'builder) map 515 - (** [map elt] maps JSON arrays of type ['elt] to arrays of type ['array] 516 - built with type ['builder]. See the {!Json.Codec.Array} documentation 517 - for argument descriptions. *) 518 - 519 - val list_map : 520 - ?kind:string -> 521 - ?doc:string -> 522 - ?dec_skip:(int -> 'a list -> bool) -> 523 - 'a t -> 524 - ('a list, 'a, 'a list) map 525 - (** [list_map elt] maps JSON arrays with elements of type [elt] to [list] 526 - values. See also {!Codec.list}. *) 527 - 528 - type 'a array_builder 529 - (** The type for array builders. *) 530 - 531 - val array_map : 532 - ?kind:string -> 533 - ?doc:string -> 534 - ?dec_skip:(int -> 'a array_builder -> bool) -> 535 - 'a t -> 536 - ('a array, 'a, 'a array_builder) map 537 - (** [array_map elt] maps JSON arrays with elements of type [elt] to [array] 538 - values. See also {!Codec.array}. *) 539 - 540 - type ('a, 'b, 'c) bigarray_builder 541 - (** The type for bigarray_builders. *) 542 - 543 - val bigarray_map : 544 - ?kind:string -> 545 - ?doc:string -> 546 - ?dec_skip:(int -> ('a, 'b, 'c) bigarray_builder -> bool) -> 547 - ('a, 'b) Bigarray.kind -> 548 - 'c Bigarray.layout -> 549 - 'a t -> 550 - (('a, 'b, 'c) Bigarray.Array1.t, 'a, ('a, 'b, 'c) bigarray_builder) map 551 - (** [bigarray k l elt] maps JSON arrays with elements of type [elt] to 552 - bigarray values of kind [k] and layout [l]. See also {!Codec.bigarray}. 553 - *) 554 - 555 - (** {1:types JSON types} *) 556 - 557 - val array : ('a, _, _) map -> 'a t 558 - (** [array map] maps with [map] JSON arrays to values of type ['a]. See the 559 - the {{!section-arrays}array combinators}. *) 560 - 561 - val ignore : unit t 562 - (** [ignore] ignores JSON arrays on decoding and errors on encoding. *) 563 - 564 - val zero : unit t 565 - (** [zero] ignores JSON arrays on decoding and encodes an empty array. *) 566 - end 567 - 568 - val list : ?kind:string -> ?doc:string -> 'a t -> 'a list t 569 - (** [list t] maps JSON arrays of type [t] to [list] values. See also 570 - {!Array.list_map}. *) 571 - 572 - val array : ?kind:string -> ?doc:string -> 'a t -> 'a array t 573 - (** [array t] maps JSON arrays of type [t] to [array] values. See also 574 - {!Array.array_map}. *) 575 - 576 - val array_as_string_map : 577 - ?kind:string -> 578 - ?doc:string -> 579 - key:('a -> string) -> 580 - 'a t -> 581 - 'a Map.Make(String).t t 582 - (** [array_as_string_map ~key t] maps JSON array elements of type [t] to 583 - string maps by indexing them with [key]. If two elements have the same 584 - [key] the element with the greatest index takes over. Elements of the map 585 - are encoded to a JSON array in (binary) key order. *) 586 - 587 - val bigarray : 588 - ?kind:string -> 589 - ?doc:string -> 590 - ('a, 'b) Bigarray.kind -> 591 - 'a t -> 592 - ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t t 593 - (** [bigarray k t] maps JSON arrays of type [t] to [Bigarray.Array1.t] values. 594 - See also {!Array.bigarray_map}. *) 595 - 596 - val t2 : 597 - ?kind:string -> 598 - ?doc:string -> 599 - ?dec:('a -> 'a -> 't2) -> 600 - ?enc:('t2 -> int -> 'a) -> 601 - 'a t -> 602 - 't2 t 603 - (** [t2 ?dec ?enc t] maps JSON arrays with exactly 2 elements of type [t] to 604 - value of type ['t2]. Decodes error if there are more elements. [enc v i] 605 - must return the zero-based [i]th element. *) 606 - 607 - val t3 : 608 - ?kind:string -> 609 - ?doc:string -> 610 - ?dec:('a -> 'a -> 'a -> 't3) -> 611 - ?enc:('t3 -> int -> 'a) -> 612 - 'a t -> 613 - 't3 t 614 - (** [t3] is like {!t2} but for 3 elements. *) 615 - 616 - val t4 : 617 - ?kind:string -> 618 - ?doc:string -> 619 - ?dec:('a -> 'a -> 'a -> 'a -> 't4) -> 620 - ?enc:('t4 -> int -> 'a) -> 621 - 'a t -> 622 - 't4 t 623 - (** [t4] is like {!t2} but for 4 elements. *) 624 - 625 - val tn : ?kind:string -> ?doc:string -> n:int -> 'a t -> 'a array t 626 - (** [tn ~n t] maps JSON arrays of exactly [n] elements of type [t] to [array] 627 - values. This is {!val-array} limited by [n]. *) 628 - 629 - (** {1:objects Objects} 630 - 631 - Read the {{!page-cookbook.dealing_with_objects}cookbook} on objects. *) 632 - 633 - (** Mapping JSON objects. *) 634 - module Object : sig 635 - (** {1:maps Maps} *) 636 - 637 - type ('o, 'dec) map 638 - (** The type for mapping JSON objects to values of type ['o]. The ['dec] 639 - type is used to construct ['o] from members see {!val-mem}. *) 640 - 641 - val map : ?kind:string -> ?doc:string -> 'dec -> ('o, 'dec) map 642 - (** [map dec] is an empty JSON object decoded by function [dec]. 643 - - [kind] names the entities represented by the map and [doc] documents 644 - them. Both default to [""]. 645 - - [dec] is a constructor eventually returning a value of type ['o] to be 646 - saturated with calls to {!val-mem}, {!val-case_mem} or 647 - {!val-keep_unknown}. This is needed for decoding. Use {!enc_only} if 648 - the result is only used for encoding. *) 649 - 650 - val map_with_meta : 651 - ?kind:string -> 652 - ?doc:string -> 653 - ?enc_meta:('o -> Meta.t) -> 654 - (Meta.t -> 'dec) -> 655 - ('o, 'dec) map 656 - (** [map_with_meta dec] is like {!val-map} except [dec] receives the 657 - object's decoding metadata and [?enc_meta] is used to recover it on 658 - encoding. *) 659 - 660 - val enc_only : 661 - ?kind:string -> 662 - ?doc:string -> 663 - ?enc_meta:('o -> Meta.t) -> 664 - unit -> 665 - ('o, 'a) map 666 - (** [enc_only ()] is like {!val-map'} but can only be used for encoding. *) 667 - 668 - val seal : ('o, 'o) map -> 'o t 669 - (** [finish map] is a JSON type for objects mapped by [map]. Raises 670 - [Invalid_argument] if [map] describes a member name more than once. *) 671 - 672 - (** {1:mems Members} *) 673 - 674 - (** Member maps. 675 - 676 - Usually it's better to use {!Json.Codec.Object.member} or 677 - {!Json.Codec.Object.opt_member} directly. But this may be useful in 678 - certain abstraction contexts. *) 679 - module Member : sig 680 - type ('o, 'dec) object_map := ('o, 'dec) map 681 - 682 - type ('o, 'a) map 683 - (** The type for mapping a member object to a value ['a] stored in an 684 - OCaml value of type ['o]. *) 685 - 686 - val map : 687 - ?doc:string -> 688 - ?dec_absent:'a -> 689 - ?enc:('o -> 'a) -> 690 - ?enc_omit:('a -> bool) -> 691 - string -> 692 - 'a codec -> 693 - ('o, 'a) map 694 - (** See {!Json.Codec.Object.member}. *) 695 - 696 - val app : ('o, 'a -> 'b) object_map -> ('o, 'a) map -> ('o, 'b) object_map 697 - (** [app map mmap] applies the member map [mmap] to the contructor of the 698 - object map [map]. In turn this adds the [mmap] member definition to 699 - the object described by [map]. *) 700 - end 701 - 702 - val member : 703 - ?doc:string -> 704 - ?dec_absent:'a -> 705 - ?enc:('o -> 'a) -> 706 - ?enc_omit:('a -> bool) -> 707 - string -> 708 - 'a codec -> 709 - ('o, 'a -> 'b) map -> 710 - ('o, 'b) map 711 - (** [member name t map] is a member named [name] of type [t] for an object 712 - of type ['o] being constructed by [map]. 713 - - [doc] is a documentation string for the member. Defaults to [""]. 714 - - [dec_absent], if specified, is the value used for the decoding 715 - direction when the member named [name] is missing. If unspecified 716 - decoding errors when the member is absent. 717 - - [enc] is used to project the member's value from the object 718 - representation ['o] for encoding to JSON with [t]. It can be omitted 719 - if the result is only used for decoding. 720 - - [enc_omit] is for the encoding direction. If the member value returned 721 - by [enc] returns [true] on [enc_omit], the member is omited in the 722 - encoded JSON object. Defaults to [Fun.const false]. *) 723 - 724 - val opt_member : 725 - ?doc:string -> 726 - ?enc:('o -> 'a option) -> 727 - string -> 728 - 'a codec -> 729 - ('o, 'a option -> 'b) map -> 730 - ('o, 'b) map 731 - (** [opt_member name t map] is: 732 - {[ 733 - let dec_absent = None and enc_omit = Option.is_none in 734 - Json.Codec.Object.member name (Json.Codec.some t) map ~dec_absent 735 - ~enc_omit 736 - ]} *) 737 - 738 - (** {1:cases Case objects} 739 - 740 - Read the {{!page-cookbook.cases}cookbook} on case objects. *) 741 - 742 - (** Case objects. *) 743 - module Case : sig 744 - (** {1:maps Maps} *) 745 - 746 - type 'a codec := 'a codec 747 - 748 - type ('cases, 'case, 'tag) map 749 - (** The type for mapping a case object. *) 750 - 751 - val map : 752 - ?dec:('case -> 'cases) -> 753 - 'tag -> 754 - 'case codec -> 755 - ('cases, 'case, 'tag) map 756 - (** [map ~dec v obj] defines the object map [obj] as being the case for 757 - the tag value [v] of the case member. [dec] indicates how to inject 758 - the object case into the type common to all cases. 759 - 760 - Raises [Invalid_argument] if [obj] is not a direct result of 761 - {!finish}, that is if [obj] does not describe an object. *) 762 - 763 - val map_tag : ('cases, 'case, 'tag) map -> 'tag 764 - (** [map_tag m] is [m]'s tag. *) 765 - 766 - (** {1:cases Cases} *) 767 - 768 - type ('cases, 'tag) t 769 - (** The type for a case of the type ['cases]. *) 770 - 771 - val make : ('cases, 'case, 'tag) map -> ('cases, 'tag) t 772 - (** [make map] is [map] as a case. *) 773 - 774 - val tag : ('cases, 'tag) t -> 'tag 775 - (** [tag c] is the tag of [c]. *) 776 - 777 - (** {1:case Case values} *) 778 - 779 - type ('cases, 'tag) value 780 - (** The type for case values. *) 781 - 782 - val value : ('cases, 'case, 'tag) map -> 'case -> ('cases, 'tag) value 783 - (** [value map v] is a case value [v] described by [map]. *) 784 - end 785 - 786 - val case_member : 787 - ?doc:string -> 788 - ?tag_compare:('tag -> 'tag -> int) -> 789 - ?tag_to_string:('tag -> string) -> 790 - ?dec_absent:'tag -> 791 - ?enc:('o -> 'cases) -> 792 - ?enc_omit:('tag -> bool) -> 793 - ?enc_case:('cases -> ('cases, 'tag) Case.value) -> 794 - string -> 795 - 'tag codec -> 796 - ('cases, 'tag) Case.t list -> 797 - ('o, 'cases -> 'a) map -> 798 - ('o, 'a) map 799 - (** [case_member name t cases map] is mostly like {!val-member} except the 800 - member [name] selects an object representation according to the member 801 - value of type [t]. *) 802 - 803 - (** {1:unknown_members Unknown members} 804 - 805 - Read the {{!page-cookbook.unknown_members}cookbook}. *) 806 - 807 - (** Uniform members. *) 808 - module Members : sig 809 - (** {1:maps Maps} *) 810 - 811 - type 'a codec := 'a codec 812 - 813 - type ('mems, 'a) enc = { 814 - enc : 815 - 'acc. 816 - (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc; 817 - } 818 - (** The type for specifying unknown members encoding function. *) 819 - 820 - type ('mems, 'a, 'builder) map 821 - (** The type for mapping members of uniform type ['a] to values of type 822 - ['mems] using a builder of type ['builder]. *) 823 - 824 - val map : 825 - ?kind:string -> 826 - ?doc:string -> 827 - ?dec_empty:(unit -> 'builder) -> 828 - ?dec_add:(Meta.t -> string -> 'a -> 'builder -> 'builder) -> 829 - ?dec_finish:(Meta.t -> 'builder -> 'mems) -> 830 - ?enc:('mems, 'a) enc -> 831 - 'a codec -> 832 - ('mems, 'a, 'builder) map 833 - (** [map type'] maps unknown members of uniform type ['a] to values of 834 - type ['mems] built with type ['builder]. *) 835 - 836 - val string_map : 837 - ?kind:string -> 838 - ?doc:string -> 839 - 'a codec -> 840 - ('a Stdlib.Map.Make(String).t, 'a, 'a Stdlib.Map.Make(String).t) map 841 - (** [string_map t] collects unknown member by name and types their values 842 - with [t]. *) 843 - end 844 - 845 - val skip_unknown : ('o, 'dec) map -> ('o, 'dec) map 846 - (** [skip_unknown map] makes [map] skip unknown members. *) 847 - 848 - val error_unknown : ('o, 'dec) map -> ('o, 'dec) map 849 - (** [error_unknown map] makes [map] error on unknown members. *) 850 - 851 - val keep_unknown : 852 - ?enc:('o -> 'mems) -> 853 - ('mems, _, _) Members.map -> 854 - ('o, 'mems -> 'a) map -> 855 - ('o, 'a) map 856 - (** [keep_unknown mems map] makes [map] keep unknown member with [mems]. *) 857 - 858 - (** {1:types JSON types} *) 859 - 860 - val as_string_map : 861 - ?kind:string -> 862 - ?doc:string -> 863 - 'a codec -> 864 - 'a Stdlib.Map.Make(String).t codec 865 - (** [as_string_map t] maps object to key-value maps of type [t]. *) 866 - 867 - val zero : unit codec 868 - (** [zero] ignores JSON objects on decoding and encodes an empty object. *) 869 - end 870 - 871 - (** {1:any Any value} 872 - 873 - Per {{:https://www.rfc-editor.org/rfc/rfc8259#section-3}RFC 8259 § 3}, a 874 - JSON {e value} is one of [null], [true]/[false], a number, a string, an 875 - array, or an object. *) 876 - 877 - val any : 878 - ?kind:string -> 879 - ?doc:string -> 880 - ?dec_null:'a t -> 881 - ?dec_bool:'a t -> 882 - ?dec_number:'a t -> 883 - ?dec_string:'a t -> 884 - ?dec_array:'a t -> 885 - ?dec_object:'a t -> 886 - ?enc:('a -> 'a t) -> 887 - unit -> 888 - 'a t 889 - (** [any ()] maps subsets of JSON values of different 890 - {{:https://www.rfc-editor.org/rfc/rfc8259#section-3}sorts} to values of 891 - type ['a]. *) 892 - 893 - (** {1:maps Maps & recursion} *) 894 - 895 - val map : 896 - ?kind:string -> 897 - ?doc:string -> 898 - ?dec:('a -> 'b) -> 899 - ?enc:('b -> 'a) -> 900 - 'a t -> 901 - 'b t 902 - (** [map t] changes the type of [t] from ['a] to ['b]. For mapping base types 903 - use {!Base.map}. *) 904 - 905 - val iter : 906 - ?kind:string -> 907 - ?doc:string -> 908 - ?dec:('a -> unit) -> 909 - ?enc:('a -> unit) -> 910 - 'a t -> 911 - 'a t 912 - (** [iter ?enc dec t] applies [dec] on decoding and [enc] on encoding but 913 - otherwise behaves like [t] does. *) 914 - 915 - val fix : 'a t Lazy.t -> 'a t 916 - (** [fix] maps recursive JSON values. *) 917 - 918 - (** {1:ignoring Ignoring} *) 919 - 920 - val ignore : unit t 921 - (** [ignore] lossily maps all JSON values to [()] on decoding and errors on 922 - encoding. *) 923 - 924 - val zero : unit t 925 - (** [zero] lossily maps all JSON values to [()] on decoding and encodes JSON 926 - nulls. *) 927 - 928 - val todo : ?kind:string -> ?doc:string -> ?dec_stub:'a -> unit -> 'a t 929 - (** [todo ?dec_stub ()] maps all JSON values to [dec_stub] if specified 930 - (errors otherwise) and errors on encoding. *) 931 - 932 - (** {1:generic_ast Generic AST codecs} 933 - 934 - Codecs that preserve the generic {!value} AST. *) 935 - 936 - module Value : sig 937 - val t : value t 938 - (** [t] maps any JSON value to its generic representation. Use {!val-any} 939 - with [dec_*] arguments to restrict to a subset of sorts. *) 940 - 941 - val null : value t 942 - (** [null] decodes JSON nulls to {!Null} and encodes {!Null} values. *) 943 - 944 - val bool : value t 945 - (** [bool] decodes JSON booleans to {!Bool} and encodes {!Bool} values. *) 946 - 947 - val number : value t 948 - (** [number] decodes JSON numbers to {!Number} and encodes {!Number} values. 949 - *) 950 - 951 - val string : value t 952 - (** [string] decodes JSON strings to {!String} and encodes {!String} values. 953 - *) 954 - 955 - val array : value t 956 - (** [array] decodes JSON arrays to {!Array} and encodes {!Array} values. *) 957 - 958 - val object' : value t 959 - (** [object'] decodes JSON objects to {!Object} and encodes {!Object} 960 - values. *) 961 - 962 - val mems : (value, value, member list) Object.Members.map 963 - (** [mems] is a {!Object.Members.map} for the generic {!member list} type. 964 - *) 965 - end 966 - 967 - (** {1:low Low-level representation} 968 - 969 - The following re-exports the low-level codec GADT that backs {!t}. This 970 - representation may change even between minor versions of the library. *) 971 - 972 - module String_map : module type of Map.Make (String) 973 - (** A [Map.Make(String)] instance used by the low-level representation. *) 974 - 975 - (** The type for decoding functions. *) 976 - type ('ret, 'f) dec_fun = ('ret, 'f) Codec.dec_fun = 977 - | Dec_fun : 'f -> ('ret, 'f) dec_fun 978 - | Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun 979 - (** *) 980 - 981 - type ('a, 'b) base_map = ('a, 'b) Codec.base_map = { 982 - kind : string; 983 - doc : string; 984 - dec : Meta.t -> 'a -> 'b; 985 - enc : 'b -> 'a; 986 - enc_meta : 'b -> Meta.t; 987 - } 988 - (** The type for mapping JSON base values. *) 989 - 990 - (** {1:types_group Codec record field types} 991 - 992 - The low-level record types form a mutually-recursive group in 993 - {!Codec.Codec}; they are re-exported here as equi-recursive aliases so 994 - constructors and fields are accessible by consumers. *) 995 - 996 - type ('array, 'elt, 'builder) array_map = 997 - ('array, 'elt, 'builder) Codec.array_map = { 998 - kind : string; 999 - doc : string; 1000 - elt : 'elt t; 1001 - dec_empty : unit -> 'builder; 1002 - dec_skip : int -> 'builder -> bool; 1003 - dec_add : int -> 'elt -> 'builder -> 'builder; 1004 - dec_finish : Meta.t -> int -> 'builder -> 'array; 1005 - enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; 1006 - enc_meta : 'array -> Meta.t; 1007 - } 1008 - 1009 - and ('o, 'dec) object_map = ('o, 'dec) Codec.object_map = { 1010 - kind : string; 1011 - doc : string; 1012 - dec : ('o, 'dec) dec_fun; 1013 - mem_decs : mem_dec Codec.String_map.t; 1014 - mem_encs : 'o mem_enc list; 1015 - enc_meta : 'o -> Meta.t; 1016 - shape : 'o object_shape; 1017 - } 1018 - 1019 - and mem_dec = Codec.mem_dec = Mem_dec : ('o, 'a) mem_map -> mem_dec 1020 - and 'o mem_enc = 'o Codec.mem_enc = Mem_enc : ('o, 'a) mem_map -> 'o mem_enc 1021 - 1022 - and ('o, 'a) mem_map = ('o, 'a) Codec.mem_map = { 1023 - name : string; 1024 - doc : string; 1025 - type' : 'a t; 1026 - id : 'a Type.Id.t; 1027 - dec_absent : 'a option; 1028 - enc : 'o -> 'a; 1029 - enc_omit : 'a -> bool; 1030 - } 1031 - 1032 - and 'o object_shape = 'o Codec.object_shape = 1033 - | Object_basic : ('o, 'mems, 'builder) unknown_mems -> 'o object_shape 1034 - | Object_cases : 1035 - ('o, 'mems, 'builder) unknown_mems option 1036 - * ('o, 'cases, 'tag) object_cases 1037 - -> 'o object_shape 1038 - 1039 - and ('o, 'mems, 'builder) unknown_mems = 1040 - ('o, 'mems, 'builder) Codec.unknown_mems = 1041 - | Unknown_skip : ('o, unit, unit) unknown_mems 1042 - | Unknown_error : ('o, unit, unit) unknown_mems 1043 - | Unknown_keep : 1044 - ('mems, 'a, 'builder) mems_map * ('o -> 'mems) 1045 - -> ('o, 'mems, 'builder) unknown_mems 1046 - 1047 - and ('mems, 'a, 'builder) mems_map = ('mems, 'a, 'builder) Codec.mems_map = { 1048 - kind : string; 1049 - doc : string; 1050 - mems_type : 'a t; 1051 - id : 'mems Type.Id.t; 1052 - dec_empty : unit -> 'builder; 1053 - dec_add : Meta.t -> string -> 'a -> 'builder -> 'builder; 1054 - dec_finish : Meta.t -> 'builder -> 'mems; 1055 - enc : 1056 - 'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc; 1057 - } 1058 - 1059 - and ('o, 'cases, 'tag) object_cases = 1060 - ('o, 'cases, 'tag) Codec.object_cases = { 1061 - tag : ('tag, 'tag) mem_map; 1062 - tag_compare : 'tag -> 'tag -> int; 1063 - tag_to_string : ('tag -> string) option; 1064 - id : 'cases Type.Id.t; 1065 - cases : ('cases, 'tag) case list; 1066 - enc : 'o -> 'cases; 1067 - enc_case : 'cases -> ('cases, 'tag) case_value; 1068 - } 1069 - 1070 - and ('cases, 'case, 'tag) case_map = ('cases, 'case, 'tag) Codec.case_map = { 1071 - tag : 'tag; 1072 - object_map : ('case, 'case) object_map; 1073 - dec : 'case -> 'cases; 1074 - } 1075 - 1076 - and ('cases, 'tag) case = ('cases, 'tag) Codec.case = 1077 - | Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case 1078 - (** The type for hiding the concrete type of a case. *) 1079 - 1080 - and ('cases, 'tag) case_value = ('cases, 'tag) Codec.case_value = 1081 - | Case_value : 1082 - ('cases, 'case, 'tag) case_map * 'case 1083 - -> ('cases, 'tag) case_value (** The type for case values. *) 1084 - 1085 - and 'a any_map = 'a Codec.any_map = { 1086 - kind : string; 1087 - doc : string; 1088 - dec_null : 'a t option; 1089 - dec_bool : 'a t option; 1090 - dec_number : 'a t option; 1091 - dec_string : 'a t option; 1092 - dec_array : 'a t option; 1093 - dec_object : 'a t option; 1094 - enc : 'a -> 'a t; 1095 - } 1096 - 1097 - and ('a, 'b) map = ('a, 'b) Codec.map = { 1098 - kind : string; 1099 - doc : string; 1100 - dom : 'a t; 1101 - dec : 'a -> 'b; 1102 - enc : 'b -> 'a; 1103 - } 1104 - 1105 - val array_kinded_sort : ('a, 'elt, 'builder) array_map -> string 1106 - (** [array_kinded_sort map] is like {!kinded_sort} but acts directly on the 1107 - array [map]. *) 1108 - 1109 - val object_kinded_sort : ('o, 'dec) object_map -> string 1110 - (** [object_kinded_sort map] is like {!kinded_sort} but acts directly on the 1111 - object [map]. *) 1112 - 1113 - val pp_kind : string Fmt.t 1114 - (** [pp_kind] formats kinds. *) 1115 - 1116 - val error_push_array : 1117 - Meta.t -> ('array, 'elt, 'builder) array_map -> int node -> Error.t -> 'a 1118 - (** [error_push_array] contextualises an error within an array. *) 1119 - 1120 - val error_push_object : 1121 - Meta.t -> ('o, 'dec) object_map -> string node -> Error.t -> 'a 1122 - (** [error_push_object] contextualises an error within an object. *) 1123 - 1124 - val type_error : Meta.t -> 'a t -> fnd:Sort.t -> 'b 1125 - (** [type_error meta ~exp ~fnd] errors. *) 1126 - 1127 - val missing_mems_error : 1128 - Meta.t -> 1129 - ('o, 'o) object_map -> 1130 - exp:mem_dec String_map.t -> 1131 - fnd:string list -> 1132 - 'a 1133 - (** [missing_mems_error] errors when expected members are missing. *) 1134 - 1135 - val unexpected_mems_error : 1136 - Meta.t -> ('o, 'o) object_map -> fnd:(string * Meta.t) list -> 'a 1137 - (** [unexpected_mems_error] errors on unexpected members. *) 1138 - 1139 - val unexpected_case_tag_error : 1140 - Meta.t -> ('o, 'o) object_map -> ('o, 'd, 'tag) object_cases -> 'tag -> 'a 1141 - (** [unexpected_case_tag_error] errors when a case tag has no matching case. 1142 - *) 1143 - 1144 - val object_meta_arg : Meta.t Type.Id.t 1145 - (** [object_meta_arg] is used to thread an object's {!Meta.t} through decode. 1146 - *) 1147 - 1148 - (** Heterogeneous dictionaries. *) 1149 - module Dict : sig 1150 - type binding = Codec.Dict.binding = B : 'a Type.Id.t * 'a -> binding 1151 - type t = Codec.Dict.t 1152 - 1153 - val empty : t 1154 - (** [empty] is the empty dictionary. *) 1155 - 1156 - val mem : 'a Type.Id.t -> t -> bool 1157 - (** [mem k d] is [true] iff [d] has a binding for [k]. *) 1158 - 1159 - val add : 'a Type.Id.t -> 'a -> t -> t 1160 - (** [add k v d] is [d] with [k] bound to [v]. *) 1161 - 1162 - val remove : 'a Type.Id.t -> t -> t 1163 - (** [remove k d] is [d] with any binding for [k] removed. *) 1164 - 1165 - val find : 'a Type.Id.t -> t -> 'a option 1166 - (** [find k d] is the value bound to [k] in [d] or [None]. *) 1167 - end 1168 - 1169 - val apply_dict : ('ret, 'f) dec_fun -> Dict.t -> 'f 1170 - (** [apply_dict dec dict] applies [dict] to [f]. *) 1171 - 1172 - type unknown_mems_option = Codec.unknown_mems_option = 1173 - | Unknown_mems : 1174 - ('o, 'mems, 'builder) unknown_mems option 1175 - -> unknown_mems_option 1176 - 1177 - val override_unknown_mems : 1178 - by:unknown_mems_option -> 1179 - unknown_mems_option -> 1180 - Dict.t -> 1181 - unknown_mems_option * Dict.t 1182 - (** [override_unknown_mems] performs unknown member overriding. *) 1183 - 1184 - val finish_object_decode : 1185 - ('o, 'o) object_map -> 1186 - Meta.t -> 1187 - ('p, 'mems, 'builder) unknown_mems -> 1188 - 'builder -> 1189 - mem_dec String_map.t -> 1190 - Dict.t -> 1191 - Dict.t 1192 - (** [finish_object_decode] finishes an object map decode. *) 1193 - 1194 - val pp_code : string Fmt.t 1195 - (** [pp_code] formats strings like code (in bold). *) 1196 - 1197 - (** {1:queries Queries and updates} 1198 - 1199 - Queries are lossy or aggregating decodes. Updates yield codecs that decode 1200 - to generic {!value} values but transform the data along the way. They 1201 - allow to process JSON data without having to fully model it. *) 1202 - 1203 - val const : 'a t -> 'a -> 'a t 1204 - (** [const t v] maps any JSON value to [v] on decodes and unconditionally 1205 - encodes [v] with [t]. *) 1206 - 1207 - val recode : dec:'a t -> ('a -> 'b) -> enc:'b t -> 'b t 1208 - (** [recode ~dec f ~enc] maps on decodes like [dec] does followed by [f] and 1209 - on encodes uses [enc]. *) 1210 - 1211 - val update : 'a t -> value t 1212 - (** [update t] decodes any JSON with [t] and directly encodes it back with [t] 1213 - to yield the decode result. *) 1214 - 1215 - (** {2:array_queries Arrays} *) 1216 - 1217 - val nth : ?absent:'a -> int -> 'a t -> 'a t 1218 - (** [nth n t] decodes the [n]th index of a JSON array with [t]. *) 1219 - 1220 - val set_nth : 1221 - ?stub:value -> ?allow_absent:bool -> 'a t -> int -> 'a -> value t 1222 - (** [set_nth t n v] on decodes sets the [n]th value to [v]. *) 1223 - 1224 - val update_nth : ?stub:value -> ?absent:'a -> int -> 'a t -> value t 1225 - (** [update_nth n t] recodes the [n]th value of a JSON array with [t]. *) 1226 - 1227 - val delete_nth : ?allow_absent:bool -> int -> value t 1228 - (** [delete_nth n] drops the [n]th index of a JSON array. *) 1229 - 1230 - val filter_map_array : 'a t -> 'b t -> (int -> 'a -> 'b option) -> value t 1231 - (** [filter_map_array a b f] maps the [a] elements with [f] to [b] elements or 1232 - deletes them on [None]. *) 1233 - 1234 - val fold_array : 'a t -> (int -> 'a -> 'b -> 'b) -> 'b -> 'b t 1235 - (** [fold_array t f acc] folds [f] over the [t] elements of a JSON array. *) 1236 - 1237 - (** {2:object_queries Objects} *) 1238 - 1239 - val mem : ?absent:'a -> string -> 'a t -> 'a t 1240 - (** [mem name t] decodes the member named [name] of a JSON object with [t]. *) 1241 - 1242 - val set_mem : ?allow_absent:bool -> 'a t -> string -> 'a -> value t 1243 - (** [set_mem t name v] sets the member value of [name] to an encoding of [v]. 1244 - *) 1245 - 1246 - val update_mem : ?absent:'a -> string -> 'a t -> value t 1247 - (** [update_mem name t] recodes the member value of [name]. *) 1248 - 1249 - val delete_mem : ?allow_absent:bool -> string -> value t 1250 - (** [delete_mem name] deletes the member named [name]. *) 1251 - 1252 - val filter_map_object : 1253 - 'a t -> 'b t -> (Meta.t -> string -> 'a -> (name * 'b) option) -> value t 1254 - (** [filter_map_object a b f] maps the [a] members with [f] to [(n, b)] 1255 - members or deletes them on [None]. *) 1256 - 1257 - val fold_object : 'a t -> (Meta.t -> string -> 'a -> 'b -> 'b) -> 'b -> 'b t 1258 - (** [fold_object t f acc] folds [f] over the [t] members of a JSON object. *) 1259 - 1260 - (** {2:index_queries Indices} *) 1261 - 1262 - val index : ?absent:'a -> Path.step -> 'a t -> 'a t 1263 - (** [index] uses {!val-nth} or {!val-mem} on the given index. *) 1264 - 1265 - val set_index : ?allow_absent:bool -> 'a t -> Path.step -> 'a -> value t 1266 - (** [set_index] uses {!set_nth} or {!set_mem} on the given index. *) 1267 - 1268 - val update_index : ?stub:value -> ?absent:'a -> Path.step -> 'a t -> value t 1269 - (** [update_index] uses {!update_nth} or {!update_mem}. *) 1270 - 1271 - val delete_index : ?allow_absent:bool -> Path.step -> value t 1272 - (** [delete_index] uses {!delete_nth} or {!delete_mem}. *) 1273 - 1274 - (** {2:path_queries Paths} *) 1275 - 1276 - val path : ?absent:'a -> Path.t -> 'a t -> 'a t 1277 - (** [path p t] decodes with [t] on the last index of [p]. *) 1278 - 1279 - val set_path : 1280 - ?stub:value -> ?allow_absent:bool -> 'a t -> Path.t -> 'a -> value t 1281 - (** [set_path t p v] sets the last index of [p]. *) 1282 - 1283 - val update_path : ?stub:value -> ?absent:'a -> Path.t -> 'a t -> value t 1284 - (** [update_path p t] updates the last index of [p] with [t]. *) 1285 - 1286 - val delete_path : ?allow_absent:bool -> Path.t -> value t 1287 - (** [delete_path p] deletes the last index of [p]. *) 1288 - end 1289 - 1290 105 (** {1:tape Tape} *) 1291 106 1292 107 module Tape = Tape ··· 1334 149 val of_reader : 1335 150 ?layout:bool -> 1336 151 ?locs:bool -> 1337 - ?file:Loc.fpath -> 152 + ?file:fpath -> 1338 153 'a codec -> 1339 154 Bytes.Reader.t -> 1340 155 ('a, Error.t) result ··· 1343 158 Defaults to [false]. 1344 159 - If [locs] is [true] locations are preserved in {!Meta.t} values and error 1345 160 messages are precisely located. Defaults to [false]. 1346 - - [file] is the file path from which [r] is assumed to read. Defaults to 1347 - {!Loc.file_none}. *) 161 + - [file] is the file path from which [r] is assumed to read. Defaults to the 162 + empty path. *) 1348 163 1349 164 val of_reader_exn : 1350 - ?layout:bool -> 1351 - ?locs:bool -> 1352 - ?file:Loc.fpath -> 1353 - 'a codec -> 1354 - Bytes.Reader.t -> 1355 - 'a 165 + ?layout:bool -> ?locs:bool -> ?file:fpath -> 'a codec -> Bytes.Reader.t -> 'a 1356 166 (** [of_reader_exn] is like {!val-of_reader} but raises {!Json.exception-Error}. 1357 167 *) 1358 168 1359 169 val of_string : 1360 170 ?layout:bool -> 1361 171 ?locs:bool -> 1362 - ?file:Loc.fpath -> 172 + ?file:fpath -> 1363 173 'a codec -> 1364 174 string -> 1365 175 ('a, Error.t) result 1366 176 (** [of_string] is like {!val-of_reader} but decodes directly from a string. *) 1367 177 1368 178 val of_string_exn : 1369 - ?layout:bool -> ?locs:bool -> ?file:Loc.fpath -> 'a codec -> string -> 'a 179 + ?layout:bool -> ?locs:bool -> ?file:fpath -> 'a codec -> string -> 'a 1370 180 (** [of_string_exn] is like {!val-of_string} but raises {!Json.exception-Error}. 1371 181 *) 1372 182 ··· 1443 253 *) 1444 254 1445 255 val of_string : 1446 - ?layout:bool -> 1447 - ?locs:bool -> 1448 - ?file:Loc.fpath -> 1449 - string -> 1450 - (t, Error.t) result 256 + ?layout:bool -> ?locs:bool -> ?file:fpath -> string -> (t, Error.t) result 1451 257 (** [of_string s] parses [s] to a generic JSON value. *) 1452 258 1453 - val of_string_exn : 1454 - ?layout:bool -> ?locs:bool -> ?file:Loc.fpath -> string -> t 259 + val of_string_exn : ?layout:bool -> ?locs:bool -> ?file:fpath -> string -> t 1455 260 (** [of_string_exn] is like {!val-of_string} but raises 1456 261 {!Json.exception-Error}. *) 1457 262 1458 263 val of_reader : 1459 264 ?layout:bool -> 1460 265 ?locs:bool -> 1461 - ?file:Loc.fpath -> 266 + ?file:fpath -> 1462 267 Bytesrw.Bytes.Reader.t -> 1463 268 (t, Error.t) result 1464 269 (** [of_reader r] parses [r] to a generic JSON value. *) 1465 270 1466 271 val of_reader_exn : 1467 - ?layout:bool -> ?locs:bool -> ?file:Loc.fpath -> Bytesrw.Bytes.Reader.t -> t 272 + ?layout:bool -> ?locs:bool -> ?file:fpath -> Bytesrw.Bytes.Reader.t -> t 1468 273 (** [of_reader_exn] is like {!val-of_reader} but raises 1469 274 {!Json.exception-Error}. *) 1470 275

+1 -1

test/codecs/json_rpc.ml

··· 44 44 | j -> 45 45 let meta = Json.Meta.none in 46 46 let fnd = Json.Sort.to_string (Json.Value.sort j) in 47 - Json.Error.expected meta "object or array" ~fnd 47 + Json.Error.fail_expected meta "object or array" ~fnd 48 48 in 49 49 let kind = "JSON-RPC params" in 50 50 Json.any ~kind ~dec_array:Json.json ~dec_object:Json.json ~enc ()

+4 -3

test/test_error.ml

··· 4 4 5 5 let test_sort_mismatch () = 6 6 match 7 - Json.Error.sort Json.Meta.none ~exp:Json.Sort.Number ~fnd:Json.Sort.String 7 + Json.Error.fail_sort Json.Meta.none ~exp:Json.Sort.Number 8 + ~fnd:Json.Sort.String 8 9 with 9 10 | exception Loc.Error _ -> () 10 11 | _ -> Alcotest.fail "Expected Loc.Error to be raised" 11 12 12 13 let test_kinded_sort_mismatch () = 13 14 match 14 - Json.Error.kinded_sort Json.Meta.none ~exp:"port" ~fnd:Json.Sort.Array 15 + Json.Error.fail_kinded_sort Json.Meta.none ~exp:"port" ~fnd:Json.Sort.Array 15 16 with 16 17 | exception Loc.Error _ -> () 17 18 | _ -> Alcotest.fail "Expected Loc.Error to be raised" ··· 26 27 loop 0 27 28 28 29 let test_expected_message () = 29 - match Json.Error.expected Json.Meta.none "integer" ~fnd:"string" with 30 + match Json.Error.fail_expected Json.Meta.none "integer" ~fnd:"string" with 30 31 | exception Loc.Error e -> 31 32 let s = Loc.Error.to_string e in 32 33 Alcotest.(check bool)

Configure Feed

Configure Feed