ocaml-json: extract Codec and Error modules from json.ml

+19 -14

lib/brr/json_brr.ml

··· 3 3 SPDX-License-Identifier: ISC 4 4 ---------------------------------------------------------------------------*) 5 5 6 - open Json.Repr 6 + open Json.Codec 7 7 8 8 (* Converting between Json.Error.t and Jv.Error.t values *) 9 9 ··· 67 67 (* Decoding *) 68 68 69 69 let error_push_array map i e = 70 - Json.Repr.error_push_array Json.Meta.none map (i, Json.Meta.none) e 70 + Json.Codec.error_push_array Json.Meta.none map (i, Json.Meta.none) e 71 71 72 72 let error_push_object map n e = 73 - Json.Repr.error_push_object Json.Meta.none map (n, Json.Meta.none) e 73 + Json.Codec.error_push_object Json.Meta.none map (n, Json.Meta.none) e 74 74 75 - let type_error t ~fnd = Json.Repr.type_error Json.Meta.none t ~fnd 75 + let type_error t ~fnd = Json.Codec.type_error Json.Meta.none t ~fnd 76 76 77 77 let find_all_unexpected ~mem_decs mems = 78 78 let unexpected (n, _jname) = ··· 82 82 in 83 83 List.filter_map unexpected mems 84 84 85 - let rec decode : type a. a Json.Repr.t -> Jv.t -> a = 85 + let rec decode : type a. a Json.Codec.t -> Jv.t -> a = 86 86 fun t jv -> 87 87 match t with 88 88 | Null map -> ( ··· 151 151 match map.shape with 152 152 | Object_cases (umems', cases) -> 153 153 let umems' = Unknown_mems umems' in 154 - let umems, dict = Json.Repr.override_unknown_mems ~by:umems umems' dict in 154 + let umems, dict = 155 + Json.Codec.override_unknown_mems ~by:umems umems' dict 156 + in 155 157 decode_object_cases map umems cases mem_decs dict names jv 156 158 | Object_basic umems' -> ( 157 159 let umems' = Unknown_mems (Some umems') in 158 - let umems, dict = Json.Repr.override_unknown_mems ~by:umems umems' dict in 160 + let umems, dict = 161 + Json.Codec.override_unknown_mems ~by:umems umems' dict 162 + in 159 163 match umems with 160 164 | Unknown_mems (Some Unknown_skip | None) -> 161 165 let u = Unknown_skip in ··· 182 186 fun map umems umap mem_decs dict names jv -> 183 187 match names with 184 188 | [] -> 185 - Json.Repr.finish_object_decode map Json.Meta.none umems umap mem_decs dict 189 + Json.Codec.finish_object_decode map Json.Meta.none umems umap mem_decs 190 + dict 186 191 | (n, jname) :: names -> ( 187 192 match String_map.find_opt n mem_decs with 188 193 | Some (Mem_dec m) -> ··· 200 205 let fnd = 201 206 (n, Json.Meta.none) :: find_all_unexpected ~mem_decs names 202 207 in 203 - Json.Repr.unexpected_mems_error Json.Meta.none map ~fnd 208 + Json.Codec.unexpected_mems_error Json.Meta.none map ~fnd 204 209 | Unknown_keep (mmap, _) -> 205 210 let umap = 206 211 let v = ··· 224 229 let decode_case_tag tag = 225 230 let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in 226 231 match List.find_opt eq_tag cases.cases with 227 - | None -> Json.Repr.unexpected_case_tag_error Json.Meta.none map cases tag 232 + | None -> Json.Codec.unexpected_case_tag_error Json.Meta.none map cases tag 228 233 | Some (Case case) -> 229 234 let mems = String_map.remove cases.tag.name names in 230 235 let dict = ··· 242 247 | None -> 243 248 let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in 244 249 let fnd = jv_mem_name_list jv in 245 - Json.Repr.missing_mems_error Json.Meta.none map ~exp ~fnd) 250 + Json.Codec.missing_mems_error Json.Meta.none map ~exp ~fnd) 246 251 247 252 and decode_any : type a. a t -> a any_map -> Jv.t -> a = 248 253 fun t map jv -> ··· 257 262 | Array as s -> case t map.dec_array s jv 258 263 | Object as s -> case t map.dec_object s jv 259 264 260 - let decode t jv = decode (Json.Repr.of_t t) jv 265 + let decode t jv = decode t jv 261 266 let decode_jv' t jv = try Ok (decode t jv) with Json.Error e -> Error e 262 267 let decode_jv t jv = Result.map_error error_to_jv_error (decode_jv' t jv) 263 268 ··· 294 299 | Ignore -> Json.Error.failf Json.Meta.none "Cannot encode Ignore value" 295 300 296 301 and encode_object : type o. 297 - (o, o) Json.Repr.object_map -> do_unknown:bool -> o -> Jv.t -> Jv.t = 302 + (o, o) Json.Codec.object_map -> do_unknown:bool -> o -> Jv.t -> Jv.t = 298 303 fun map ~do_unknown o jv -> 299 304 let encode_mem map o jv (Mem_enc mmap) = 300 305 try ··· 339 344 in 340 345 umap.enc (encode_mem map) mems jv 341 346 342 - let encode t v = encode (Json.Repr.of_t t) v 347 + let encode t v = encode t v 343 348 let encode_jv' t v = try Ok (encode t v) with Json.Error e -> Error e 344 349 let encode_jv t v = Result.map_error error_to_jv_error (encode_jv' t v) 345 350

+50 -46

lib/bytesrw/json_bytesrw.ml

··· 4 4 ---------------------------------------------------------------------------*) 5 5 6 6 open Bytesrw 7 - open Json.Repr 7 + open Json.Codec 8 8 9 9 (* XXX add these things to Stdlib.Uchar *) 10 10 ··· 40 40 41 41 let sot = 0x1A0000 (* start of text U+10FFFF + 1 *) 42 42 let eot = 0x1A0001 (* end of text U+10FFFF + 2 *) 43 - let pp_code = Json.Repr.pp_code 43 + let pp_code = Json.Codec.pp_code 44 44 45 45 let pp_quchar ppf u = 46 46 pp_code ppf ··· 200 200 | _ -> err_not_json_value d 201 201 202 202 let type_error d t = 203 - Json.Repr.type_error (error_meta d) t ~fnd:(current_json_sort d) 203 + Json.Codec.type_error (error_meta d) t ~fnd:(current_json_sort d) 204 204 205 205 (* Errors for constants *) 206 206 ··· 270 270 err_here d "Expected %a after %a but found %a" pp_code ":" pp_code 271 271 "member name" pp_quchar d.u 272 272 273 - let err_unclosed_object d (map : ('o, 'o) Json.Repr.object_map) = 274 - err_here d "Unclosed %a" Json.Repr.pp_kind 275 - (Json.Repr.object_map_kinded_sort map) 273 + let err_unclosed_object d (map : ('o, 'o) Json.Codec.object_map) = 274 + err_here d "Unclosed %a" Json.Codec.pp_kind 275 + (Json.Codec.object_map_kinded_sort map) 276 276 277 277 (* Decode next character in d.u *) 278 278 ··· 807 807 let first_byte = get_last_byte d in 808 808 let first_line_num = d.line and first_line_byte = d.line_start in 809 809 try 810 - if map.dec_skip !i !b then decode d (of_t Json.ignore) 810 + if map.dec_skip !i !b then decode d Json.ignore 811 811 else b := map.dec_add !i (decode d map.elt) !b 812 812 with Json.Error e -> 813 813 let imeta = 814 814 error_meta_to_current ~first_byte ~first_line_num 815 815 ~first_line_byte d 816 816 in 817 - Json.Repr.error_push_array (error_meta d) map (!i, imeta) e 817 + Json.Codec.error_push_array (error_meta d) map (!i, imeta) e 818 818 end; 819 819 incr i; 820 820 match ··· 858 858 with 859 859 | Json.Error (ctx, meta, k) when Json.Error.Context.is_empty ctx -> 860 860 let meta = 861 - (* This is for when Json.Repr.finish_object_decode raises. *) 861 + (* This is for when Json.Codec.finish_object_decode raises. *) 862 862 if Json.Textloc.is_none (Json.Meta.textloc meta) then 863 863 error_meta_to_current d ~first_byte ~first_line_num ~first_line_byte 864 864 else meta ··· 876 876 ws_pop d 877 877 in 878 878 let meta = meta_make d ~ws_before ~ws_after textloc in 879 - let dict = Dict.add Json.Repr.object_meta_arg meta dict in 880 - Json.Repr.apply_dict map.dec dict 879 + let dict = Dict.add Json.Codec.object_meta_arg meta dict in 880 + Json.Codec.apply_dict map.dec dict 881 881 882 882 and decode_object_delayed : type o. 883 883 decoder -> ··· 896 896 | Some (Mem_dec m) -> 897 897 let dict = 898 898 try 899 - let t = Json.Repr.unsafe_to_t m.type' in 899 + let t = m.type' in 900 900 let v = 901 901 match Json.Value.decode' t v with 902 902 | Ok v -> v ··· 904 904 in 905 905 Dict.add m.id v dict 906 906 with Json.Error e -> 907 - Json.Repr.error_push_object (error_meta d) map nm e 907 + Json.Codec.error_push_object (error_meta d) map nm e 908 908 in 909 909 let mem_miss = String_map.remove name mem_miss in 910 910 loop d map mem_miss mem_decs rem_delay dict delay) ··· 927 927 match map.shape with 928 928 | Object_cases (umems', cases) -> 929 929 let umems' = Unknown_mems umems' in 930 - let umems, dict = Json.Repr.override_unknown_mems ~by:umems umems' dict in 930 + let umems, dict = 931 + Json.Codec.override_unknown_mems ~by:umems umems' dict 932 + in 931 933 decode_object_case d map umems cases mem_miss mem_decs delay dict 932 934 | Object_basic umems' -> ( 933 935 let mem_miss, delay, dict = 934 936 decode_object_delayed d map mem_miss mem_decs delay dict 935 937 in 936 938 let umems' = Unknown_mems (Some umems') in 937 - let umems, dict = Json.Repr.override_unknown_mems ~by:umems umems' dict in 939 + let umems, dict = 940 + Json.Codec.override_unknown_mems ~by:umems umems' dict 941 + in 938 942 match umems with 939 943 | Unknown_mems (Some Unknown_skip | None) -> 940 944 decode_object_basic d map Unknown_skip () mem_miss mem_decs dict ··· 943 947 decode_object_basic d map u () mem_miss mem_decs dict 944 948 else 945 949 let fnd = List.map fst delay in 946 - Json.Repr.unexpected_mems_error (error_meta d) map ~fnd 950 + Json.Codec.unexpected_mems_error (error_meta d) map ~fnd 947 951 | Unknown_mems (Some (Unknown_keep (umap, _) as u)) -> 948 952 let add_delay umems (((n, meta) as nm), v) = 949 953 try 950 - let t = Json.Repr.unsafe_to_t umap.mems_type in 954 + let t = umap.mems_type in 951 955 let v = 952 956 match Json.Value.decode' t v with 953 957 | Ok v -> v ··· 955 959 in 956 960 umap.dec_add meta n v umems 957 961 with Json.Error e -> 958 - Json.Repr.error_push_object (error_meta d) map nm e 962 + Json.Codec.error_push_object (error_meta d) map nm e 959 963 in 960 964 let umems = List.fold_left add_delay (umap.dec_empty ()) delay in 961 965 decode_object_basic d map u umems mem_miss mem_decs dict) ··· 976 980 d.meta_none 977 981 (* we add a correct one in decode_object *) 978 982 in 979 - Json.Repr.finish_object_decode map meta u umap mem_miss dict 983 + Json.Codec.finish_object_decode map meta u umap mem_miss dict 980 984 | 0x0022 -> 981 985 let meta = read_json_name d in 982 986 (* Fast path: byte-compare the token buffer against [mem_decs] ··· 990 994 let dict = 991 995 try Dict.add mem.id (decode d mem.type') dict 992 996 with Json.Error e -> 993 - Json.Repr.error_push_object (error_meta d) map (name, meta) e 997 + Json.Codec.error_push_object (error_meta d) map (name, meta) e 994 998 in 995 999 read_json_mem_sep d; 996 1000 decode_object_basic d map u umap mem_miss mem_decs dict ··· 1000 1004 (* The name is never read, so we don't need to allocate it. *) 1001 1005 token_clear d; 1002 1006 let () = 1003 - try decode d (Json.Repr.of_t Json.ignore) 1007 + try decode d Json.ignore 1004 1008 with Json.Error e -> 1005 - Json.Repr.error_push_object (error_meta d) map 1009 + Json.Codec.error_push_object (error_meta d) map 1006 1010 (token_pop d, meta) 1007 1011 e 1008 1012 in ··· 1011 1015 | Unknown_error -> 1012 1016 let name = token_pop d in 1013 1017 let fnd = [ (name, meta) ] in 1014 - Json.Repr.unexpected_mems_error (error_meta d) map ~fnd 1018 + Json.Codec.unexpected_mems_error (error_meta d) map ~fnd 1015 1019 | Unknown_keep (umap', _) -> 1016 1020 let name = token_pop d in 1017 1021 let umap = 1018 1022 try umap'.dec_add meta name (decode d umap'.mems_type) umap 1019 1023 with Json.Error e -> 1020 - Json.Repr.error_push_object (error_meta d) map (name, meta) e 1024 + Json.Codec.error_push_object (error_meta d) map (name, meta) e 1021 1025 in 1022 1026 read_json_mem_sep d; 1023 1027 decode_object_basic d map u umap mem_miss mem_decs dict) ··· 1040 1044 let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in 1041 1045 match List.find_opt eq_tag cases.cases with 1042 1046 | None -> ( 1043 - try Json.Repr.unexpected_case_tag_error (error_meta d) map cases tag 1047 + try Json.Codec.unexpected_case_tag_error (error_meta d) map cases tag 1044 1048 with Json.Error e -> 1045 - Json.Repr.error_push_object (error_meta d) map (cases.tag.name, nmeta) 1046 - e) 1049 + Json.Codec.error_push_object (error_meta d) map 1050 + (cases.tag.name, nmeta) e) 1047 1051 | Some (Case case) -> 1048 1052 if sep then read_json_mem_sep d; 1049 1053 let dict = ··· 1060 1064 | None -> 1061 1065 let fnd = List.map (fun ((n, _), _) -> n) delay in 1062 1066 let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in 1063 - Json.Repr.missing_mems_error (error_meta d) map ~exp ~fnd) 1067 + Json.Codec.missing_mems_error (error_meta d) map ~exp ~fnd) 1064 1068 | 0x0022 -> 1065 1069 let meta = read_json_name d in 1066 1070 let name = token_pop d in ··· 1068 1072 let tag = 1069 1073 try decode d cases.tag.type' 1070 1074 with Json.Error e -> 1071 - Json.Repr.error_push_object (error_meta d) map (name, meta) e 1075 + Json.Codec.error_push_object (error_meta d) map (name, meta) e 1072 1076 in 1073 1077 decode_case_tag ~sep:true map umems cases mem_miss mem_decs meta tag 1074 1078 delay ··· 1079 1083 let dict = 1080 1084 try Dict.add mem.id (decode d mem.type') dict 1081 1085 with Json.Error e -> 1082 - Json.Repr.error_push_object (error_meta d) map (name, meta) e 1086 + Json.Codec.error_push_object (error_meta d) map (name, meta) e 1083 1087 in 1084 1088 read_json_mem_sep d; 1085 1089 decode_object_case d map umems cases mem_miss mem_decs delay dict ··· 1087 1091 (* Because JSON can be out of order we don't know how to decode 1088 1092 this yet. Generic decode *) 1089 1093 let v = 1090 - try decode d (Json.Repr.of_t Json.json) 1094 + try decode d Json.json 1091 1095 with Json.Error e -> 1092 - Json.Repr.error_push_object (error_meta d) map (name, meta) e 1096 + Json.Codec.error_push_object (error_meta d) map (name, meta) e 1093 1097 in 1094 1098 let delay = ((name, meta), v) :: delay in 1095 1099 read_json_mem_sep d; ··· 1117 1121 let d = make_decoder ?layout ?locs ?file reader in 1118 1122 let v = 1119 1123 nextc d; 1120 - decode d (Json.Repr.of_t t) 1124 + decode d t 1121 1125 in 1122 1126 if d.u <> eot then err_exp_eot d else Ok v 1123 1127 with Json.Error e -> Error e ··· 1247 1251 loop 0 0 (len - 1); 1248 1252 write_char e '"' 1249 1253 1250 - let encode_null (map : ('a, 'b) Json.Repr.base_map) e v = 1254 + let encode_null (map : ('a, 'b) Json.Codec.base_map) e v = 1251 1255 let () = map.enc v in 1252 1256 match e.format with 1253 1257 | Json.Minify | Json.Indent -> write_json_null e ··· 1257 1261 write_json_null e; 1258 1262 write_ws_after e meta 1259 1263 1260 - let encode_bool (map : ('a, 'b) Json.Repr.base_map) e v = 1264 + let encode_bool (map : ('a, 'b) Json.Codec.base_map) e v = 1261 1265 let b = map.enc v in 1262 1266 match e.format with 1263 1267 | Json.Minify | Json.Indent -> write_json_bool e b ··· 1267 1271 write_json_bool e b; 1268 1272 write_ws_after e meta 1269 1273 1270 - let encode_number (map : ('a, 'b) Json.Repr.base_map) e v = 1274 + let encode_number (map : ('a, 'b) Json.Codec.base_map) e v = 1271 1275 let n = map.enc v in 1272 1276 match e.format with 1273 1277 | Json.Minify | Json.Indent -> write_json_number e n ··· 1277 1281 write_json_number e n; 1278 1282 write_ws_after e meta 1279 1283 1280 - let encode_string (map : ('a, 'b) Json.Repr.base_map) e v = 1284 + let encode_string (map : ('a, 'b) Json.Codec.base_map) e v = 1281 1285 let s = map.enc v in 1282 1286 match e.format with 1283 1287 | Json.Minify | Json.Indent -> write_json_string e s ··· 1305 1309 write_ws_after e meta; 1306 1310 write_char e ':' 1307 1311 1308 - let rec encode : type a. nest:int -> a Json.Repr.t -> encoder -> a -> unit = 1312 + let rec encode : type a. nest:int -> a Json.Codec.t -> encoder -> a -> unit = 1309 1313 fun ~nest t e v -> 1310 1314 match t with 1311 1315 | Null map -> encode_null map e v ··· 1320 1324 | Ignore -> Json.Error.failf Json.Meta.none "Cannot encode Ignore value" 1321 1325 1322 1326 and encode_array : type a elt b. 1323 - nest:int -> (a, elt, b) Json.Repr.array_map -> encoder -> a -> unit = 1327 + nest:int -> (a, elt, b) Json.Codec.array_map -> encoder -> a -> unit = 1324 1328 fun ~nest map e v -> 1325 1329 let encode_element ~nest map e i v = 1326 1330 if i <> 0 then write_sep e; ··· 1328 1332 encode ~nest map.elt e v; 1329 1333 e 1330 1334 with Json.Error e -> 1331 - Json.Repr.error_push_array Json.Meta.none map (i, Json.Meta.none) e 1335 + Json.Codec.error_push_array Json.Meta.none map (i, Json.Meta.none) e 1332 1336 in 1333 1337 match e.format with 1334 1338 | Json.Minify -> ··· 1351 1355 encode ~nest map.elt e v; 1352 1356 e 1353 1357 with Json.Error e -> 1354 - Json.Repr.error_push_array Json.Meta.none map (i, Json.Meta.none) e 1358 + Json.Codec.error_push_array Json.Meta.none map (i, Json.Meta.none) e 1355 1359 in 1356 1360 let array_not_empty e = 1357 1361 e.o_next = 0 || not (Bytes.get e.o (e.o_next - 1) = '[') ··· 1364 1368 write_char e ']' 1365 1369 1366 1370 and encode_object : type o enc. 1367 - nest:int -> (o, o) Json.Repr.object_map -> encoder -> o -> unit = 1371 + nest:int -> (o, o) Json.Codec.object_map -> encoder -> o -> unit = 1368 1372 fun ~nest map e o -> 1369 1373 match e.format with 1370 1374 | Json.Minify -> ··· 1392 1396 1393 1397 and encode_object_map : type o enc. 1394 1398 nest:int -> 1395 - (o, o) Json.Repr.object_map -> 1399 + (o, o) Json.Codec.object_map -> 1396 1400 do_unknown:bool -> 1397 1401 encoder -> 1398 1402 start:bool -> ··· 1415 1419 false 1416 1420 end 1417 1421 with Json.Error e -> 1418 - Json.Repr.error_push_object Json.Meta.none map 1422 + Json.Codec.error_push_object Json.Meta.none map 1419 1423 (mmap.name, Json.Meta.none) 1420 1424 e 1421 1425 in ··· 1463 1467 encode ~nest umap.mems_type e v; 1464 1468 false 1465 1469 with Json.Error e -> 1466 - Json.Repr.error_push_object Json.Meta.none map (n, Json.Meta.none) e 1470 + Json.Codec.error_push_object Json.Meta.none map (n, Json.Meta.none) e 1467 1471 in 1468 1472 umap.enc (encode_unknown_mem ~nest map umap e) mems start 1469 1473 1470 1474 let encode' ?buf ?format ?number_format t v ~eod w = 1471 1475 let e = make_encoder ?buf ?format ?number_format w in 1472 - let t = Json.Repr.of_t t in 1476 + let t = t in 1473 1477 try 1474 1478 Ok 1475 1479 (encode ~nest:0 t e v;

+371 -1

lib/codec.ml

··· 1 - (** Codec combinators for JSON values. See {!Json} for the public API. *) 1 + (* Internal codec representation. This is the GADT that json.ml's 2 + combinators walk at decode/encode time. The public alias is 3 + [type 'a Json.codec = 'a Codec.t] in json.ml. *) 4 + 5 + (* See the .mli for documentation *) 6 + 7 + module Fmt = Core.Fmt 8 + module Meta = Loc.Meta 9 + module Path = Loc.Path 10 + module Sort = Core.Sort 11 + module String_map = Map.Make (String) 12 + 13 + type 'a node = 'a * Meta.t 14 + 15 + type ('ret, 'f) dec_fun = 16 + | Dec_fun : 'f -> ('ret, 'f) dec_fun 17 + | Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun 18 + 19 + type ('a, 'b) base_map = { 20 + kind : string; 21 + doc : string; 22 + dec : Meta.t -> 'a -> 'b; 23 + enc : 'b -> 'a; 24 + enc_meta : 'b -> Meta.t; 25 + } 26 + 27 + type 'a t = 28 + | Null : (unit, 'a) base_map -> 'a t 29 + | Bool : (bool, 'a) base_map -> 'a t 30 + | Number : (float, 'a) base_map -> 'a t 31 + | String : (string, 'a) base_map -> 'a t 32 + | Array : ('a, 'elt, 'builder) array_map -> 'a t 33 + | Object : ('o, 'o) object_map -> 'o t 34 + | Any : 'a any_map -> 'a t 35 + | Map : ('a, 'b) map -> 'b t 36 + | Rec : 'a t Lazy.t -> 'a t 37 + | Ignore : unit t 38 + (** Skip-parse any JSON value without materialising its contents. The 39 + bytesrw decoder dispatches to [skip_json_value], which advances past 40 + the value at the byte level (balancing brackets, skipping string 41 + content without decoding escapes, consuming numeric digits without 42 + [float_of_string]). Avoids the token-accumulation and allocation costs 43 + of the generic codec dispatch when the caller only needs to discard 44 + the value. *) 45 + 46 + and ('array, 'elt, 'builder) array_map = { 47 + kind : string; 48 + doc : string; 49 + elt : 'elt t; 50 + dec_empty : unit -> 'builder; 51 + dec_skip : int -> 'builder -> bool; 52 + dec_add : int -> 'elt -> 'builder -> 'builder; 53 + dec_finish : Meta.t -> int -> 'builder -> 'array; 54 + enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; 55 + enc_meta : 'array -> Meta.t; 56 + } 57 + 58 + and ('o, 'dec) object_map = { 59 + kind : string; 60 + doc : string; 61 + dec : ('o, 'dec) dec_fun; 62 + mem_decs : mem_dec String_map.t; 63 + mem_encs : 'o mem_enc list; 64 + enc_meta : 'o -> Meta.t; 65 + shape : 'o object_shape; 66 + } 67 + 68 + and mem_dec = Mem_dec : ('o, 'a) mem_map -> mem_dec 69 + and 'o mem_enc = Mem_enc : ('o, 'a) mem_map -> 'o mem_enc 70 + 71 + and ('o, 'a) mem_map = { 72 + name : string; 73 + doc : string; 74 + type' : 'a t; 75 + id : 'a Type.Id.t; 76 + dec_absent : 'a option; 77 + enc : 'o -> 'a; 78 + (* enc_name_meta : 'a -> Meta.t; See comment in .mli *) 79 + enc_omit : 'a -> bool; 80 + } 81 + 82 + and 'o object_shape = 83 + | Object_basic : ('o, 'mems, 'builder) unknown_mems -> 'o object_shape 84 + | Object_cases : 85 + ('o, 'mems, 'builder) unknown_mems option 86 + * ('o, 'cases, 'tag) object_cases 87 + -> 'o object_shape 88 + 89 + and ('o, 'mems, 'builder) unknown_mems = 90 + | Unknown_skip : ('o, unit, unit) unknown_mems 91 + | Unknown_error : ('o, unit, unit) unknown_mems 92 + | Unknown_keep : 93 + ('mems, 'a, 'builder) mems_map * ('o -> 'mems) 94 + -> ('o, 'mems, 'builder) unknown_mems 95 + 96 + and ('mems, 'a, 'builder) mems_map = { 97 + kind : string; 98 + doc : string; 99 + mems_type : 'a t; 100 + id : 'mems Type.Id.t; 101 + dec_empty : unit -> 'builder; 102 + dec_add : Meta.t -> string -> 'a -> 'builder -> 'builder; 103 + dec_finish : Meta.t -> 'builder -> 'mems; 104 + enc : 'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc; 105 + } 106 + 107 + and ('o, 'cases, 'tag) object_cases = { 108 + tag : ('tag, 'tag) mem_map; 109 + tag_compare : 'tag -> 'tag -> int; 110 + tag_to_string : ('tag -> string) option; 111 + id : 'cases Type.Id.t; 112 + cases : ('cases, 'tag) case list; 113 + enc : 'o -> 'cases; 114 + enc_case : 'cases -> ('cases, 'tag) case_value; 115 + } 116 + 117 + and ('cases, 'case, 'tag) case_map = { 118 + tag : 'tag; 119 + object_map : ('case, 'case) object_map; 120 + dec : 'case -> 'cases; 121 + } 122 + 123 + and ('cases, 'tag) case_value = 124 + | Case_value : 125 + ('cases, 'case, 'tag) case_map * 'case 126 + -> ('cases, 'tag) case_value 127 + 128 + and ('cases, 'tag) case = 129 + | Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case 130 + 131 + and 'a any_map = { 132 + kind : string; 133 + doc : string; 134 + dec_null : 'a t option; 135 + dec_bool : 'a t option; 136 + dec_number : 'a t option; 137 + dec_string : 'a t option; 138 + dec_array : 'a t option; 139 + dec_object : 'a t option; 140 + enc : 'a -> 'a t; 141 + } 142 + 143 + and ('a, 'b) map = { 144 + kind : string; 145 + doc : string; 146 + dom : 'a t; 147 + dec : 'a -> 'b; 148 + enc : 'b -> 'a; 149 + } 150 + 151 + (* Kinds and doc *) 152 + 153 + let base_map_with_doc ?kind ?doc (map : ('a, 'b) base_map) = 154 + let kind = Option.value ~default:map.kind doc in 155 + let doc = Option.value ~default:map.doc doc in 156 + { map with kind; doc } 157 + 158 + let array_map_with_doc ?kind ?doc (map : ('a, 'b, 'c) array_map) = 159 + let kind = Option.value ~default:map.kind doc in 160 + let doc = Option.value ~default:map.doc doc in 161 + { map with kind; doc } 162 + 163 + let object_map_with_doc ?kind ?doc (map : ('o, 'o) object_map) = 164 + let kind = Option.value ~default:map.kind doc in 165 + let doc = Option.value ~default:map.doc doc in 166 + { map with kind; doc } 167 + 168 + let any_map_with_doc ?kind ?doc (map : 'a any_map) = 169 + let kind = Option.value ~default:map.kind doc in 170 + let doc = Option.value ~default:map.doc doc in 171 + { map with kind; doc } 172 + 173 + let map_with_doc ?kind ?doc (map : ('a, 'b) map) = 174 + let kind = Option.value ~default:map.kind doc in 175 + let doc = Option.value ~default:map.doc doc in 176 + { map with kind; doc } 177 + 178 + let rec with_doc : type a. ?kind:string -> ?doc:string -> a t -> a t = 179 + fun ?kind ?doc -> function 180 + | Null map -> Null (base_map_with_doc ?kind ?doc map) 181 + | Bool map -> Bool (base_map_with_doc ?kind ?doc map) 182 + | Number map -> Number (base_map_with_doc ?kind ?doc map) 183 + | String map -> String (base_map_with_doc ?kind ?doc map) 184 + | Array map -> Array (array_map_with_doc ?kind ?doc map) 185 + | Object map -> Object (object_map_with_doc ?kind ?doc map) 186 + | Any map -> Any (any_map_with_doc ?kind ?doc map) 187 + | Map map -> Map (map_with_doc ?kind ?doc map) 188 + | Rec l -> with_doc ?kind ?doc (Lazy.force l) 189 + | Ignore -> Ignore 190 + 191 + let object_map_kinded_sort (map : ('o, 'dec) object_map) = 192 + Sort.kinded ~kind:map.kind Object 193 + 194 + let rec kinded_sort : type a. a t -> string = function 195 + | Null map -> Sort.kinded ~kind:map.kind Null 196 + | Bool map -> Sort.kinded ~kind:map.kind Bool 197 + | Number map -> Sort.kinded ~kind:map.kind Number 198 + | String map -> Sort.kinded ~kind:map.kind String 199 + | Array map -> array_map_kinded_sort map 200 + | Object map -> object_map_kinded_sort map 201 + | Any map -> if map.kind = "" then any_map_kinded_sort map else map.kind 202 + | Map map -> if map.kind = "" then kinded_sort map.dom else map.kind 203 + | Rec l -> kinded_sort (Lazy.force l) 204 + | Ignore -> "ignore" 205 + 206 + and array_map_kinded_sort : type a e b. (a, e, b) array_map -> string = 207 + fun map -> 208 + if map.kind <> "" then Sort.kinded ~kind:map.kind Array 209 + else 210 + let elt = kinded_sort map.elt in 211 + String.concat "" [ "array<"; elt; ">" ] 212 + 213 + and any_map_kinded_sort : type a. a any_map -> string = 214 + fun map -> 215 + let add_case ks sort = function 216 + | None -> ks 217 + | Some k -> 218 + (if map.kind <> "" then kinded_sort k 219 + else Sort.kinded ~kind:map.kind sort) 220 + :: ks 221 + in 222 + let ks = add_case [] Object map.dec_object in 223 + let ks = add_case ks Array map.dec_array in 224 + let ks = add_case ks String map.dec_string in 225 + let ks = add_case ks Number map.dec_number in 226 + let ks = add_case ks Bool map.dec_bool in 227 + let ks = add_case ks Null map.dec_null in 228 + "one of " ^ String.concat ", " ks 229 + 230 + let rec kind : type a. a t -> string = function 231 + | Null map -> Sort.or_kind ~kind:map.kind Null 232 + | Bool map -> Sort.or_kind ~kind:map.kind Bool 233 + | Number map -> Sort.or_kind ~kind:map.kind Number 234 + | String map -> Sort.or_kind ~kind:map.kind String 235 + | Array map -> Sort.or_kind ~kind:map.kind Array 236 + | Object map -> Sort.or_kind ~kind:map.kind Object 237 + | Any map -> if map.kind <> "" then map.kind else "any" 238 + | Map map -> if map.kind <> "" then map.kind else kind map.dom 239 + | Rec l -> kind (Lazy.force l) 240 + | Ignore -> "ignore" 241 + 242 + let rec doc : type a. a t -> string = function 243 + | Null map -> map.doc 244 + | Bool map -> map.doc 245 + | Number map -> map.doc 246 + | String map -> map.doc 247 + | Array map -> map.doc 248 + | Object map -> map.doc 249 + | Any map -> map.doc 250 + | Map map -> map.doc 251 + | Rec l -> doc (Lazy.force l) 252 + | Ignore -> "" 253 + 254 + (* Errors *) 255 + 256 + let pp_code = Fmt.code 257 + let pp_kind = Fmt.code 258 + 259 + let error_push_object meta map name e = 260 + Error.push_object (object_map_kinded_sort map, meta) name e 261 + 262 + let error_push_array meta map i e = 263 + Error.push_array (array_map_kinded_sort map, meta) i e 264 + 265 + let type_error meta t ~fnd = Error.kinded_sort meta ~exp:(kinded_sort t) ~fnd 266 + 267 + let missing_mems_error meta (object_map : ('o, 'o) object_map) ~exp ~fnd = 268 + let kinded_sort = object_map_kinded_sort object_map in 269 + let exp = 270 + let add n (Mem_dec m) acc = 271 + match m.dec_absent with None -> n :: acc | Some _ -> acc 272 + in 273 + List.rev (String_map.fold add exp []) 274 + in 275 + Error.missing_mems meta ~kinded_sort ~exp ~fnd 276 + 277 + let unexpected_mems_error meta (object_map : ('o, 'o) object_map) ~fnd = 278 + let kinded_sort = object_map_kinded_sort object_map in 279 + let exp = List.map (fun (Mem_enc m) -> m.name) object_map.mem_encs in 280 + Error.unexpected_mems meta ~kinded_sort ~exp ~fnd 281 + 282 + let unexpected_case_tag_error meta object_map object_cases tag = 283 + let kinded_sort = object_map_kinded_sort object_map in 284 + let case_to_string (Case c) = 285 + match object_cases.tag_to_string with 286 + | None -> None 287 + | Some str -> Some (str c.tag) 288 + in 289 + let exp = List.filter_map case_to_string object_cases.cases in 290 + let fnd = 291 + match object_cases.tag_to_string with 292 + | None -> "<tag>" (* XXX not good *) 293 + | Some str -> str tag 294 + in 295 + let mem_name = object_cases.tag.name in 296 + Error.unexpected_case_tag meta ~kinded_sort ~mem_name ~exp ~fnd 297 + 298 + (* Processor toolbox *) 299 + 300 + let object_meta_arg : Meta.t Type.Id.t = Type.Id.make () 301 + 302 + module Dict = struct 303 + module M = Map.Make (Int) 304 + 305 + type binding = B : 'a Type.Id.t * 'a -> binding 306 + type t = binding M.t 307 + 308 + let empty = M.empty 309 + let mem k m = M.mem (Type.Id.uid k) m 310 + let add k v m = M.add (Type.Id.uid k) (B (k, v)) m 311 + let remove k m = M.remove (Type.Id.uid k) m 312 + 313 + let find : type a. a Type.Id.t -> t -> a option = 314 + fun k m -> 315 + match M.find_opt (Type.Id.uid k) m with 316 + | None -> None 317 + | Some (B (k', v)) -> ( 318 + match Type.Id.provably_equal k k' with 319 + | Some Type.Equal -> Some v 320 + | None -> assert false) 321 + end 322 + 323 + let rec apply_dict : type ret f. (ret, f) dec_fun -> Dict.t -> f = 324 + fun dec dict -> 325 + match dec with 326 + | Dec_fun f -> f 327 + | Dec_app (f, arg) -> (apply_dict f dict) (Option.get (Dict.find arg dict)) 328 + 329 + type unknown_mems_option = 330 + | Unknown_mems : 331 + ('o, 'mems, 'builder) unknown_mems option 332 + -> unknown_mems_option 333 + 334 + let override_unknown_mems ~by umems dict = 335 + match by with 336 + | Unknown_mems None -> (umems, dict) 337 + | Unknown_mems _ as by -> ( 338 + match umems with 339 + | Unknown_mems (Some (Unknown_keep (umap, _))) -> 340 + (* A decoding function still expect [umap.id] argument in 341 + an Dec_app, we simply stub it with the empty map. *) 342 + let empty = umap.dec_finish Meta.none (umap.dec_empty ()) in 343 + let dict = Dict.add umap.id empty dict in 344 + (by, dict) 345 + | _ -> (by, dict)) 346 + 347 + let finish_object_decode : type o p m mems builder. 348 + (o, o) object_map -> 349 + Meta.t -> 350 + (p, mems, builder) unknown_mems -> 351 + builder -> 352 + mem_dec String_map.t -> 353 + Dict.t -> 354 + Dict.t = 355 + fun map meta umems umap mem_decs dict -> 356 + let dict = Dict.add object_meta_arg meta dict in 357 + let dict = 358 + match umems with 359 + | Unknown_skip | Unknown_error -> dict 360 + | Unknown_keep (map, _) -> Dict.add map.id (map.dec_finish meta umap) dict 361 + in 362 + let add_default _ (Mem_dec mem_map) dict = 363 + match mem_map.dec_absent with 364 + | Some v -> Dict.add mem_map.id v dict 365 + | None -> raise Exit 366 + in 367 + try String_map.fold add_default mem_decs dict 368 + with Exit -> 369 + let no_default _ (Mem_dec mm) = Option.is_none mm.dec_absent in 370 + let exp = String_map.filter no_default mem_decs in 371 + missing_mems_error meta map ~exp ~fnd:[]

+371 -1

lib/codec.mli

··· 1 - (** Codec combinators for JSON values. See {!Json} for the public API. *) 1 + (** Internal codec representation. This is the GADT that json.ml's combinators 2 + walk at decode/encode time. The public alias is 3 + [type 'a Json.codec = 'a Codec.t] in json.ml. *) 4 + 5 + module Meta = Loc.Meta 6 + module Path = Loc.Path 7 + module Sort = Core.Sort 8 + 9 + type 'a node = 'a * Meta.t 10 + 11 + module String_map : module type of Map.Make (String) 12 + (** A [Map.Make(String)] instance. *) 13 + 14 + (** The type for decoding functions. *) 15 + type ('ret, 'f) dec_fun = 16 + | Dec_fun : 'f -> ('ret, 'f) dec_fun (** The function and its return type. *) 17 + | Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun 18 + (** Application of an argument to a function witnessed by a type 19 + identifier. The type identifier can be used to lookup a value of the 20 + right type in an heterogenous dictionary. *) 21 + 22 + (** {1:base Base value maps} *) 23 + 24 + type ('a, 'b) base_map = { 25 + kind : string; (** The kind of JSON value that are mapped (documentation) *) 26 + doc : string; (** A doc string for the kind of JSON value. *) 27 + dec : Meta.t -> 'a -> 'b; 28 + (** [dec] decodes a base value represented by its metadata and ['a] to 29 + ['b]. *) 30 + enc : 'b -> 'a; 31 + (** [enc] encodes a value of type ['b] to a base JSON value represented by 32 + ['a]. *) 33 + enc_meta : 'b -> Meta.t; 34 + (** [enc_meta] recovers the base JSON value metadata from ['b] (if any). 35 + *) 36 + } 37 + (** The type for mapping JSON base values represented in OCaml by ['a] (these 38 + values are fixed by the cases in {!t}) to a value of type ['b]. *) 39 + 40 + (** {1:types JSON types} *) 41 + 42 + (** The type for JSON types. *) 43 + type 'a t = 44 + | Null : (unit, 'a) base_map -> 'a t (** Null maps. *) 45 + | Bool : (bool, 'a) base_map -> 'a t (** Boolean maps. *) 46 + | Number : (float, 'a) base_map -> 'a t (** Number maps. *) 47 + | String : (string, 'a) base_map -> 'a t (** String maps. *) 48 + | Array : ('a, 'elt, 'builder) array_map -> 'a t (** Array maps. *) 49 + | Object : ('o, 'o) object_map -> 'o t (** Object maps. *) 50 + | Any : 'a any_map -> 'a t (** Map for different sorts of JSON values. *) 51 + | Map : ('b, 'a) map -> 'a t 52 + (** Map from JSON type ['b] to JSON type ['a]. *) 53 + | Rec : 'a t Lazy.t -> 'a t (** Recursive definition. *) 54 + | Ignore : unit t 55 + (** Skip-parse any JSON value. The bytesrw decoder consumes the value at 56 + the byte level without materialising strings, numbers or nested DOM; 57 + this is the fast path for {!Json.ignore}. *) 58 + 59 + (** {1:array Array maps} *) 60 + 61 + and ('array, 'elt, 'builder) array_map = { 62 + kind : string; (** The kind of JSON array mapped (documentation). *) 63 + doc : string; (** Documentation string for the JSON array. *) 64 + elt : 'elt t; (** The type for the array elements. *) 65 + dec_empty : unit -> 'builder; 66 + (** [dec_empty ()] creates a new empty array builder. *) 67 + dec_skip : int -> 'builder -> bool; 68 + (** [dec_skip i b] determines if the [i]th index of the JSON array can be 69 + skipped. *) 70 + dec_add : int -> 'elt -> 'builder -> 'builder; 71 + (** [dec_add] adds the [i]th index value of the JSON array as decoded by 72 + [elt] to the builder. *) 73 + dec_finish : Meta.t -> int -> 'builder -> 'array; 74 + (** [dec_finish] turns the builder into an array given its metadata and 75 + length. *) 76 + enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; 77 + (** [enc] folds over the elements of the array for encoding. *) 78 + enc_meta : 'array -> Meta.t; 79 + (** [enc_meta] recovers the metadata of an array (if any). *) 80 + } 81 + (** The type for mapping JSON arrays to values of type ['array] with array 82 + elements mapped to type ['elt] and using a ['builder] value to construct the 83 + array. *) 84 + 85 + (** {1:object_map Object maps} *) 86 + 87 + and ('o, 'dec) object_map = { 88 + kind : string; (** The kind of JSON object (documentation). *) 89 + doc : string; (** A doc string for the JSON member. *) 90 + dec : ('o, 'dec) dec_fun; 91 + (** The object decoding function to construct an ['o] value. *) 92 + mem_decs : mem_dec String_map.t; 93 + (** [mem_decs] are the member decoders sorted by member name. *) 94 + mem_encs : 'o mem_enc list; (** [mem_encs] is the list of member encoders. *) 95 + enc_meta : 'o -> Meta.t; 96 + (** [enc_meta] recovers the metadata of an object (if any). *) 97 + shape : 'o object_shape; 98 + (** [shape] is the {{!object_shape}shape} of the object. *) 99 + } 100 + (** The type for mapping a JSON object to values of type ['o] using a decoding 101 + function of type ['dec]. [mem_decs] and [mem_encs] have the same {!mem_map} 102 + values they are just sorted differently for decoding and encoding purposes. 103 + *) 104 + 105 + and mem_dec = 106 + | Mem_dec : ('o, 'a) mem_map -> mem_dec 107 + (** The type for member maps in decoding position. *) 108 + 109 + and 'o mem_enc = 110 + | Mem_enc : ('o, 'a) mem_map -> 'o mem_enc 111 + (** The type for member maps in encoding position. *) 112 + 113 + and ('o, 'a) mem_map = { 114 + name : string; (** The JSON member name. *) 115 + doc : string; (** Documentation for the JSON member. *) 116 + type' : 'a t; (** The type for the member value. *) 117 + id : 'a Type.Id.t; 118 + (** A type identifier for the member. This allows to store the decode in a 119 + {!Dict.t} on decode and give it in time to the object decoding 120 + function of the object map. *) 121 + dec_absent : 'a option; (** The value to use if absent (if any). *) 122 + enc : 'o -> 'a; (** [enc] recovers the value to encode from ['o]. *) 123 + (* enc_name_meta : 'a -> Meta.t; 124 + XXX This should have been the meta found for the name, but 125 + that does not fit so well in the member combinators, it's 126 + not impossible to fit it in but likely increases the cost 127 + for decoding objects. The layout preserving updates occur 128 + via generic JSON which uses [mems_map] in which the meta 129 + is available in [dec_add]. Let's leave it that way for now. *) 130 + enc_omit : 'a -> bool; 131 + (** [enc_omit] is [true] if the result of [enc] should not be encoded. *) 132 + } 133 + (** The type for mapping a JSON member to a value of type ['a] in an object 134 + represented by a value of type ['o]. *) 135 + 136 + (** The type for object shapes. *) 137 + and 'o object_shape = 138 + | Object_basic : ('o, 'mems, 'builder) unknown_mems -> 'o object_shape 139 + (** A basic object, possibly indicating how to handle unknown members *) 140 + | Object_cases : 141 + ('o, 'mems, 'builder) unknown_mems option 142 + * ('o, 'cases, 'tag) object_cases 143 + -> 'o object_shape 144 + (** An object with a case member each case further describing an object 145 + map. *) 146 + 147 + (** {2:unknown_mems Unknown members} *) 148 + 149 + (** The type for specifying decoding behaviour on unknown JSON object members. 150 + *) 151 + and ('o, 'mems, 'builder) unknown_mems = 152 + | Unknown_skip : ('o, unit, unit) unknown_mems (** Skip unknown members. *) 153 + | Unknown_error : ('o, unit, unit) unknown_mems 154 + (** Error on unknown members. *) 155 + | Unknown_keep : 156 + ('mems, 'a, 'builder) mems_map * ('o -> 'mems) 157 + -> ('o, 'mems, 'builder) unknown_mems 158 + (** Gather unknown members in a member map. *) 159 + 160 + and ('mems, 'a, 'builder) mems_map = { 161 + kind : string; (** The kind for unknown members (documentation). *) 162 + doc : string; (** Documentation string for the unknown members. *) 163 + mems_type : 'a t; 164 + (** The uniform type according which unknown members are typed. *) 165 + id : 'mems Type.Id.t; (** A type identifier for the unknown member map. *) 166 + dec_empty : unit -> 'builder; 167 + (** [dec_empty] create a new empty member map builder. *) 168 + dec_add : Meta.t -> string -> 'a -> 'builder -> 'builder; 169 + (** [dec_add] adds a member named [n] with metadata [meta] and value 170 + parsed by [mems_type] to the builder. *) 171 + dec_finish : Meta.t -> 'builder -> 'mems; 172 + (** [dec_finish] turns the builder into an unknown member map. The [meta] 173 + is the meta data of the object in which they were found. *) 174 + enc : 'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc; 175 + (** [enc] folds over the member map for encoding. *) 176 + } 177 + (** The type for gathering unknown JSON members uniformly typed according to 178 + ['a] in a map ['mems] constructed with ['builder]. *) 179 + 180 + (** {2:case_objects Case objects} *) 181 + 182 + and ('o, 'cases, 'tag) object_cases = { 183 + tag : ('tag, 'tag) mem_map; 184 + (** The JSON member used to decide cases. The [enc] field of this 185 + [mem_map] should be the identity, this allows encoders to reuse 186 + generic encoding code for members. We don't have [('o, 'tag) mem_map] 187 + here because the tag is not stored we recover the case via [enc] and 188 + [enc_case] below. *) 189 + tag_compare : 'tag -> 'tag -> int; (** The function to compare tags. *) 190 + tag_to_string : ('tag -> string) option; 191 + (** The function to stringify tags for error reporting. *) 192 + id : 'cases Type.Id.t; (** A type identifier for the tag. *) 193 + cases : ('cases, 'tag) case list; (** The list of possible cases. *) 194 + enc : 'o -> 'cases; 195 + (** [enc] is the function to recover case values from the value ['o] the 196 + object is mapped to. *) 197 + enc_case : 'cases -> ('cases, 'tag) case_value; 198 + (** [enc_case] retrieves the concrete case from the common [cases] values. 199 + You can see it as preforming a match. *) 200 + } 201 + (** The type for object cases mapped to a common type ['cases] stored in a vlue 202 + of type ['o] and identified by tag values of type ['tag]. *) 203 + 204 + and ('cases, 'case, 'tag) case_map = { 205 + tag : 'tag; (** The tag value for the case. *) 206 + object_map : ('case, 'case) object_map; (** The object map for the case. *) 207 + dec : 'case -> 'cases; 208 + (** [dec] is the function used on decoding to inject the case into the 209 + common ['cases] type. *) 210 + } 211 + (** The type for an object case with common type ['cases] specific type ['case] 212 + and tag type ['tag]. *) 213 + 214 + and ('cases, 'tag) case_value = 215 + | Case_value : 216 + ('cases, 'case, 'tag) case_map * 'case 217 + -> ('cases, 'tag) case_value 218 + (** The type for case values. This packs a case value and its description. 219 + *) 220 + 221 + and ('cases, 'tag) case = 222 + | Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case 223 + (** The type for hiding the the concrete type of a case . *) 224 + 225 + (** {1:any Any maps} *) 226 + 227 + and 'a any_map = { 228 + kind : string; (** The kind of JSON values mapped (documentation). *) 229 + doc : string; (** Documentation string for the kind of values. *) 230 + dec_null : 'a t option; 231 + (** [dec_null], if any, is used for decoding JSON nulls. *) 232 + dec_bool : 'a t option; 233 + (** [dec_bool], if any, is used for decoding JSON bools. *) 234 + dec_number : 'a t option; 235 + (** [dec_number], if any, is used for decoding JSON numbers. *) 236 + dec_string : 'a t option; 237 + (** [dec_string], if any, is used for decoding JSON strings. *) 238 + dec_array : 'a t option; 239 + (** [dec_array], if any, is used for decoding JSON arrays. *) 240 + dec_object : 'a t option; 241 + (** [dec_object], if any, is used for decoding JSON objects. *) 242 + enc : 'a -> 'a t; (** [enc] specifies the encoder to use on a given value. *) 243 + } 244 + (** The type for mapping JSON values with multiple sorts to a value of type 245 + ['a]. If a decoding case is [None], the decoding errors on these JSON 246 + values. *) 247 + 248 + (** {1:type_map Type maps} *) 249 + 250 + and ('a, 'b) map = { 251 + kind : string; (** The kind of JSON values mapped (documentation). *) 252 + doc : string; (** Documentation string for the kind of values. *) 253 + dom : 'a t; (** The domain of the map. *) 254 + dec : 'a -> 'b; (** [dec] decodes ['a] to ['b]. *) 255 + enc : 'b -> 'a; (** [enc] encodes ['b] to ['a]. *) 256 + } 257 + (** The type for mapping JSON types of type ['a] to a JSON type of type ['b]. *) 258 + 259 + (** {1:kinds Kinds and doc} *) 260 + 261 + val kinded_sort : 'a t -> string 262 + (** [kinded_sort t] is kinded sort of [t], see {!Json.kinded_sort}. *) 263 + 264 + val kind : 'a t -> string 265 + (** [kind t] is the kind of the underlying map, see {!Json.kind}. *) 266 + 267 + val array_map_kinded_sort : ('a, 'elt, 'builder) array_map -> string 268 + (** [array_map_kinded_sort map] is like {!kinded_sort} but acts directly on the 269 + array [map]. *) 270 + 271 + val object_map_kinded_sort : ('o, 'dec) object_map -> string 272 + (** [object_map_kind map] is like {!kinded_sort} but acts directly on the object 273 + [map]. *) 274 + 275 + val pp_kind : string Fmt.t 276 + (** [pp_kind] formats kinds. *) 277 + 278 + val doc : 'a t -> string 279 + (** See {!Json.doc}. *) 280 + 281 + val with_doc : ?kind:string -> ?doc:string -> 'a t -> 'a t 282 + (** See {!Json.with_doc}. *) 283 + 284 + (** {1:errors Errors} *) 285 + 286 + val error_push_array : 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 289 + [meta] and array map to caracterize the context. *) 290 + 291 + val error_push_object : 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. *) 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. *) 299 + 300 + val missing_mems_error : 301 + Meta.t -> 302 + ('o, 'o) object_map -> 303 + exp:mem_dec String_map.t -> 304 + fnd:string list -> 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. *) 308 + 309 + val unexpected_mems_error : 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 312 + members for object [map]. *) 313 + 314 + val unexpected_case_tag_error : 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 317 + member has no corresponding case. *) 318 + 319 + (** {1:toolbox Processor toolbox} *) 320 + 321 + val object_meta_arg : Meta.t Type.Id.t 322 + (** [object_meta_arg] holds the {!Json.Object.mem} to *) 323 + 324 + (** Heterogeneous dictionaries. *) 325 + module Dict : sig 326 + type binding = B : 'a Type.Id.t * 'a -> binding 327 + type t 328 + 329 + val empty : t 330 + val mem : 'a Type.Id.t -> t -> bool 331 + val add : 'a Type.Id.t -> 'a -> t -> t 332 + val remove : 'a Type.Id.t -> t -> t 333 + val find : 'a Type.Id.t -> t -> 'a option 334 + end 335 + 336 + val apply_dict : ('ret, 'f) dec_fun -> Dict.t -> 'f 337 + (** [apply_dict dec dict] applies [dict] to [f] in order to get the value ['f]. 338 + Raises [Invalid_argument] if [dict] has not all the type identifiers that 339 + [dec] needs. *) 340 + 341 + type unknown_mems_option = 342 + | Unknown_mems : 343 + ('o, 'mems, 'builder) unknown_mems option 344 + -> unknown_mems_option 345 + (** A type for hiding an optional {!type-unknown_mems} values. *) 346 + 347 + val override_unknown_mems : 348 + by:unknown_mems_option -> 349 + unknown_mems_option -> 350 + Dict.t -> 351 + unknown_mems_option * Dict.t 352 + (** [override_unknown_mems ~by current dict] preforms the unknown member 353 + overriding logic for {!Json.Object.Case} objects. In particular if [current] 354 + is a {!Json.Object.Mems.val-map} it adds an empty one in [dict] so that the 355 + associated decoding function does not fail. *) 356 + 357 + val finish_object_decode : 358 + ('o, 'o) object_map -> 359 + Meta.t -> 360 + ('p, 'mems, 'builder) unknown_mems -> 361 + 'builder -> 362 + mem_dec String_map.t -> 363 + Dict.t -> 364 + Dict.t 365 + (** [finish_object_decode map meta unknown_mems umap rem_mems dict] finishes an 366 + object map [map] decode. It adds the [umap] (if needed) to [dict], it adds 367 + [meta] to [dict] under {!object_meta_arg} and tries to find andd default 368 + values to [dict] for [rem_mems] (and errors if it can't). *) 369 + 370 + val pp_code : string Fmt.t 371 + (** [pp_code] formats strings like code (in bold). *)

-1

lib/core.ml

··· 346 346 char ppf '"' 347 347 end 348 348 349 - 350 349 (* JSON numbers *) 351 350 352 351 module Number = struct

-1

lib/core.mli

··· 65 65 val json_string : string t 66 66 end 67 67 68 - 69 68 (** JSON number tools. *) 70 69 module Number : sig 71 70 val number_contains_int : bool

+104

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. *) 3 + 4 + module Fmt = Core.Fmt 5 + module Sort = Core.Sort 6 + 7 + type kind = Loc.Error.kind = .. 8 + 9 + type Loc.Error.kind += 10 + | Sort_mismatch of { exp : Sort.t; fnd : Sort.t } 11 + | Kinded_sort_mismatch of { exp : string; fnd : Sort.t } 12 + 13 + let () = 14 + Loc.Error.register_kind_printer (function 15 + | Sort_mismatch { exp; fnd } -> 16 + Some 17 + (fun ppf -> 18 + Fmt.pf ppf "Expected %a but found %a" Sort.pp exp Sort.pp fnd) 19 + | Kinded_sort_mismatch { exp; fnd } -> 20 + Some 21 + (fun ppf -> 22 + Fmt.pf ppf "Expected %a but found %a" Fmt.code exp Sort.pp fnd) 23 + | _ -> None) 24 + 25 + type t = Loc.Error.t 26 + 27 + module Context = Loc.Error.Context 28 + 29 + let kind_to_string = Loc.Error.kind_to_string 30 + let v = Loc.Error.v 31 + let msg = Loc.Error.msg 32 + let raise = Loc.Error.raise 33 + let fail = Loc.Error.fail 34 + let failf = Loc.Error.failf 35 + let msgf = Loc.Error.failf 36 + let push_array = Loc.Error.push_array 37 + let push_object = Loc.Error.push_object 38 + let adjust_context = Loc.Error.adjust_context 39 + let pp = Loc.Error.pp 40 + let to_string = Loc.Error.to_string 41 + let puterr = Loc.Error.puterr 42 + let disable_ansi_styler = Fmt.disable_ansi_styler 43 + let pp_kind = Fmt.code 44 + let pp_kind_opt ppf kind = if kind = "" then () else pp_kind ppf kind 45 + let pp_int ppf i = Fmt.code ppf (Int.to_string i) 46 + 47 + let expected meta exp ~fnd = 48 + msgf meta "Expected %a but found %a" Fmt.code exp Fmt.code fnd 49 + 50 + let sort meta ~exp ~fnd = raise Context.empty meta (Sort_mismatch { exp; fnd }) 51 + 52 + let kinded_sort meta ~exp ~fnd = 53 + raise Context.empty meta (Kinded_sort_mismatch { exp; fnd }) 54 + 55 + let missing_mems meta ~kinded_sort ~exp ~fnd = 56 + let pp_miss ppf m = 57 + Fmt.pf ppf "@[%a%a@]" Fmt.code m Fmt.similar_mems (m, fnd) 58 + in 59 + match exp with 60 + | [ n ] -> 61 + msgf meta "@[<v>Missing member %a in %a%a@]" Fmt.code n Fmt.code 62 + kinded_sort Fmt.similar_mems (n, fnd) 63 + | exp -> 64 + msgf meta "@[<v1>Missing members in %a:@,%a@]" Fmt.code kinded_sort 65 + (Fmt.list pp_miss) exp 66 + 67 + let unexpected_mems meta ~kinded_sort ~exp ~fnd = 68 + let pp_unexp ppf m = 69 + Fmt.pf ppf " @[%a%a@]" Fmt.code m Fmt.should_it_be_mem (m, exp) 70 + in 71 + match fnd with 72 + | [ (u, _) ] -> 73 + msgf meta "@[<v>Unexpected member %a for %a%a@]" Fmt.code u Fmt.code 74 + kinded_sort Fmt.should_it_be_mem (u, exp) 75 + | us -> 76 + msgf meta "@[<v1>Unexpected members for %a:@,%a@]" Fmt.code kinded_sort 77 + (Fmt.list pp_unexp) (List.map fst us) 78 + 79 + let unexpected_case_tag meta ~kinded_sort ~mem_name ~exp ~fnd = 80 + let pp_kind ppf () = 81 + Fmt.pf ppf "member %a value in %a" Fmt.code mem_name Fmt.code kinded_sort 82 + in 83 + msgf meta "@[%a@]" (Fmt.out_of_dom ~pp_kind ()) (fnd, exp) 84 + 85 + let index_out_of_range meta ~n ~len = 86 + msgf meta "Index %a out of range [%a;%a]" pp_int n pp_int 0 pp_int (len - 1) 87 + 88 + let number_range meta ~kind n = 89 + msgf meta "Number %a not in %a range" Fmt.code 90 + (Fmt.str "%a" Fmt.json_number n) 91 + Fmt.code kind 92 + 93 + let parse_string_number meta ~kind s = 94 + msgf meta "String %a does not parse to %a value" Fmt.json_string s pp_kind 95 + kind 96 + 97 + let integer_range meta ~kind n = 98 + msgf meta "Integer %a not in %a range" pp_int n pp_kind kind 99 + 100 + let no_decoder meta ~kind = msgf meta "No decoder for %a" pp_kind kind 101 + let no_encoder meta ~kind = msgf meta "No encoder for %a" pp_kind kind 102 + let decode_todo meta ~kind_opt:k = msgf meta "TODO: decode%a" pp_kind_opt k 103 + let encode_todo meta ~kind_opt:k = msgf meta "TODO: encode%a" pp_kind_opt k 104 + let for' meta ~kind e = msgf meta "%a: %s" pp_kind kind e

+78

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. *) 3 + 4 + module Sort = Core.Sort 5 + 6 + type kind = Loc.Error.kind = .. 7 + 8 + type Loc.Error.kind += 9 + | Sort_mismatch of { exp : Sort.t; fnd : Sort.t } 10 + | Kinded_sort_mismatch of { exp : string; fnd : Sort.t } 11 + 12 + val kind_to_string : kind -> string 13 + 14 + type t = Loc.Error.t 15 + 16 + module Context = Loc.Error.Context 17 + 18 + val v : Context.t -> Loc.Meta.t -> kind -> t 19 + val msg : Context.t -> Loc.Meta.t -> string -> t 20 + val raise : Context.t -> Loc.Meta.t -> kind -> 'a 21 + val fail : Loc.Meta.t -> string -> 'a 22 + val failf : Loc.Meta.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a 23 + val msgf : Loc.Meta.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a 24 + val push_array : string Loc.node -> int Loc.node -> t -> 'a 25 + val push_object : string Loc.node -> string Loc.node -> t -> 'a 26 + 27 + val adjust_context : 28 + first_byte:Loc.byte_pos -> 29 + first_line_num:Loc.line_num -> 30 + first_line_byte:Loc.byte_pos -> 31 + t -> 32 + 'a 33 + 34 + val pp : t Fmt.t 35 + val to_string : t -> string 36 + val puterr : unit Fmt.t 37 + val disable_ansi_styler : unit -> unit 38 + val pp_kind : string Fmt.t 39 + val pp_kind_opt : string Fmt.t 40 + val pp_int : int Fmt.t 41 + 42 + (** {1:helpers High-level helpers} *) 43 + 44 + val expected : Loc.Meta.t -> string -> fnd:string -> 'a 45 + 46 + val sort : Loc.Meta.t -> exp:Sort.t -> fnd:Sort.t -> 'a 47 + (** Raises [Sort_mismatch]. *) 48 + 49 + val kinded_sort : Loc.Meta.t -> exp:string -> fnd:Sort.t -> 'a 50 + (** Raises [Kinded_sort_mismatch]. *) 51 + 52 + val missing_mems : 53 + Loc.Meta.t -> kinded_sort:string -> exp:string list -> fnd:string list -> 'a 54 + 55 + val unexpected_mems : 56 + Loc.Meta.t -> 57 + kinded_sort:string -> 58 + exp:string list -> 59 + fnd:(string * Loc.Meta.t) list -> 60 + 'a 61 + 62 + val unexpected_case_tag : 63 + Loc.Meta.t -> 64 + kinded_sort:string -> 65 + mem_name:string -> 66 + exp:string list -> 67 + fnd:string -> 68 + 'a 69 + 70 + val index_out_of_range : Loc.Meta.t -> n:int -> len:int -> 'a 71 + val number_range : Loc.Meta.t -> kind:string -> float -> 'a 72 + val parse_string_number : Loc.Meta.t -> kind:string -> string -> 'a 73 + val integer_range : Loc.Meta.t -> kind:string -> int -> 'a 74 + val no_decoder : Loc.Meta.t -> kind:string -> 'a 75 + val no_encoder : Loc.Meta.t -> kind:string -> 'a 76 + val decode_todo : Loc.Meta.t -> kind_opt:string -> 'a 77 + val encode_todo : Loc.Meta.t -> kind_opt:string -> 'a 78 + val for' : Loc.Meta.t -> kind:string -> string -> 'a

+87 -562

lib/json.ml

··· 5 5 6 6 module Fmt = Core.Fmt 7 7 8 - 9 8 let pp_kind = Fmt.code 10 9 let pp_kind_opt ppf kind = if kind = "" then () else pp_kind ppf kind 11 10 let pp_name = Fmt.code ··· 21 20 22 21 exception Error = Loc.Error 23 22 24 - (* Json-specific typed error kinds. Registered with Loc.Error's printer 25 - registry so [Loc.Error.kind_to_string] formats them correctly. *) 26 - 27 - type Loc.Error.kind += 28 - | Sort_mismatch of { exp : Sort.t; fnd : Sort.t } 29 - | Kinded_sort_mismatch of { exp : string; fnd : Sort.t } 30 - 31 - let () = 32 - Loc.Error.register_kind_printer (function 33 - | Sort_mismatch { exp; fnd } -> 34 - Some 35 - (fun ppf -> 36 - Fmt.pf ppf "Expected %a but found %a" Sort.pp exp Sort.pp fnd) 37 - | Kinded_sort_mismatch { exp; fnd } -> 38 - Some 39 - (fun ppf -> 40 - Fmt.pf ppf "Expected %a but found %a" Fmt.code exp Sort.pp fnd) 41 - | _ -> None) 42 - 43 - module Error = struct 44 - type kind = Loc.Error.kind = .. 45 - type t = Loc.Error.t 46 - 47 - module Context = Loc.Error.Context 48 - 49 - let kind_to_string = Loc.Error.kind_to_string 50 - let v = Loc.Error.v 51 - let msg = Loc.Error.msg 52 - let raise = Loc.Error.raise 53 - let fail = Loc.Error.fail 54 - let failf = Loc.Error.failf 55 - let msgf = Loc.Error.failf (* legacy alias used internally *) 56 - let make_msg ctx meta s = Loc.Error.v ctx meta (Loc.Error.Msg s) 57 - (* legacy alias: construct from string *) 58 - 59 - let push_array = Loc.Error.push_array 60 - let push_object = Loc.Error.push_object 61 - let adjust_context = Loc.Error.adjust_context 62 - let pp = Loc.Error.pp 63 - let to_string = Loc.Error.to_string 64 - let puterr = Loc.Error.puterr 65 - let disable_ansi_styler = Fmt.disable_ansi_styler 66 - 67 - (* Predefined errors *) 68 - 69 - let expected meta exp ~fnd = 70 - msgf meta "Expected %a but found %a" Fmt.code exp Fmt.code fnd 71 - 72 - let sort meta ~exp ~fnd = 73 - raise Context.empty meta (Sort_mismatch { exp; fnd }) 74 - 75 - let kinded_sort meta ~exp ~fnd = 76 - raise Context.empty meta (Kinded_sort_mismatch { exp; fnd }) 77 - 78 - let missing_mems meta ~kinded_sort ~exp ~fnd = 79 - let pp_miss ppf m = 80 - Fmt.pf ppf "@[%a%a@]" Fmt.code m Fmt.similar_mems (m, fnd) 81 - in 82 - match exp with 83 - | [ n ] -> 84 - msgf meta "@[<v>Missing member %a in %a%a@]" Fmt.code n Fmt.code 85 - kinded_sort Fmt.similar_mems (n, fnd) 86 - | exp -> 87 - msgf meta "@[<v1>Missing members in %a:@,%a@]" Fmt.code kinded_sort 88 - (Fmt.list pp_miss) exp 89 - 90 - let unexpected_mems meta ~kinded_sort ~exp ~fnd = 91 - let pp_unexp ppf m = 92 - Fmt.pf ppf " @[%a%a@]" Fmt.code m Fmt.should_it_be_mem (m, exp) 93 - in 94 - match fnd with 95 - | [ (u, _) ] -> 96 - msgf meta "@[<v>Unexpected member %a for %a%a@]" Fmt.code u Fmt.code 97 - kinded_sort Fmt.should_it_be_mem (u, exp) 98 - | us -> 99 - msgf meta "@[<v1>Unexpected members for %a:@,%a@]" Fmt.code kinded_sort 100 - (Fmt.list pp_unexp) (List.map fst us) 101 - 102 - let unexpected_case_tag meta ~kinded_sort ~mem_name ~exp ~fnd = 103 - let pp_kind ppf () = 104 - Fmt.pf ppf "member %a value in %a" Fmt.code mem_name Fmt.code kinded_sort 105 - in 106 - msgf meta "@[%a@]" (Fmt.out_of_dom ~pp_kind ()) (fnd, exp) 107 - 108 - (* Numbers *) 109 - 110 - let index_out_of_range meta ~n ~len = 111 - msgf meta "Index %a out of range [%a;%a]" pp_int n pp_int 0 pp_int (len - 1) 112 - 113 - let number_range meta ~kind n = 114 - msgf meta "Number %a not in %a range" Fmt.code 115 - (Fmt.str "%a" Fmt.json_number n) 116 - Fmt.code kind 117 - 118 - let parse_string_number meta ~kind s = 119 - msgf meta "String %a does not parse to %a value" Fmt.json_string s pp_kind 120 - kind 121 - 122 - let integer_range meta ~kind n = 123 - msgf meta "Integer %a not in %a range" pp_int n pp_kind kind 124 - 125 - (* Maps *) 126 - 127 - let no_decoder meta ~kind = msgf meta "No decoder for %a" pp_kind kind 128 - let no_encoder meta ~kind = msgf meta "No encoder for %a" pp_kind kind 129 - let decode_todo meta ~kind_opt:k = msgf meta "TODO: decode%a" pp_kind_opt k 130 - let encode_todo meta ~kind_opt:k = msgf meta "TODO: encode%a" pp_kind_opt k 131 - let for' meta ~kind e = msgf meta "%a: %s" pp_kind kind e 132 - end 23 + module Error = Error 133 24 134 25 (* Types *) 135 26 136 - module Repr = struct 137 - (* See the .mli for documentation *) 138 - module String_map = Map.Make (String) 27 + type 'a codec = 'a Codec.t 139 28 140 - type ('ret, 'f) dec_fun = 141 - | Dec_fun : 'f -> ('ret, 'f) dec_fun 142 - | Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun 143 - 144 - type ('a, 'b) base_map = { 145 - kind : string; 146 - doc : string; 147 - dec : Meta.t -> 'a -> 'b; 148 - enc : 'b -> 'a; 149 - enc_meta : 'b -> Meta.t; 150 - } 151 - 152 - type 'a t = 153 - | Null : (unit, 'a) base_map -> 'a t 154 - | Bool : (bool, 'a) base_map -> 'a t 155 - | Number : (float, 'a) base_map -> 'a t 156 - | String : (string, 'a) base_map -> 'a t 157 - | Array : ('a, 'elt, 'builder) array_map -> 'a t 158 - | Object : ('o, 'o) object_map -> 'o t 159 - | Any : 'a any_map -> 'a t 160 - | Map : ('a, 'b) map -> 'b t 161 - | Rec : 'a t Lazy.t -> 'a t 162 - | Ignore : unit t 163 - (** Skip-parse any JSON value without materialising its contents. The 164 - bytesrw decoder dispatches to [skip_json_value], which advances past 165 - the value at the byte level (balancing brackets, skipping string 166 - content without decoding escapes, consuming numeric digits without 167 - [float_of_string]). Avoids the token-accumulation and allocation 168 - costs of the generic codec dispatch when the caller only needs to 169 - discard the value. *) 170 - 171 - and ('array, 'elt, 'builder) array_map = { 172 - kind : string; 173 - doc : string; 174 - elt : 'elt t; 175 - dec_empty : unit -> 'builder; 176 - dec_skip : int -> 'builder -> bool; 177 - dec_add : int -> 'elt -> 'builder -> 'builder; 178 - dec_finish : Meta.t -> int -> 'builder -> 'array; 179 - enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; 180 - enc_meta : 'array -> Meta.t; 181 - } 182 - 183 - and ('o, 'dec) object_map = { 184 - kind : string; 185 - doc : string; 186 - dec : ('o, 'dec) dec_fun; 187 - mem_decs : mem_dec String_map.t; 188 - mem_encs : 'o mem_enc list; 189 - enc_meta : 'o -> Meta.t; 190 - shape : 'o object_shape; 191 - } 192 - 193 - and mem_dec = Mem_dec : ('o, 'a) mem_map -> mem_dec 194 - and 'o mem_enc = Mem_enc : ('o, 'a) mem_map -> 'o mem_enc 195 - 196 - and ('o, 'a) mem_map = { 197 - name : string; 198 - doc : string; 199 - type' : 'a t; 200 - id : 'a Type.Id.t; 201 - dec_absent : 'a option; 202 - enc : 'o -> 'a; 203 - (* enc_name_meta : 'a -> Meta.t; See comment in .mli *) 204 - enc_omit : 'a -> bool; 205 - } 206 - 207 - and 'o object_shape = 208 - | Object_basic : ('o, 'mems, 'builder) unknown_mems -> 'o object_shape 209 - | Object_cases : 210 - ('o, 'mems, 'builder) unknown_mems option 211 - * ('o, 'cases, 'tag) object_cases 212 - -> 'o object_shape 213 - 214 - and ('o, 'mems, 'builder) unknown_mems = 215 - | Unknown_skip : ('o, unit, unit) unknown_mems 216 - | Unknown_error : ('o, unit, unit) unknown_mems 217 - | Unknown_keep : 218 - ('mems, 'a, 'builder) mems_map * ('o -> 'mems) 219 - -> ('o, 'mems, 'builder) unknown_mems 220 - 221 - and ('mems, 'a, 'builder) mems_map = { 222 - kind : string; 223 - doc : string; 224 - mems_type : 'a t; 225 - id : 'mems Type.Id.t; 226 - dec_empty : unit -> 'builder; 227 - dec_add : Meta.t -> string -> 'a -> 'builder -> 'builder; 228 - dec_finish : Meta.t -> 'builder -> 'mems; 229 - enc : 230 - 'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc; 231 - } 232 - 233 - and ('o, 'cases, 'tag) object_cases = { 234 - tag : ('tag, 'tag) mem_map; 235 - tag_compare : 'tag -> 'tag -> int; 236 - tag_to_string : ('tag -> string) option; 237 - id : 'cases Type.Id.t; 238 - cases : ('cases, 'tag) case list; 239 - enc : 'o -> 'cases; 240 - enc_case : 'cases -> ('cases, 'tag) case_value; 241 - } 242 - 243 - and ('cases, 'case, 'tag) case_map = { 244 - tag : 'tag; 245 - object_map : ('case, 'case) object_map; 246 - dec : 'case -> 'cases; 247 - } 248 - 249 - and ('cases, 'tag) case_value = 250 - | Case_value : 251 - ('cases, 'case, 'tag) case_map * 'case 252 - -> ('cases, 'tag) case_value 253 - 254 - and ('cases, 'tag) case = 255 - | Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case 256 - 257 - and 'a any_map = { 258 - kind : string; 259 - doc : string; 260 - dec_null : 'a t option; 261 - dec_bool : 'a t option; 262 - dec_number : 'a t option; 263 - dec_string : 'a t option; 264 - dec_array : 'a t option; 265 - dec_object : 'a t option; 266 - enc : 'a -> 'a t; 267 - } 268 - 269 - and ('a, 'b) map = { 270 - kind : string; 271 - doc : string; 272 - dom : 'a t; 273 - dec : 'a -> 'b; 274 - enc : 'b -> 'a; 275 - } 276 - 277 - (* Convert *) 278 - 279 - let of_t = Fun.id 280 - let unsafe_to_t = Fun.id 281 - 282 - (* Kinds and doc *) 283 - 284 - let base_map_with_doc ?kind ?doc (map : ('a, 'b) base_map) = 285 - let kind = Option.value ~default:map.kind doc in 286 - let doc = Option.value ~default:map.doc doc in 287 - { map with kind; doc } 288 - 289 - let array_map_with_doc ?kind ?doc (map : ('a, 'b, 'c) array_map) = 290 - let kind = Option.value ~default:map.kind doc in 291 - let doc = Option.value ~default:map.doc doc in 292 - { map with kind; doc } 293 - 294 - let object_map_with_doc ?kind ?doc (map : ('o, 'o) object_map) = 295 - let kind = Option.value ~default:map.kind doc in 296 - let doc = Option.value ~default:map.doc doc in 297 - { map with kind; doc } 298 - 299 - let any_map_with_doc ?kind ?doc (map : 'a any_map) = 300 - let kind = Option.value ~default:map.kind doc in 301 - let doc = Option.value ~default:map.doc doc in 302 - { map with kind; doc } 303 - 304 - let map_with_doc ?kind ?doc (map : ('a, 'b) map) = 305 - let kind = Option.value ~default:map.kind doc in 306 - let doc = Option.value ~default:map.doc doc in 307 - { map with kind; doc } 308 - 309 - let rec with_doc : type a. ?kind:string -> ?doc:string -> a t -> a t = 310 - fun ?kind ?doc -> function 311 - | Null map -> Null (base_map_with_doc ?kind ?doc map) 312 - | Bool map -> Bool (base_map_with_doc ?kind ?doc map) 313 - | Number map -> Number (base_map_with_doc ?kind ?doc map) 314 - | String map -> String (base_map_with_doc ?kind ?doc map) 315 - | Array map -> Array (array_map_with_doc ?kind ?doc map) 316 - | Object map -> Object (object_map_with_doc ?kind ?doc map) 317 - | Any map -> Any (any_map_with_doc ?kind ?doc map) 318 - | Map map -> Map (map_with_doc ?kind ?doc map) 319 - | Rec l -> with_doc ?kind ?doc (Lazy.force l) 320 - | Ignore -> Ignore 321 - 322 - let object_map_kinded_sort (map : ('o, 'dec) object_map) = 323 - Sort.kinded ~kind:map.kind Object 324 - 325 - let rec kinded_sort : type a. a t -> string = function 326 - | Null map -> Sort.kinded ~kind:map.kind Null 327 - | Bool map -> Sort.kinded ~kind:map.kind Bool 328 - | Number map -> Sort.kinded ~kind:map.kind Number 329 - | String map -> Sort.kinded ~kind:map.kind String 330 - | Array map -> array_map_kinded_sort map 331 - | Object map -> object_map_kinded_sort map 332 - | Any map -> if map.kind = "" then any_map_kinded_sort map else map.kind 333 - | Map map -> if map.kind = "" then kinded_sort map.dom else map.kind 334 - | Rec l -> kinded_sort (Lazy.force l) 335 - | Ignore -> "ignore" 336 - 337 - and array_map_kinded_sort : type a e b. (a, e, b) array_map -> string = 338 - fun map -> 339 - if map.kind <> "" then Sort.kinded ~kind:map.kind Array 340 - else 341 - let elt = kinded_sort map.elt in 342 - String.concat "" [ "array<"; elt; ">" ] 343 - 344 - and any_map_kinded_sort : type a. a any_map -> string = 345 - fun map -> 346 - let add_case ks sort = function 347 - | None -> ks 348 - | Some k -> 349 - (if map.kind <> "" then kinded_sort k 350 - else Sort.kinded ~kind:map.kind sort) 351 - :: ks 352 - in 353 - let ks = add_case [] Object map.dec_object in 354 - let ks = add_case ks Array map.dec_array in 355 - let ks = add_case ks String map.dec_string in 356 - let ks = add_case ks Number map.dec_number in 357 - let ks = add_case ks Bool map.dec_bool in 358 - let ks = add_case ks Null map.dec_null in 359 - "one of " ^ String.concat ", " ks 360 - 361 - let rec kind : type a. a t -> string = function 362 - | Null map -> Sort.or_kind ~kind:map.kind Null 363 - | Bool map -> Sort.or_kind ~kind:map.kind Bool 364 - | Number map -> Sort.or_kind ~kind:map.kind Number 365 - | String map -> Sort.or_kind ~kind:map.kind String 366 - | Array map -> Sort.or_kind ~kind:map.kind Array 367 - | Object map -> Sort.or_kind ~kind:map.kind Object 368 - | Any map -> if map.kind <> "" then map.kind else "any" 369 - | Map map -> if map.kind <> "" then map.kind else kind map.dom 370 - | Rec l -> kind (Lazy.force l) 371 - | Ignore -> "ignore" 372 - 373 - let rec doc : type a. a t -> string = function 374 - | Null map -> map.doc 375 - | Bool map -> map.doc 376 - | Number map -> map.doc 377 - | String map -> map.doc 378 - | Array map -> map.doc 379 - | Object map -> map.doc 380 - | Any map -> map.doc 381 - | Map map -> map.doc 382 - | Rec l -> doc (Lazy.force l) 383 - | Ignore -> "" 384 - 385 - (* Errors *) 386 - 387 - let pp_code = Fmt.code 388 - let pp_kind = pp_kind 389 - 390 - let error_push_object meta map name e = 391 - Error.push_object (object_map_kinded_sort map, meta) name e 392 - 393 - let error_push_array meta map i e = 394 - Error.push_array (array_map_kinded_sort map, meta) i e 395 - 396 - let type_error meta t ~fnd = Error.kinded_sort meta ~exp:(kinded_sort t) ~fnd 397 - 398 - let missing_mems_error meta (object_map : ('o, 'o) object_map) ~exp ~fnd = 399 - let kinded_sort = object_map_kinded_sort object_map in 400 - let exp = 401 - let add n (Mem_dec m) acc = 402 - match m.dec_absent with None -> n :: acc | Some _ -> acc 403 - in 404 - List.rev (String_map.fold add exp []) 405 - in 406 - Error.missing_mems meta ~kinded_sort ~exp ~fnd 407 - 408 - let unexpected_mems_error meta (object_map : ('o, 'o) object_map) ~fnd = 409 - let kinded_sort = object_map_kinded_sort object_map in 410 - let exp = List.map (fun (Mem_enc m) -> m.name) object_map.mem_encs in 411 - Error.unexpected_mems meta ~kinded_sort ~exp ~fnd 412 - 413 - let unexpected_case_tag_error meta object_map object_cases tag = 414 - let kinded_sort = object_map_kinded_sort object_map in 415 - let case_to_string (Case c) = 416 - match object_cases.tag_to_string with 417 - | None -> None 418 - | Some str -> Some (str c.tag) 419 - in 420 - let exp = List.filter_map case_to_string object_cases.cases in 421 - let fnd = 422 - match object_cases.tag_to_string with 423 - | None -> "<tag>" (* XXX not good *) 424 - | Some str -> str tag 425 - in 426 - let mem_name = object_cases.tag.name in 427 - Error.unexpected_case_tag meta ~kinded_sort ~mem_name ~exp ~fnd 428 - 429 - (* Processor toolbox *) 430 - 431 - let object_meta_arg : Meta.t Type.Id.t = Type.Id.make () 432 - 433 - module Dict = struct 434 - module M = Map.Make (Int) 435 - 436 - type binding = B : 'a Type.Id.t * 'a -> binding 437 - type t = binding M.t 438 - 439 - let empty = M.empty 440 - let mem k m = M.mem (Type.Id.uid k) m 441 - let add k v m = M.add (Type.Id.uid k) (B (k, v)) m 442 - let remove k m = M.remove (Type.Id.uid k) m 443 - 444 - let find : type a. a Type.Id.t -> t -> a option = 445 - fun k m -> 446 - match M.find_opt (Type.Id.uid k) m with 447 - | None -> None 448 - | Some (B (k', v)) -> ( 449 - match Type.Id.provably_equal k k' with 450 - | Some Type.Equal -> Some v 451 - | None -> assert false) 452 - end 453 - 454 - let rec apply_dict : type ret f. (ret, f) dec_fun -> Dict.t -> f = 455 - fun dec dict -> 456 - match dec with 457 - | Dec_fun f -> f 458 - | Dec_app (f, arg) -> (apply_dict f dict) (Option.get (Dict.find arg dict)) 459 - 460 - type unknown_mems_option = 461 - | Unknown_mems : 462 - ('o, 'mems, 'builder) unknown_mems option 463 - -> unknown_mems_option 464 - 465 - let override_unknown_mems ~by umems dict = 466 - match by with 467 - | Unknown_mems None -> (umems, dict) 468 - | Unknown_mems _ as by -> ( 469 - match umems with 470 - | Unknown_mems (Some (Unknown_keep (umap, _))) -> 471 - (* A decoding function still expect [umap.id] argument in 472 - an Dec_app, we simply stub it with the empty map. *) 473 - let empty = umap.dec_finish Meta.none (umap.dec_empty ()) in 474 - let dict = Dict.add umap.id empty dict in 475 - (by, dict) 476 - | _ -> (by, dict)) 477 - 478 - let finish_object_decode : type o p m mems builder. 479 - (o, o) object_map -> 480 - Meta.t -> 481 - (p, mems, builder) unknown_mems -> 482 - builder -> 483 - mem_dec String_map.t -> 484 - Dict.t -> 485 - Dict.t = 486 - fun map meta umems umap mem_decs dict -> 487 - let dict = Dict.add object_meta_arg meta dict in 488 - let dict = 489 - match umems with 490 - | Unknown_skip | Unknown_error -> dict 491 - | Unknown_keep (map, _) -> Dict.add map.id (map.dec_finish meta umap) dict 492 - in 493 - let add_default _ (Mem_dec mem_map) dict = 494 - match mem_map.dec_absent with 495 - | Some v -> Dict.add mem_map.id v dict 496 - | None -> raise Exit 497 - in 498 - try String_map.fold add_default mem_decs dict 499 - with Exit -> 500 - let no_default _ (Mem_dec mm) = Option.is_none mm.dec_absent in 501 - let exp = String_map.filter no_default mem_decs in 502 - missing_mems_error meta map ~exp ~fnd:[] 503 - end 504 - 505 - (* Types *) 506 - 507 - type 'a codec = 'a Repr.t 508 - 509 - let kinded_sort = Repr.kinded_sort 510 - let kind = Repr.kind 511 - let doc = Repr.doc 512 - let with_doc = Repr.with_doc 29 + let kinded_sort = Codec.kinded_sort 30 + let kind = Codec.kind 31 + let doc = Codec.doc 32 + let with_doc = Codec.with_doc 513 33 514 34 (* Base types *) 515 35 516 36 let enc_meta_none _v = Meta.none 517 37 518 38 module Base = struct 519 - type ('a, 'b) map = ('a, 'b) Repr.base_map 39 + type ('a, 'b) map = ('a, 'b) Codec.base_map 520 40 521 41 let base_map_sort = "base map" 522 42 ··· 535 55 let kind = Sort.kinded' ~kind base_map_sort in 536 56 fun _v -> Error.no_encoder Meta.none ~kind 537 57 in 538 - { Repr.kind; doc; dec; enc; enc_meta } 58 + { Codec.kind; doc; dec; enc; enc_meta } 539 59 540 60 let id = 541 61 let dec _meta v = v and enc = Fun.id in 542 - { Repr.kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none } 62 + { Codec.kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none } 543 63 544 64 let ignore = 545 65 let kind = "ignore" in ··· 548 68 let kind = Sort.kinded' ~kind base_map_sort in 549 69 Error.no_encoder Meta.none ~kind 550 70 in 551 - { Repr.kind; doc = ""; dec; enc; enc_meta = enc_meta_none } 71 + { Codec.kind; doc = ""; dec; enc; enc_meta = enc_meta_none } 552 72 553 - let null map = Repr.Null map 554 - let bool map = Repr.Bool map 555 - let number map = Repr.Number map 556 - let string map = Repr.String map 73 + let null map = Codec.Null map 74 + let bool map = Codec.Bool map 75 + let number map = Codec.Number map 76 + let string map = Codec.String map 557 77 let dec dec = fun _meta v -> dec v 558 78 559 79 let dec_result ?(kind = "") dec = ··· 588 108 let kind = Sort.kinded' ~kind "any" in 589 109 fun _v -> Error.no_encoder Meta.none ~kind 590 110 in 591 - Repr.Any 111 + Codec.Any 592 112 { 593 113 kind; 594 114 doc; ··· 619 139 let kind = Sort.kinded' ~kind map_sort in 620 140 fun _v -> Error.no_encoder Meta.none ~kind 621 141 in 622 - Repr.Map { kind; doc; dom; dec; enc } 142 + Codec.Map { kind; doc; dom; dec; enc } 623 143 624 144 let iter ?(kind = "") ?(doc = "") ?dec ?enc dom = 625 145 let dec = ··· 638 158 enc v; 639 159 v 640 160 in 641 - Repr.Map { kind; doc; dom; dec; enc } 161 + Codec.Map { kind; doc; dom; dec; enc } 642 162 643 - let rec' t = Repr.Rec t 163 + let rec' t = Codec.Rec t 644 164 645 165 (* Nulls and options *) 646 166 647 167 let null ?kind ?doc v = 648 168 let dec _meta () = v and enc _meta = () in 649 - Repr.Null (Base.map ?doc ?kind ~dec ~enc ()) 169 + Codec.Null (Base.map ?doc ?kind ~dec ~enc ()) 650 170 651 171 let none = 652 172 let none = 653 173 (* Can't use [Base.map] because of the value restriction. *) 654 174 let dec _meta _v = None and enc _ = () in 655 - { Repr.kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none } 175 + { Codec.kind = ""; doc = ""; dec; enc; enc_meta = enc_meta_none } 656 176 in 657 - Repr.Null none 177 + Codec.Null none 658 178 659 179 let some t = map ~dec:Option.some ~enc:Option.get t 660 180 661 - let option : type a. ?kind:string -> ?doc:string -> a Repr.t -> a option Repr.t 662 - = 181 + let option : type a. 182 + ?kind:string -> ?doc:string -> a Codec.t -> a option Codec.t = 663 183 fun ?kind ?doc t -> 664 184 let some = some t in 665 185 let enc = function None -> none | Some _ -> some in ··· 676 196 677 197 (* Booleans *) 678 198 679 - let bool = Repr.Bool Base.id 199 + let bool = Codec.Bool Base.id 680 200 681 201 (* Numbers *) 682 202 ··· 684 204 if Float.is_finite v then () 685 205 else Error.kinded_sort meta ~exp:(Sort.kinded ~kind Number) ~fnd:Sort.Null 686 206 687 - let number = Repr.Number Base.id 207 + let number = Codec.Number Base.id 688 208 689 209 let any_float = 690 210 let kind = "float" in ··· 830 350 831 351 (* String and enums *) 832 352 833 - let string = Repr.String Base.id 353 + let string = Codec.String Base.id 834 354 835 355 let of_of_string ?kind ?doc ?enc of_string = 836 356 let dec = Base.dec_result ?kind of_string in ··· 840 360 let enum (type a) ?(cmp = Stdlib.compare) ?(kind = "") ?doc assoc = 841 361 let kind = Sort.kinded' ~kind "enum" in 842 362 let dec_map = 843 - let add m (k, v) = Repr.String_map.add k v m in 844 - let m = List.fold_left add Repr.String_map.empty assoc in 845 - fun k -> Repr.String_map.find_opt k m 363 + let add m (k, v) = Codec.String_map.add k v m in 364 + let m = List.fold_left add Codec.String_map.empty assoc in 365 + fun k -> Codec.String_map.find_opt k m 846 366 in 847 367 let enc_map = 848 368 let module M = Map.Make (struct ··· 859 379 | Some v -> v 860 380 | None -> 861 381 let kind = Sort.kinded ~kind String in 862 - let pp_kind ppf () = Fmt.pf ppf "%a value" Repr.pp_kind kind in 382 + let pp_kind ppf () = Fmt.pf ppf "%a value" Codec.pp_kind kind in 863 383 Error.msgf meta "%a" (Fmt.out_of_dom ~pp_kind ()) (s, List.map fst assoc) 864 384 in 865 385 let enc v = 866 386 match enc_map v with 867 387 | Some s -> s 868 388 | None -> 869 - Error.msgf Meta.none "Encode %a: unknown enum value" Repr.pp_kind kind 389 + Error.msgf Meta.none "Encode %a: unknown enum value" Codec.pp_kind kind 870 390 in 871 391 Base.string (Base.map ~kind ?doc ~dec ~enc ()) 872 392 ··· 880 400 (* Arrays and tuples *) 881 401 882 402 module Array = struct 883 - type ('array, 'elt, 'builder) map = ('array, 'elt, 'builder) Repr.array_map 403 + type ('array, 'elt, 'builder) map = ('array, 'elt, 'builder) Codec.array_map 884 404 885 405 type ('array, 'elt) enc = { 886 406 enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; ··· 913 433 | None -> fun _ _ _ -> Error.no_encoder Meta.none ~kind:(array_kind kind) 914 434 in 915 435 { 916 - Repr.kind; 436 + Codec.kind; 917 437 doc; 918 438 elt; 919 439 dec_empty; ··· 970 490 let enc = { enc } in 971 491 map ?kind ?doc ~dec_empty ?dec_skip ~dec_add ~dec_finish ~enc elt 972 492 973 - let array map = Repr.Array map 493 + let array map = Codec.Array map 974 494 975 495 let stub_elt = 976 - Repr.Map 496 + Codec.Map 977 497 { 978 498 kind = ""; 979 499 doc = ""; ··· 1000 520 array (map ~kind ~dec_empty ~dec_skip ~dec_add ~dec_finish ~enc stub_elt) 1001 521 end 1002 522 1003 - let list ?kind ?doc t = Repr.Array (Array.list_map ?kind ?doc t) 1004 - let array ?kind ?doc t = Repr.Array (Array.array_map ?kind ?doc t) 523 + let list ?kind ?doc t = Codec.Array (Array.list_map ?kind ?doc t) 524 + let array ?kind ?doc t = Codec.Array (Array.array_map ?kind ?doc t) 1005 525 1006 526 let array_as_string_map ?kind ?doc ~key t = 1007 - let dec_empty () = Repr.String_map.empty in 1008 - let dec_add _i elt acc = Repr.String_map.add (key elt) elt acc in 527 + let dec_empty () = Codec.String_map.empty in 528 + let dec_add _i elt acc = Codec.String_map.add (key elt) elt acc in 1009 529 let dec_finish _meta _len acc = acc in 1010 530 let enc f acc m = 1011 531 let i = ref (-1) in 1012 - Repr.String_map.fold 532 + Codec.String_map.fold 1013 533 (fun _ elt acc -> 1014 534 incr i; 1015 535 f acc !i elt) ··· 1017 537 in 1018 538 let enc = Array.{ enc } in 1019 539 let map = Array.map ?kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t in 1020 - Repr.Array map 540 + Codec.Array map 1021 541 1022 542 let bigarray ?kind ?doc k t = 1023 - Repr.Array (Array.bigarray_map ?kind ?doc k Bigarray.c_layout t) 543 + Codec.Array (Array.bigarray_map ?kind ?doc k Bigarray.c_layout t) 1024 544 1025 545 let tuple_no_decoder ~kind meta = 1026 546 Error.no_decoder meta ~kind:(Sort.kinded' ~kind "tuple") ··· 1052 572 | Some enc -> fun f acc v -> f (f acc 0 (enc v 0)) 1 (enc v 1) 1053 573 in 1054 574 let enc = { Array.enc } in 1055 - Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 575 + Codec.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 1056 576 1057 577 let t3 ?(kind = "") ?doc ?dec ?enc t = 1058 578 let size = 3 in ··· 1074 594 fun f acc v -> f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2) 1075 595 in 1076 596 let enc = { Array.enc } in 1077 - Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 597 + Codec.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 1078 598 1079 599 let t4 ?(kind = "") ?doc ?dec ?enc t = 1080 600 let size = 4 in ··· 1097 617 f (f (f (f acc 0 (enc v 0)) 1 (enc v 1)) 2 (enc v 2)) 3 (enc v 3) 1098 618 in 1099 619 let enc = { Array.enc } in 1100 - Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 620 + Codec.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc t) 1101 621 1102 622 let tn ?(kind = "") ?doc ~n elt = 1103 623 let dec_empty () = Core.Rarray.empty () in ··· 1108 628 else Core.Rarray.to_array a 1109 629 in 1110 630 let enc = { Array.enc = Array.array_enc } in 1111 - Repr.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc elt) 631 + Codec.Array (Array.map ~kind ?doc ~dec_empty ~dec_add ~dec_finish ~enc elt) 1112 632 1113 633 (* Objects *) 1114 634 1115 635 module Object = struct 1116 - open Repr 636 + open Codec 1117 637 1118 638 (* Maps *) 1119 639 ··· 1179 699 (* Members *) 1180 700 1181 701 module Mem = struct 1182 - type ('o, 'a) map = ('o, 'a) Repr.mem_map 702 + type ('o, 'a) map = ('o, 'a) Codec.mem_map 1183 703 1184 704 let no_enc name = 1185 705 fun _v -> Error.msgf Meta.none "No encoder for member %a" pp_code name ··· 1355 875 1356 876 (* Ignoring 1357 877 1358 - [ignore] uses the dedicated [Repr.Ignore] constructor so the bytesrw 878 + [ignore] uses the dedicated [Codec.Ignore] constructor so the bytesrw 1359 879 decoder can skip-parse the value (no token buffers, no float parsing, 1360 880 no DOM allocation). *) 1361 881 1362 - let ignore : unit codec = Repr.Ignore 882 + let ignore : unit codec = Codec.Ignore 1363 883 1364 884 let zero = 1365 885 let kind = "zero" in 1366 - let null = null () and dec_bool = Repr.Bool Base.ignore in 1367 - let dec_number = Repr.Number Base.ignore in 1368 - let dec_string = Repr.String Base.ignore in 886 + let null = null () and dec_bool = Codec.Bool Base.ignore in 887 + let dec_number = Codec.Number Base.ignore in 888 + let dec_string = Codec.String Base.ignore in 1369 889 let dec_array = Array.ignore and dec_object = Object.zero in 1370 890 let enc () = null in 1371 891 any ~kind ~dec_null:null ~dec_bool ~dec_number ~dec_string ~dec_array ··· 1410 930 (* Generic JSON *) 1411 931 1412 932 module Value = struct 1413 - (* Local AST alias. Inside this module [open Repr] below shadows the 1414 - outer [t] with [Repr.t] (the codec GADT), so we preserve the AST 933 + (* Local AST alias. Inside this module [open Codec] below shadows the 934 + outer [t] with [Codec.t] (the codec GADT), so we preserve the AST 1415 935 type under a name that isn't redefined. *) 1416 936 type json = t 1417 937 type 'a cons = ?meta:Meta.t -> 'a -> json ··· 1542 1062 1543 1063 (* Converting *) 1544 1064 1545 - open Repr 1065 + open Codec 1546 1066 1547 1067 let error_sort ~exp j = Error.sort (meta j) ~exp ~fnd:(sort j) 1548 1068 ··· 1551 1071 1552 1072 let find_all_unexpected ~mem_decs mems = 1553 1073 let unexpected (((n, _) as nm), _v) = 1554 - match Repr.String_map.find_opt n mem_decs with 1074 + match Codec.String_map.find_opt n mem_decs with 1555 1075 | None -> Some nm 1556 1076 | Some _ -> None 1557 1077 in ··· 1559 1079 1560 1080 (* Decoding *) 1561 1081 1562 - let rec decode : type a. a Repr.t -> json -> a = 1082 + let rec decode : type a. a Codec.t -> json -> a = 1563 1083 fun t j -> 1564 1084 match t with 1565 1085 | Null map -> ( ··· 1595 1115 let b = 1596 1116 try 1597 1117 if map.dec_skip i b then b else map.dec_add i (decode map.elt v) b 1598 - with Error e -> Repr.error_push_array meta map (i, get_meta v) e 1118 + with Error e -> Codec.error_push_array meta map (i, get_meta v) e 1599 1119 in 1600 1120 next map meta b (i + 1) vs 1601 1121 in ··· 1625 1145 match map.shape with 1626 1146 | Object_cases (umems', cases) -> 1627 1147 let umems' = Unknown_mems umems' in 1628 - let umems, dict = Repr.override_unknown_mems ~by:umems umems' dict in 1148 + let umems, dict = Codec.override_unknown_mems ~by:umems umems' dict in 1629 1149 decode_object_cases map meta umems cases mem_miss mem_decs dict [] mems 1630 1150 | Object_basic umems' -> ( 1631 1151 let umems' = Unknown_mems (Some umems') in 1632 - let umems, dict = Repr.override_unknown_mems ~by:umems umems' dict in 1152 + let umems, dict = Codec.override_unknown_mems ~by:umems umems' dict in 1633 1153 match umems with 1634 1154 | Unknown_mems (Some Unknown_skip | None) -> 1635 1155 let umems = Unknown_skip in ··· 1651 1171 object' -> 1652 1172 Dict.t = 1653 1173 fun map meta umems umap mem_miss mem_decs dict -> function 1654 - | [] -> Repr.finish_object_decode map meta umems umap mem_miss dict 1174 + | [] -> Codec.finish_object_decode map meta umems umap mem_miss dict 1655 1175 | (((n, nmeta) as nm), v) :: mems -> ( 1656 1176 match String_map.find_opt n mem_decs with 1657 1177 | Some (Mem_dec m) -> 1658 1178 let dict = 1659 1179 try Dict.add m.id (decode m.type' v) dict 1660 - with Error e -> Repr.error_push_object meta map nm e 1180 + with Error e -> Codec.error_push_object meta map nm e 1661 1181 in 1662 1182 let mem_miss = String_map.remove n mem_miss in 1663 1183 decode_object_basic map meta umems umap mem_miss mem_decs dict mems ··· 1668 1188 mems 1669 1189 | Unknown_error -> 1670 1190 let fnd = nm :: find_all_unexpected ~mem_decs mems in 1671 - Repr.unexpected_mems_error meta map ~fnd 1191 + Codec.unexpected_mems_error meta map ~fnd 1672 1192 | Unknown_keep (umap', _) -> 1673 1193 let umap = 1674 1194 try umap'.dec_add nmeta n (decode umap'.mems_type v) umap 1675 - with Error e -> Repr.error_push_object meta map nm e 1195 + with Error e -> Codec.error_push_object meta map nm e 1676 1196 in 1677 1197 decode_object_basic map meta umems umap mem_miss mem_decs dict 1678 1198 mems)) ··· 1692 1212 let decode_case_tag map meta tag delay mems = 1693 1213 let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in 1694 1214 match List.find_opt eq_tag cases.cases with 1695 - | None -> Repr.unexpected_case_tag_error meta map cases tag 1215 + | None -> Codec.unexpected_case_tag_error meta map cases tag 1696 1216 | Some (Case case) -> 1697 1217 let mems = List.rev_append delay mems in 1698 1218 let dict = ··· 1708 1228 match cases.tag.dec_absent with 1709 1229 | Some tag -> decode_case_tag map meta tag delay [] 1710 1230 | None -> 1711 - let kinded_sort = Repr.object_map_kinded_sort map in 1231 + let kinded_sort = Codec.object_map_kinded_sort map in 1712 1232 Error.missing_mems meta ~kinded_sort ~exp:[ cases.tag.name ] 1713 1233 ~fnd:(List.map (fun ((n, _), _) -> n) delay)) 1714 1234 | ((((n, meta) as nm), v) as mem) :: mems -> ( 1715 1235 if n = cases.tag.name then 1716 1236 let tag = 1717 1237 try decode cases.tag.type' v 1718 - with Error e -> Repr.error_push_object meta map nm e 1238 + with Error e -> Codec.error_push_object meta map nm e 1719 1239 in 1720 1240 decode_case_tag map meta tag delay mems 1721 1241 else ··· 1727 1247 | Some (Mem_dec m) -> 1728 1248 let dict = 1729 1249 try Dict.add m.id (decode m.type' v) dict 1730 - with Error e -> Repr.error_push_object meta map nm e 1250 + with Error e -> Codec.error_push_object meta map nm e 1731 1251 in 1732 1252 let mem_miss = String_map.remove n mem_miss in 1733 1253 decode_object_cases map meta umems cases mem_miss mem_decs dict 1734 1254 delay mems) 1735 1255 1736 - and decode_any : type a. a Repr.t -> a any_map -> json -> a = 1256 + and decode_any : type a. a Codec.t -> a any_map -> json -> a = 1737 1257 fun t map j -> 1738 1258 let dec t map j = 1739 1259 match map with Some t -> decode t j | None -> error_type t j ··· 1752 1272 1753 1273 (* Encode *) 1754 1274 1755 - let rec encode : type a. a Repr.t -> a -> json = 1275 + let rec encode : type a. a Codec.t -> a -> json = 1756 1276 fun t v -> 1757 1277 match t with 1758 1278 | Null map -> null ~meta:(map.enc_meta v) (map.enc v) ··· 1762 1282 | Array map -> 1763 1283 let enc map acc i elt = 1764 1284 try encode map.elt elt :: acc 1765 - with Error e -> Repr.error_push_array Meta.none map (i, Meta.none) e 1285 + with Error e -> 1286 + Codec.error_push_array Meta.none map (i, Meta.none) e 1766 1287 in 1767 1288 list ~meta:(map.enc_meta v) (List.rev (map.enc (enc map) [] v)) 1768 1289 | Object map -> ··· 1782 1303 if mmap.enc_omit v then obj 1783 1304 else ((mmap.name, Meta.none), encode mmap.type' v) :: obj 1784 1305 with Error e -> 1785 - Repr.error_push_object Meta.none map (mmap.name, Meta.none) e 1306 + Codec.error_push_object Meta.none map (mmap.name, Meta.none) e 1786 1307 in 1787 1308 let obj = List.fold_left (encode_mem map) obj map.mem_encs in 1788 1309 match map.shape with ··· 1796 1317 try 1797 1318 if cases.tag.enc_omit case.tag then obj 1798 1319 else (n, encode cases.tag.type' case.tag) :: obj 1799 - with Error e -> Repr.error_push_object Meta.none map n e 1320 + with Error e -> Codec.error_push_object Meta.none map n e 1800 1321 in 1801 1322 match u with 1802 1323 | Some (Unknown_keep (umap, enc)) -> ··· 1816 1337 let n = (name, meta) in 1817 1338 let v = 1818 1339 try encode umap.mems_type v 1819 - with Error e -> Repr.error_push_object Meta.none map n e 1340 + with Error e -> Codec.error_push_object Meta.none map n e 1820 1341 in 1821 1342 (n, v) :: obj 1822 1343 in ··· 1839 1360 | Null ((), _) -> () 1840 1361 | j -> Value.error_sort ~exp:Sort.Null j 1841 1362 in 1842 - Repr.Null (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1363 + Codec.Null (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1843 1364 1844 1365 let json_bool = 1845 1366 let dec meta b = Value.bool ~meta b in ··· 1847 1368 | Bool (b, _) -> b 1848 1369 | j -> Value.error_sort ~exp:Sort.Bool j 1849 1370 in 1850 - Repr.Bool (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1371 + Codec.Bool (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1851 1372 1852 1373 let json_number = 1853 1374 let dec meta n = Value.number ~meta n in ··· 1855 1376 | Number (n, _) -> n 1856 1377 | j -> Value.error_sort ~exp:Sort.Number j 1857 1378 in 1858 - Repr.Number (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1379 + Codec.Number (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1859 1380 1860 1381 let json_string = 1861 1382 let dec meta s = Value.string ~meta s in ··· 1863 1384 | String (s, _) -> s 1864 1385 | j -> Value.error_sort ~exp:Sort.String j 1865 1386 in 1866 - Repr.String (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1387 + Codec.String (Base.map ~dec ~enc ~enc_meta:Value.meta ()) 1867 1388 1868 1389 let json, json_array, mem_list, json_object = 1869 - let rec elt = Repr.Rec any 1390 + let rec elt = Codec.Rec any 1870 1391 and array_map = 1871 1392 lazy begin 1872 1393 let dec_empty () = [] in ··· 1916 1437 | Array _ -> json_array 1917 1438 | Object _ -> json_object 1918 1439 in 1919 - Repr.Any 1440 + Codec.Any 1920 1441 { 1921 1442 kind = "json"; 1922 1443 doc = ""; ··· 1968 1489 1969 1490 let update t = 1970 1491 let dec v = Value.update t v in 1971 - Repr.Map { kind = ""; doc = ""; dom = json; dec; enc = Fun.id } 1492 + Codec.Map { kind = ""; doc = ""; dom = json; dec; enc = Fun.id } 1972 1493 1973 1494 (* Array queries *) 1974 1495 ··· 2224 1745 match Value.encode t v with 2225 1746 | Ok j -> pp_json' ?number_format () ppf j 2226 1747 | Error e -> pp_string ppf e 1748 + 1749 + (* Low-level representation *) 1750 + 1751 + module Codec = Codec

+9 -385

lib/json.mli

··· 37 37 (** Sorts of JSON values. *) 38 38 module Sort : sig 39 39 (** The type for sorts of JSON values. *) 40 - type t = 40 + type t = Core.Sort.t = 41 41 | Null (** Nulls *) 42 42 | Bool (** Booleans *) 43 43 | Number (** Numbers *) ··· 72 72 module Error : sig 73 73 (** {1:kinds Kinds of errors} *) 74 74 75 - type kind 75 + type kind = Loc.Error.kind = .. 76 76 (** The type for kind of errors. *) 77 77 78 78 val kind_to_string : kind -> string ··· 125 125 (** [failf meta Fmt.t] is like {!fail} but formats the message. *) 126 126 127 127 val expected : Meta.t -> string -> fnd:string -> 'a 128 - (** [expected meta Fmt.t exp ~fnd] is [msgf "Expected %s but found %s" exp fnd]. 129 - *) 128 + (** [expected meta Fmt.t exp ~fnd] is 129 + [msgf "Expected %s but found %s" exp fnd]. *) 130 130 131 131 val push_array : string node -> int node -> t -> 'a 132 132 (** [push_array kinded_sort n e] contextualises [e] as an error in the [n]th ··· 168 168 169 169 (** {1:types Types} *) 170 170 171 - type 'a codec 171 + type 'a codec = 'a Codec.t 172 172 (** The type for JSON types. 173 173 174 174 A value of this type represents a subset of JSON values mapped to a subset ··· 1368 1368 Uses the {!default_number_format}. *) 1369 1369 1370 1370 val pp_number' : number_format -> float Fmt.t 1371 - (** [pp_number Fmt.t] is like {!pp_number} but uses [fmt] to format the number. *) 1371 + (** [pp_number Fmt.t] is like {!pp_number} but uses [fmt] to format the number. 1372 + *) 1372 1373 1373 1374 val pp_string : string Fmt.t 1374 1375 (** [pp_string] formats a JSON string (quoted and escaped). Assumes the string ··· 1396 1397 1397 1398 (** {1:low Low-level representation} *) 1398 1399 1399 - (** Low level representation (unstable). 1400 + module Codec = Codec 1401 + (** Low level codec representation (unstable). 1400 1402 1401 1403 This representation may change even between minor versions of the library. 1402 1404 It can be used to devise new processors on JSON types. ··· 1412 1414 on how to process this representation. The 1413 1415 {{:https://erratique.ch/repos/jsont/tree/paper}paper} in the Json source 1414 1416 repository may also help to understand this menagerie of types. *) 1415 - module Repr : sig 1416 - type 'a t' := 'a codec 1417 - 1418 - module String_map : Map.S with type key = string 1419 - (** A [Map.Make(String)] instance. *) 1420 - 1421 - (** The type for decoding functions. *) 1422 - type ('ret, 'f) dec_fun = 1423 - | Dec_fun : 'f -> ('ret, 'f) dec_fun 1424 - (** The function and its return type. *) 1425 - | Dec_app : ('ret, 'a -> 'b) dec_fun * 'a Type.Id.t -> ('ret, 'b) dec_fun 1426 - (** Application of an argument to a function witnessed by a type 1427 - identifier. The type identifier can be used to lookup a value of the 1428 - right type in an heterogenous dictionary. *) 1429 - 1430 - (** {1:base Base value maps} *) 1431 - 1432 - type ('a, 'b) base_map = { 1433 - kind : string; 1434 - (** The kind of JSON value that are mapped (documentation) *) 1435 - doc : string; (** A doc string for the kind of JSON value. *) 1436 - dec : Meta.t -> 'a -> 'b; 1437 - (** [dec] decodes a base value represented by its metadata and ['a] to 1438 - ['b]. *) 1439 - enc : 'b -> 'a; 1440 - (** [enc] encodes a value of type ['b] to a base JSON value represented 1441 - by ['a]. *) 1442 - enc_meta : 'b -> Meta.t; 1443 - (** [enc_meta] recovers the base JSON value metadata from ['b] (if any). 1444 - *) 1445 - } 1446 - (** The type for mapping JSON base values represented in OCaml by ['a] (these 1447 - values are fixed by the cases in {!t}) to a value of type ['b]. *) 1448 - 1449 - (** {1:types JSON types} *) 1450 - 1451 - (** The type for JSON types. *) 1452 - type 'a t = 1453 - | Null : (unit, 'a) base_map -> 'a t (** Null maps. *) 1454 - | Bool : (bool, 'a) base_map -> 'a t (** Boolean maps. *) 1455 - | Number : (float, 'a) base_map -> 'a t (** Number maps. *) 1456 - | String : (string, 'a) base_map -> 'a t (** String maps. *) 1457 - | Array : ('a, 'elt, 'builder) array_map -> 'a t (** Array maps. *) 1458 - | Object : ('o, 'o) object_map -> 'o t (** Object maps. *) 1459 - | Any : 'a any_map -> 'a t (** Map for different sorts of JSON values. *) 1460 - | Map : ('b, 'a) map -> 'a t 1461 - (** Map from JSON type ['b] to JSON type ['a]. *) 1462 - | Rec : 'a t Lazy.t -> 'a t (** Recursive definition. *) 1463 - | Ignore : unit t 1464 - (** Skip-parse any JSON value. The bytesrw decoder consumes the value at 1465 - the byte level without materialising strings, numbers or nested DOM; 1466 - this is the fast path for {!Json.ignore}. *) 1467 - 1468 - (** {1:array Array maps} *) 1469 - 1470 - and ('array, 'elt, 'builder) array_map = { 1471 - kind : string; (** The kind of JSON array mapped (documentation). *) 1472 - doc : string; (** Documentation string for the JSON array. *) 1473 - elt : 'elt t; (** The type for the array elements. *) 1474 - dec_empty : unit -> 'builder; 1475 - (** [dec_empty ()] creates a new empty array builder. *) 1476 - dec_skip : int -> 'builder -> bool; 1477 - (** [dec_skip i b] determines if the [i]th index of the JSON array can 1478 - be skipped. *) 1479 - dec_add : int -> 'elt -> 'builder -> 'builder; 1480 - (** [dec_add] adds the [i]th index value of the JSON array as decoded by 1481 - [elt] to the builder. *) 1482 - dec_finish : Meta.t -> int -> 'builder -> 'array; 1483 - (** [dec_finish] turns the builder into an array given its metadata and 1484 - length. *) 1485 - enc : 'acc. ('acc -> int -> 'elt -> 'acc) -> 'acc -> 'array -> 'acc; 1486 - (** [enc] folds over the elements of the array for encoding. *) 1487 - enc_meta : 'array -> Meta.t; 1488 - (** [enc_meta] recovers the metadata of an array (if any). *) 1489 - } 1490 - (** The type for mapping JSON arrays to values of type ['array] with array 1491 - elements mapped to type ['elt] and using a ['builder] value to construct 1492 - the array. *) 1493 - 1494 - (** {1:object_map Object maps} *) 1495 - 1496 - and ('o, 'dec) object_map = { 1497 - kind : string; (** The kind of JSON object (documentation). *) 1498 - doc : string; (** A doc string for the JSON member. *) 1499 - dec : ('o, 'dec) dec_fun; 1500 - (** The object decoding function to construct an ['o] value. *) 1501 - mem_decs : mem_dec String_map.t; 1502 - (** [mem_decs] are the member decoders sorted by member name. *) 1503 - mem_encs : 'o mem_enc list; 1504 - (** [mem_encs] is the list of member encoders. *) 1505 - enc_meta : 'o -> Meta.t; 1506 - (** [enc_meta] recovers the metadata of an object (if any). *) 1507 - shape : 'o object_shape; 1508 - (** [shape] is the {{!object_shape}shape} of the object. *) 1509 - } 1510 - (** The type for mapping a JSON object to values of type ['o] using a decoding 1511 - function of type ['dec]. [mem_decs] and [mem_encs] have the same 1512 - {!mem_map} values they are just sorted differently for decoding and 1513 - encoding purposes. *) 1514 - 1515 - and mem_dec = 1516 - | Mem_dec : ('o, 'a) mem_map -> mem_dec 1517 - (** The type for member maps in decoding position. *) 1518 - 1519 - and 'o mem_enc = 1520 - | Mem_enc : ('o, 'a) mem_map -> 'o mem_enc 1521 - (** The type for member maps in encoding position. *) 1522 - 1523 - and ('o, 'a) mem_map = { 1524 - name : string; (** The JSON member name. *) 1525 - doc : string; (** Documentation for the JSON member. *) 1526 - type' : 'a t; (** The type for the member value. *) 1527 - id : 'a Type.Id.t; 1528 - (** A type identifier for the member. This allows to store the decode in 1529 - a {!Dict.t} on decode and give it in time to the object decoding 1530 - function of the object map. *) 1531 - dec_absent : 'a option; (** The value to use if absent (if any). *) 1532 - enc : 'o -> 'a; (** [enc] recovers the value to encode from ['o]. *) 1533 - (* enc_name_meta : 'a -> Meta.t; 1534 - XXX This should have been the meta found for the name, but 1535 - that does not fit so well in the member combinators, it's 1536 - not impossible to fit it in but likely increases the cost 1537 - for decoding objects. The layout preserving updates occur 1538 - via generic JSON which uses [mems_map] in which the meta 1539 - is available in [dec_add]. Let's leave it that way for now. *) 1540 - enc_omit : 'a -> bool; 1541 - (** [enc_omit] is [true] if the result of [enc] should not be encoded. 1542 - *) 1543 - } 1544 - (** The type for mapping a JSON member to a value of type ['a] in an object 1545 - represented by a value of type ['o]. *) 1546 - 1547 - (** The type for object shapes. *) 1548 - and 'o object_shape = 1549 - | Object_basic : ('o, 'mems, 'builder) unknown_mems -> 'o object_shape 1550 - (** A basic object, possibly indicating how to handle unknown members *) 1551 - | Object_cases : 1552 - ('o, 'mems, 'builder) unknown_mems option 1553 - * ('o, 'cases, 'tag) object_cases 1554 - -> 'o object_shape 1555 - (** An object with a case member each case further describing an object 1556 - map. *) 1557 - 1558 - (** {2:unknown_mems Unknown members} *) 1559 - 1560 - (** The type for specifying decoding behaviour on unknown JSON object members. 1561 - *) 1562 - and ('o, 'mems, 'builder) unknown_mems = 1563 - | Unknown_skip : ('o, unit, unit) unknown_mems (** Skip unknown members. *) 1564 - | Unknown_error : ('o, unit, unit) unknown_mems 1565 - (** Error on unknown members. *) 1566 - | Unknown_keep : 1567 - ('mems, 'a, 'builder) mems_map * ('o -> 'mems) 1568 - -> ('o, 'mems, 'builder) unknown_mems 1569 - (** Gather unknown members in a member map. *) 1570 - 1571 - and ('mems, 'a, 'builder) mems_map = { 1572 - kind : string; (** The kind for unknown members (documentation). *) 1573 - doc : string; (** Documentation string for the unknown members. *) 1574 - mems_type : 'a t; 1575 - (** The uniform type according which unknown members are typed. *) 1576 - id : 'mems Type.Id.t; (** A type identifier for the unknown member map. *) 1577 - dec_empty : unit -> 'builder; 1578 - (** [dec_empty] create a new empty member map builder. *) 1579 - dec_add : Meta.t -> string -> 'a -> 'builder -> 'builder; 1580 - (** [dec_add] adds a member named [n] with metadata [meta] and value 1581 - parsed by [mems_type] to the builder. *) 1582 - dec_finish : Meta.t -> 'builder -> 'mems; 1583 - (** [dec_finish] turns the builder into an unknown member map. The 1584 - [meta] is the meta data of the object in which they were found. *) 1585 - enc : 1586 - 'acc. (Meta.t -> string -> 'a -> 'acc -> 'acc) -> 'mems -> 'acc -> 'acc; 1587 - (** [enc] folds over the member map for encoding. *) 1588 - } 1589 - (** The type for gathering unknown JSON members uniformly typed according to 1590 - ['a] in a map ['mems] constructed with ['builder]. *) 1591 - 1592 - (** {2:case_objects Case objects} *) 1593 - 1594 - and ('o, 'cases, 'tag) object_cases = { 1595 - tag : ('tag, 'tag) mem_map; 1596 - (** The JSON member used to decide cases. The [enc] field of this 1597 - [mem_map] should be the identity, this allows encoders to reuse 1598 - generic encoding code for members. We don't have 1599 - [('o, 'tag) mem_map] here because the tag is not stored we recover 1600 - the case via [enc] and [enc_case] below. *) 1601 - tag_compare : 'tag -> 'tag -> int; (** The function to compare tags. *) 1602 - tag_to_string : ('tag -> string) option; 1603 - (** The function to stringify tags for error reporting. *) 1604 - id : 'cases Type.Id.t; (** A type identifier for the tag. *) 1605 - cases : ('cases, 'tag) case list; (** The list of possible cases. *) 1606 - enc : 'o -> 'cases; 1607 - (** [enc] is the function to recover case values from the value ['o] the 1608 - object is mapped to. *) 1609 - enc_case : 'cases -> ('cases, 'tag) case_value; 1610 - (** [enc_case] retrieves the concrete case from the common [cases] 1611 - values. You can see it as preforming a match. *) 1612 - } 1613 - (** The type for object cases mapped to a common type ['cases] stored in a 1614 - vlue of type ['o] and identified by tag values of type ['tag]. *) 1615 - 1616 - and ('cases, 'case, 'tag) case_map = { 1617 - tag : 'tag; (** The tag value for the case. *) 1618 - object_map : ('case, 'case) object_map; (** The object map for the case. *) 1619 - dec : 'case -> 'cases; 1620 - (** [dec] is the function used on decoding to inject the case into the 1621 - common ['cases] type. *) 1622 - } 1623 - (** The type for an object case with common type ['cases] specific type 1624 - ['case] and tag type ['tag]. *) 1625 - 1626 - and ('cases, 'tag) case_value = 1627 - | Case_value : 1628 - ('cases, 'case, 'tag) case_map * 'case 1629 - -> ('cases, 'tag) case_value 1630 - (** The type for case values. This packs a case value and its 1631 - description. *) 1632 - 1633 - and ('cases, 'tag) case = 1634 - | Case : ('cases, 'case, 'tag) case_map -> ('cases, 'tag) case 1635 - (** The type for hiding the the concrete type of a case . *) 1636 - 1637 - (** {1:any Any maps} *) 1638 - 1639 - and 'a any_map = { 1640 - kind : string; (** The kind of JSON values mapped (documentation). *) 1641 - doc : string; (** Documentation string for the kind of values. *) 1642 - dec_null : 'a t option; 1643 - (** [dec_null], if any, is used for decoding JSON nulls. *) 1644 - dec_bool : 'a t option; 1645 - (** [dec_bool], if any, is used for decoding JSON bools. *) 1646 - dec_number : 'a t option; 1647 - (** [dec_number], if any, is used for decoding JSON numbers. *) 1648 - dec_string : 'a t option; 1649 - (** [dec_string], if any, is used for decoding JSON strings. *) 1650 - dec_array : 'a t option; 1651 - (** [dec_array], if any, is used for decoding JSON arrays. *) 1652 - dec_object : 'a t option; 1653 - (** [dec_object], if any, is used for decoding JSON objects. *) 1654 - enc : 'a -> 'a t; 1655 - (** [enc] specifies the encoder to use on a given value. *) 1656 - } 1657 - (** The type for mapping JSON values with multiple sorts to a value of type 1658 - ['a]. If a decoding case is [None], the decoding errors on these JSON 1659 - values. *) 1660 - 1661 - (** {1:type_map Type maps} *) 1662 - 1663 - and ('a, 'b) map = { 1664 - kind : string; (** The kind of JSON values mapped (documentation). *) 1665 - doc : string; (** Documentation string for the kind of values. *) 1666 - dom : 'a t; (** The domain of the map. *) 1667 - dec : 'a -> 'b; (** [dec] decodes ['a] to ['b]. *) 1668 - enc : 'b -> 'a; (** [enc] encodes ['b] to ['a]. *) 1669 - } 1670 - (** The type for mapping JSON types of type ['a] to a JSON type of type ['b]. 1671 - *) 1672 - 1673 - (** {1:conv Convert} *) 1674 - 1675 - val of_t : 'a t' -> 'a t 1676 - (** [of_t] is {!Stdlib.Fun.id}. *) 1677 - 1678 - val unsafe_to_t : 'a t -> 'a t' 1679 - (** [unsafe_to_t r] converts the representation to a type [r]. It is unsafe 1680 - because constructors of the {!Json} module do maintain some invariants. *) 1681 - 1682 - (** {1:kinds Kinds and doc} *) 1683 - 1684 - val kinded_sort : 'a t -> string 1685 - (** [kinded_sort t] is kinded sort of [t], see {!Json.kinded_sort}. *) 1686 - 1687 - val array_map_kinded_sort : ('a, 'elt, 'builder) array_map -> string 1688 - (** [array_map_kinded_sort map] is like {!kinded_sort} but acts directly on 1689 - the array [map]. *) 1690 - 1691 - val object_map_kinded_sort : ('o, 'dec) object_map -> string 1692 - (** [object_map_kind map] is like {!kinded_sort} but acts directly on the 1693 - object [map]. *) 1694 - 1695 - val pp_kind : string Fmt.t 1696 - (** [pp_kind] formats kinds. *) 1697 - 1698 - val doc : 'a t -> string 1699 - (** See {!Json.doc}. *) 1700 - 1701 - val with_doc : ?kind:string -> ?doc:string -> 'a t -> 'a t 1702 - (** See {!Json.with_doc}. *) 1703 - 1704 - (** {1:errors Errors} *) 1705 - 1706 - val error_push_array : 1707 - Meta.t -> ('array, 'elt, 'builder) array_map -> int node -> Error.t -> 'a 1708 - (** [error_push_array] is like {!Error.push_array} but uses the given array 1709 - [meta] and array map to caracterize the context. *) 1710 - 1711 - val error_push_object : 1712 - Meta.t -> ('o, 'dec) object_map -> string node -> Error.t -> 'a 1713 - (** [error_push_object] is like {!Error.push_object} but uses the given object 1714 - [meta] and object map to caracterize the context. *) 1715 - 1716 - val type_error : Meta.t -> 'a t -> fnd:Sort.t -> 'b 1717 - (** [type_error meta ~exp ~fnd] errors when kind [exp] was expected but sort 1718 - [fnd] was found. *) 1719 - 1720 - val missing_mems_error : 1721 - Meta.t -> 1722 - ('o, 'o) object_map -> 1723 - exp:mem_dec String_map.t -> 1724 - fnd:string list -> 1725 - 'a 1726 - (** [missing_mems_error m map exp fnd] errors when [exp] cannot be found, 1727 - [fnd] can list a few members that were found. *) 1728 - 1729 - val unexpected_mems_error : 1730 - Meta.t -> ('o, 'o) object_map -> fnd:(string * Meta.t) list -> 'a 1731 - (** [unexpected_mems_error meta map ~fnd] errors when [fnd] are unexpected 1732 - members for object [map]. *) 1733 - 1734 - val unexpected_case_tag_error : 1735 - Meta.t -> ('o, 'o) object_map -> ('o, 'd, 'tag) object_cases -> 'tag -> 'a 1736 - (** [unexpected_case_tag_error meta map cases tag] is when a [tag] of a case 1737 - member has no corresponding case. *) 1738 - 1739 - (** {1:toolbox Processor toolbox} *) 1740 - 1741 - val object_meta_arg : Meta.t Type.Id.t 1742 - (** [object_meta_arg] holds the {!Json.Object.mem} to *) 1743 - 1744 - (** Heterogeneous dictionaries. *) 1745 - module Dict : sig 1746 - type binding = B : 'a Type.Id.t * 'a -> binding 1747 - type t 1748 - 1749 - val empty : t 1750 - val mem : 'a Type.Id.t -> t -> bool 1751 - val add : 'a Type.Id.t -> 'a -> t -> t 1752 - val remove : 'a Type.Id.t -> t -> t 1753 - val find : 'a Type.Id.t -> t -> 'a option 1754 - end 1755 - 1756 - val apply_dict : ('ret, 'f) dec_fun -> Dict.t -> 'f 1757 - (** [apply_dict dec dict] applies [dict] to [f] in order to get the value 1758 - ['f]. Raises [Invalid_argument] if [dict] has not all the type identifiers 1759 - that [dec] needs. *) 1760 - 1761 - type unknown_mems_option = 1762 - | Unknown_mems : 1763 - ('o, 'mems, 'builder) unknown_mems option 1764 - -> unknown_mems_option 1765 - (** A type for hiding an optional {!type-unknown_mems} values. *) 1766 - 1767 - val override_unknown_mems : 1768 - by:unknown_mems_option -> 1769 - unknown_mems_option -> 1770 - Dict.t -> 1771 - unknown_mems_option * Dict.t 1772 - (** [override_unknown_mems ~by current dict] preforms the unknown member 1773 - overriding logic for {!Json.Object.Case} objects. In particular if 1774 - [current] is a {!Json.Object.Mems.val-map} it adds an empty one in [dict] 1775 - so that the associated decoding function does not fail. *) 1776 - 1777 - val finish_object_decode : 1778 - ('o, 'o) object_map -> 1779 - Meta.t -> 1780 - ('p, 'mems, 'builder) unknown_mems -> 1781 - 'builder -> 1782 - mem_dec String_map.t -> 1783 - Dict.t -> 1784 - Dict.t 1785 - (** [finish_object_decode map meta unknown_mems umap rem_mems dict] finishes 1786 - an object map [map] decode. It adds the [umap] (if needed) to [dict], it 1787 - adds [meta] to [dict] under {!object_meta_arg} and tries to find andd 1788 - default values to [dict] for [rem_mems] (and errors if it can't). *) 1789 - 1790 - val pp_code : string Fmt.t 1791 - (** [pp_code] formats strings like code (in bold). *) 1792 - end

+1 -1

test/cookbook.ml

··· 238 238 type t = { id : int; value : (Jsont.json, string) result } 239 239 240 240 let make id result error = 241 - let pp_mem = Jsont.Repr.pp_code in 241 + let pp_mem = Jsont.Codec.pp_code in 242 242 match (result, error) with 243 243 | Some result, None -> { id; value = Ok result } 244 244 | None, Some error -> { id; value = Error error }

+2 -2

test/json_rpc.ml

··· 90 90 let response jsonrpc result error id : response = 91 91 let err_both () = 92 92 Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined" 93 - Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error" 93 + Jsont.Codec.pp_code "result" Jsont.Codec.pp_code "error" 94 94 in 95 95 let err_none () = 96 96 Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member" 97 - Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error" 97 + Jsont.Codec.pp_code "result" Jsont.Codec.pp_code "error" 98 98 in 99 99 match (result, error) with 100 100 | Some result, None -> { jsonrpc; value = Ok result; id }

+1 -1

test/jsont_tool.ml

··· 141 141 142 142 let locs' ~file = 143 143 let pf = Format.fprintf in 144 - let pp_code = Jsont.Repr.pp_code in 144 + let pp_code = Jsont.Codec.pp_code in 145 145 let pp_locs_outline ppf v = 146 146 let indent = 2 in 147 147 let loc label ppf m =

Configure Feed

Configure Feed