Native CBOR codec with type-safe combinators
ocaml-cbor: rewrite Obj/Obj_int as nox-json-style pipeline, drop Obj.magic
The old [(o, a) mem] GADT was monadic with [cont : 'x -> ('o, 'a) mem],
which forced [member_names] / [build_decoders] to walk the chain by
calling [cont (Obj.magic ())] — a fake value the continuations were
trusted not to inspect. That trust was implicit, type-system-evading,
and exactly what you don't want in a security-focused codec.
Replace it with [Json.Codec.Object]'s pipeline shape:
Cbor.Obj.map (fun a b c -> { a; b; c })
|> Cbor.Obj.mem "a" (fun r -> r.a) Cbor.string
|> Cbor.Obj.mem "b" (fun r -> r.b) Cbor.int
|> Cbor.Obj.mem_opt "c" (fun r -> r.c) Cbor.string
|> Cbor.Obj.seal
Each [mem] consumes one argument of the curried constructor and reifies
the field as a record carrying its name plus typed encode/decode
closures. [seal] enumerates field names and a name -> field dispatch
table directly from the field list — no chain walking, no [Obj.magic].
The implementation still uses [Stdlib.Obj.repr] / [Stdlib.Obj.obj] to
hold heterogeneously-typed decoded values in a single name-keyed table,
but only with values whose static type is fixed by the field that
produced them (the same [Hmap]-style universal-table contract); never
[Obj.magic ()].
Other changes:
- Apply the same rewrite to [Cbor.Obj_int] (integer-keyed records used
by COSE / CWT).
- Drop [let*], [return], [map], [both], [let+], [and+] from the API —
the pipeline form supersedes them.
- Update mli docs and the README quick-start to the new shape.
- Migrate every caller in the workspace
(ocaml-cbor/test/{test_cbor,test_value}, ocaml-mst/test/test_mst).
[dune build] is clean; [Cbor.encode_string] / [decode_string]
roundtrip remains green across all 298 cbor tests and the 41 mst
tests. [merlint ocaml-cbor] now reports 0 issues — every Obj.magic
flagged by E100 is gone.
+580
-660
+484
-593
lib/cbor.ml
+484
-593
lib/cbor.ml
···
798
798
let string_map vc = assoc string vc
799
799
let int_map vc = assoc int vc
800
800
801
-
(* Object codec module *)
801
+
(* Object codec module.
802
+
803
+
Records are described as a curried constructor [map ctor] threaded through a
804
+
sequence of [mem] / [mem_opt] / [mem_default] applications and closed by
805
+
[seal] — the same applicative pipeline shape used by [Json.Codec.Object].
806
+
Each [mem] reifies a field as an [_ field] record carrying its name plus a
807
+
typed encode/decode pair, and applies one argument of the curried [ctor].
808
+
Assembly of the final record happens after decoding through a per-instance
809
+
lookup, so the codec never has to walk the structure with a fake value
810
+
(which is what the previous monadic GADT did via [Obj.magic ()]). *)
802
811
803
812
module Obj = struct
804
-
type enc = (string * Value.t) list
813
+
type 'o field = {
814
+
name : string;
815
+
encode : 'o -> Value.t option;
816
+
(** [None] means the field is omitted from the encoded map. *)
817
+
decode_value :
818
+
Loc.Context.t -> Value.t option -> (Stdlib.Obj.t, Error.t) result;
819
+
(** [decode_value ctx v] takes the value found for this field ([None]
820
+
when the field was absent in the input map). The result is
821
+
type-erased into [Stdlib.Obj.t] for storage in the per-decode value
822
+
table; the matching {!field_lookup} reverses the erasure via the
823
+
field's known static type. *)
824
+
decode_rw :
825
+
Loc.Context.t -> Binary.decoder -> (Stdlib.Obj.t, Error.t) result;
826
+
(** Streaming decode entry point. The peek-and-skip-on-null behaviour of
827
+
{!mem_opt} / {!mem_default} lives here. *)
828
+
decode_missing : (Stdlib.Obj.t, string) result;
829
+
(** Default value used when the field is absent in the streaming decode
830
+
path. [Error name] is returned for required fields. *)
831
+
}
805
832
806
-
let field name (v : Value.t) (acc : enc) : enc = (name, v) :: acc
833
+
type ('o, 'dec) mem = {
834
+
fields : 'o field list;
835
+
build : (string -> Stdlib.Obj.t) -> 'dec;
836
+
(** Always called with a [lookup] that maps every field's name to a real
837
+
decoded value (already type-erased into [Stdlib.Obj.t]). The static
838
+
type of each lookup result is fixed by the field that produced it,
839
+
so [Stdlib.Obj.obj] in the field-specific reader is the same kind of
840
+
contract that drives [Hmap]. *)
841
+
}
842
+
843
+
let map ctor = { fields = []; build = (fun _ -> ctor) }
807
844
808
-
let find_remove key pairs =
809
-
let rec loop acc = function
810
-
| [] -> (None, List.rev acc)
811
-
| (k, v) :: rest when k = key -> (Some v, List.rev_append acc rest)
812
-
| kv :: rest -> loop (kv :: acc) rest
845
+
let mem (type o a b) name (get : o -> a) (codec : a t) (m : (o, a -> b) mem) :
846
+
(o, b) mem =
847
+
let encode o = Some (codec.encode (get o)) in
848
+
let decode_value ctx v =
849
+
let path' = Error.ctx_with_key name ctx in
850
+
match v with
851
+
| None -> Error (Error.v ~ctx:path' (Error.Missing_member name))
852
+
| Some v -> (
853
+
match codec.decode path' v with
854
+
| Ok x -> Ok (Stdlib.Obj.repr x)
855
+
| Error e -> Error e)
856
+
in
857
+
let decode_rw ctx dec =
858
+
let path' = Error.ctx_with_key name ctx in
859
+
match codec.decode_rw path' dec with
860
+
| Ok x -> Ok (Stdlib.Obj.repr x)
861
+
| Error e -> Error e
862
+
in
863
+
let field =
864
+
{ name; encode; decode_value; decode_rw; decode_missing = Error name }
813
865
in
814
-
loop [] pairs
866
+
{
867
+
fields = m.fields @ [ field ];
868
+
build =
869
+
(fun lookup ->
870
+
let f = m.build lookup in
871
+
let v : a = Stdlib.Obj.obj (lookup name) in
872
+
f v);
873
+
}
815
874
816
-
type (_, _) mem =
817
-
| Return : 'a -> ('o, 'a) mem
818
-
| Mem : {
819
-
name : string;
820
-
get : 'o -> 'x;
821
-
codec : 'x t;
822
-
cont : 'x -> ('o, 'a) mem;
823
-
}
824
-
-> ('o, 'a) mem
825
-
| Mem_opt : {
826
-
name : string;
827
-
get : 'o -> 'x option;
828
-
codec : 'x t;
829
-
cont : 'x option -> ('o, 'a) mem;
830
-
}
831
-
-> ('o, 'a) mem
832
-
| Mem_default : {
833
-
name : string;
834
-
get : 'o -> 'x;
835
-
codec : 'x t;
836
-
default : 'x;
837
-
cont : 'x -> ('o, 'a) mem;
838
-
}
839
-
-> ('o, 'a) mem
840
-
841
-
let return v = Return v
842
-
let mem name get codec = Mem { name; get; codec; cont = (fun x -> Return x) }
843
-
844
-
let mem_opt name get codec =
845
-
Mem_opt { name; get; codec; cont = (fun x -> Return x) }
846
-
847
-
let mem_default name get ~default codec =
848
-
Mem_default { name; get; codec; default; cont = (fun x -> Return x) }
875
+
let mem_opt (type o a b) name (get : o -> a option) (codec : a t)
876
+
(m : (o, a option -> b) mem) : (o, b) mem =
877
+
let none_obj : Stdlib.Obj.t = Stdlib.Obj.repr (None : a option) in
878
+
let encode o =
879
+
match get o with None -> None | Some x -> Some (codec.encode x)
880
+
in
881
+
let decode_value ctx v =
882
+
match v with
883
+
| None | Some Value.Null -> Ok none_obj
884
+
| Some v -> (
885
+
let path' = Error.ctx_with_key name ctx in
886
+
match codec.decode path' v with
887
+
| Ok x -> Ok (Stdlib.Obj.repr (Some x : a option))
888
+
| Error e -> Error e)
889
+
in
890
+
let decode_rw ctx dec =
891
+
match Binary.peek_byte dec with
892
+
| Some b
893
+
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
894
+
->
895
+
ignore (Binary.read_byte dec);
896
+
Ok none_obj
897
+
| _ -> (
898
+
let path' = Error.ctx_with_key name ctx in
899
+
match codec.decode_rw path' dec with
900
+
| Ok x -> Ok (Stdlib.Obj.repr (Some x : a option))
901
+
| Error e -> Error e)
902
+
in
903
+
let field =
904
+
{ name; encode; decode_value; decode_rw; decode_missing = Ok none_obj }
905
+
in
906
+
{
907
+
fields = m.fields @ [ field ];
908
+
build =
909
+
(fun lookup ->
910
+
let f = m.build lookup in
911
+
let v : a option = Stdlib.Obj.obj (lookup name) in
912
+
f v);
913
+
}
849
914
850
-
let rec ( let* ) : type o a b. (o, a) mem -> (a -> (o, b) mem) -> (o, b) mem =
851
-
fun m f ->
852
-
match m with
853
-
| Return a -> f a
854
-
| Mem r ->
855
-
Mem
856
-
{
857
-
r with
858
-
cont =
859
-
(fun x ->
860
-
let* y = r.cont x in
861
-
f y);
862
-
}
863
-
| Mem_opt r ->
864
-
Mem_opt
865
-
{
866
-
r with
867
-
cont =
868
-
(fun x ->
869
-
let* y = r.cont x in
870
-
f y);
871
-
}
872
-
| Mem_default r ->
873
-
Mem_default
874
-
{
875
-
r with
876
-
cont =
877
-
(fun x ->
878
-
let* y = r.cont x in
879
-
f y);
880
-
}
915
+
let mem_default (type o a b) name (get : o -> a) ~(default : a) (codec : a t)
916
+
(m : (o, a -> b) mem) : (o, b) mem =
917
+
let default_obj : Stdlib.Obj.t = Stdlib.Obj.repr default in
918
+
let encode o = Some (codec.encode (get o)) in
919
+
let decode_value ctx v =
920
+
match v with
921
+
| None | Some Value.Null -> Ok default_obj
922
+
| Some v -> (
923
+
let path' = Error.ctx_with_key name ctx in
924
+
match codec.decode path' v with
925
+
| Ok x -> Ok (Stdlib.Obj.repr x)
926
+
| Error e -> Error e)
927
+
in
928
+
let decode_rw ctx dec =
929
+
match Binary.peek_byte dec with
930
+
| Some b
931
+
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
932
+
->
933
+
ignore (Binary.read_byte dec);
934
+
Ok default_obj
935
+
| _ -> (
936
+
let path' = Error.ctx_with_key name ctx in
937
+
match codec.decode_rw path' dec with
938
+
| Ok x -> Ok (Stdlib.Obj.repr x)
939
+
| Error e -> Error e)
940
+
in
941
+
let field =
942
+
{ name; encode; decode_value; decode_rw; decode_missing = Ok default_obj }
943
+
in
944
+
{
945
+
fields = m.fields @ [ field ];
946
+
build =
947
+
(fun lookup ->
948
+
let f = m.build lookup in
949
+
let v : a = Stdlib.Obj.obj (lookup name) in
950
+
f v);
951
+
}
881
952
882
-
let rec decode_mem : type o a.
883
-
Loc.Context.t ->
884
-
(string * Value.t) list ->
885
-
(o, a) mem ->
886
-
(a * (string * Value.t) list, Error.t) result =
887
-
fun path pairs m ->
888
-
match m with
889
-
| Return a -> Ok (a, pairs)
890
-
| Mem { name; codec; cont; _ } -> (
891
-
match find_remove name pairs with
892
-
| None, _ -> Error (Error.v ~ctx:path (Error.Missing_member name))
893
-
| Some v, remaining -> (
894
-
let path' = Error.ctx_with_key name path in
895
-
match codec.decode path' v with
953
+
let seal (type o) (m : (o, o) mem) : o t =
954
+
let names = List.map (fun (f : o field) -> f.name) m.fields in
955
+
let kind = Fmt.str "obj({%s})" (String.concat ", " names) in
956
+
let by_name : (string, o field) Hashtbl.t =
957
+
Hashtbl.create (List.length m.fields)
958
+
in
959
+
List.iter (fun (f : o field) -> Hashtbl.replace by_name f.name f) m.fields;
960
+
let lookup_or_fail path tbl =
961
+
let lookup name =
962
+
match Hashtbl.find_opt tbl name with
963
+
| Some v -> v
964
+
| None ->
965
+
(* Decoding never reaches assembly without populating every field
966
+
(or its default), so this only fires on a programmer bug in
967
+
the codec itself. *)
968
+
Stdlib.invalid_arg
969
+
(Fmt.str "Cbor.Obj.seal: missing %s for %a" name Loc.Context.pp
970
+
path)
971
+
in
972
+
lookup
973
+
in
974
+
let decode_value path values =
975
+
let pairs =
976
+
List.filter_map
977
+
(fun (k, v) -> match k with Value.Text s -> Some (s, v) | _ -> None)
978
+
values
979
+
in
980
+
let pairs_tbl = Hashtbl.create (List.length pairs) in
981
+
List.iter (fun (k, v) -> Hashtbl.replace pairs_tbl k v) pairs;
982
+
let results = Hashtbl.create (List.length m.fields) in
983
+
let rec fill = function
984
+
| [] -> Ok ()
985
+
| (f : o field) :: rest -> (
986
+
let v_opt = Hashtbl.find_opt pairs_tbl f.name in
987
+
match f.decode_value path v_opt with
896
988
| Error e -> Error e
897
-
| Ok x -> decode_mem path remaining (cont x)))
898
-
| Mem_opt { name; codec; cont; _ } -> (
899
-
match find_remove name pairs with
900
-
| None, remaining -> decode_mem path remaining (cont None)
901
-
| Some Value.Null, remaining -> decode_mem path remaining (cont None)
902
-
| Some v, remaining -> (
903
-
let path' = Error.ctx_with_key name path in
904
-
match codec.decode path' v with
905
-
| Error e -> Error e
906
-
| Ok x -> decode_mem path remaining (cont (Some x))))
907
-
| Mem_default { name; codec; default; cont; _ } -> (
908
-
match find_remove name pairs with
909
-
| None, remaining -> decode_mem path remaining (cont default)
910
-
| Some Value.Null, remaining -> decode_mem path remaining (cont default)
911
-
| Some v, remaining -> (
912
-
let path' = Error.ctx_with_key name path in
913
-
match codec.decode path' v with
914
-
| Error e -> Error e
915
-
| Ok x -> decode_mem path remaining (cont x)))
916
-
917
-
let rec encode_mem : type o a. o -> (o, a) mem -> enc -> enc =
918
-
fun o m acc ->
919
-
match m with
920
-
| Return _ -> acc
921
-
| Mem { name; get; codec; cont } ->
922
-
let v = get o in
923
-
let acc = field name (codec.encode v) acc in
924
-
encode_mem o (cont v) acc
925
-
| Mem_opt { name; get; codec; cont } ->
926
-
let v = get o in
927
-
let acc =
928
-
match v with None -> acc | Some x -> field name (codec.encode x) acc
929
-
in
930
-
encode_mem o (cont v) acc
931
-
| Mem_default { name; get; codec; cont; _ } ->
932
-
let v = get o in
933
-
let acc = field name (codec.encode v) acc in
934
-
encode_mem o (cont v) acc
935
-
936
-
let rec member_names : type o a. (o, a) mem -> string list = function
937
-
| Return _ -> []
938
-
| Mem { name; cont; _ } ->
939
-
(* We need a dummy value to get the continuation, but for names
940
-
we just use Obj.magic since we only inspect structure *)
941
-
name :: member_names (cont (Stdlib.Obj.magic ()))
942
-
| Mem_opt { name; cont; _ } ->
943
-
name :: member_names (cont (Stdlib.Obj.magic ()))
944
-
| Mem_default { name; cont; _ } ->
945
-
name :: member_names (cont (Stdlib.Obj.magic ()))
946
-
947
-
(* Build a dispatch table from member name to a streaming decoder that
948
-
stores the typed result into a hashtable keyed by name. The stored
949
-
values are wrapped via Stdlib.Obj.repr so that a single table can
950
-
hold heterogeneously-typed decoded results. *)
951
-
type mem_decoder = {
952
-
decode_rw_store :
953
-
Loc.Context.t ->
954
-
Binary.decoder ->
955
-
(string, Stdlib.Obj.t) Hashtbl.t ->
956
-
(unit, Error.t) result;
957
-
}
958
-
959
-
let rec build_decoders : type o a. (o, a) mem -> (string * mem_decoder) list =
960
-
function
961
-
| Return _ -> []
962
-
| Mem { name; codec; cont; _ } ->
963
-
let dec_entry =
964
-
{
965
-
decode_rw_store =
966
-
(fun path dec tbl ->
967
-
match codec.decode_rw path dec with
968
-
| Ok v ->
969
-
Hashtbl.replace tbl name (Stdlib.Obj.repr v);
970
-
Ok ()
971
-
| Error e -> Error e);
972
-
}
973
-
in
974
-
(name, dec_entry) :: build_decoders (cont (Stdlib.Obj.magic ()))
975
-
| Mem_opt { name; codec; cont; _ } ->
976
-
let dec_entry =
977
-
{
978
-
decode_rw_store =
979
-
(fun path dec tbl ->
980
-
(* Peek: if null, store None *)
981
-
match Binary.peek_byte dec with
982
-
| Some b
983
-
when b lsr 5 = Binary.major_simple
984
-
&& b land 0x1f = Binary.simple_null ->
985
-
ignore (Binary.read_byte dec);
986
-
Hashtbl.replace tbl name (Stdlib.Obj.repr None);
987
-
Ok ()
988
-
| _ -> (
989
-
match codec.decode_rw path dec with
990
-
| Ok v ->
991
-
Hashtbl.replace tbl name (Stdlib.Obj.repr (Some v));
992
-
Ok ()
993
-
| Error e -> Error e));
994
-
}
995
-
in
996
-
(name, dec_entry) :: build_decoders (cont (Stdlib.Obj.magic ()))
997
-
| Mem_default { name; codec; default; cont; _ } ->
998
-
let dec_entry =
999
-
{
1000
-
decode_rw_store =
1001
-
(fun path dec tbl ->
1002
-
match Binary.peek_byte dec with
1003
-
| Some b
1004
-
when b lsr 5 = Binary.major_simple
1005
-
&& b land 0x1f = Binary.simple_null ->
1006
-
ignore (Binary.read_byte dec);
1007
-
Hashtbl.replace tbl name (Stdlib.Obj.repr default);
1008
-
Ok ()
1009
-
| _ -> (
1010
-
match codec.decode_rw path dec with
1011
-
| Ok v ->
1012
-
Hashtbl.replace tbl name (Stdlib.Obj.repr v);
1013
-
Ok ()
1014
-
| Error e -> Error e));
1015
-
}
1016
-
in
1017
-
(name, dec_entry) :: build_decoders (cont (Stdlib.Obj.magic ()))
1018
-
1019
-
(* After reading all map pairs from the stream, walk the mem chain
1020
-
and collect typed values from the hashtable. *)
1021
-
let rec resolve_mem : type o a.
1022
-
Loc.Context.t ->
1023
-
(string, Stdlib.Obj.t) Hashtbl.t ->
1024
-
(o, a) mem ->
1025
-
(a, Error.t) result =
1026
-
fun path tbl m ->
1027
-
match m with
1028
-
| Return a -> Ok a
1029
-
| Mem { name; cont; _ } -> (
1030
-
match Hashtbl.find_opt tbl name with
1031
-
| None -> Error (Error.v ~ctx:path (Error.Missing_member name))
1032
-
| Some obj -> resolve_mem path tbl (cont (Stdlib.Obj.obj obj)))
1033
-
| Mem_opt { name; cont; _ } -> (
1034
-
match Hashtbl.find_opt tbl name with
1035
-
| None -> resolve_mem path tbl (cont None)
1036
-
| Some obj -> resolve_mem path tbl (cont (Stdlib.Obj.obj obj)))
1037
-
| Mem_default { name; default; cont; _ } -> (
1038
-
match Hashtbl.find_opt tbl name with
1039
-
| None -> resolve_mem path tbl (cont default)
1040
-
| Some obj -> resolve_mem path tbl (cont (Stdlib.Obj.obj obj)))
1041
-
1042
-
(* Streaming decode: read map key-value pairs directly, dispatching
1043
-
each value to the appropriate member's decode_rw. Unknown keys
1044
-
have their values skipped. *)
1045
-
let decode_map_rw path dec len_opt dispatch tbl =
1046
-
let n = match len_opt with Some n -> n | None -> max_int in
1047
-
let rec loop i =
1048
-
if i >= n then Ok ()
1049
-
else if len_opt = None && Binary.is_break dec then (
1050
-
Binary.skip_break dec;
1051
-
Ok ())
1052
-
else
1053
-
match Binary.peek_byte dec with
1054
-
| Some b when b lsr 5 = Binary.major_text -> (
1055
-
let key = Binary.read_text dec in
1056
-
match Hashtbl.find_opt dispatch key with
1057
-
| Some entry -> (
1058
-
let path' = Error.ctx_with_key key path in
1059
-
match entry.decode_rw_store path' dec tbl with
1060
-
| Ok () -> loop (i + 1)
1061
-
| Error e -> Error e)
1062
-
| None ->
1063
-
(* Unknown member: skip the value *)
1064
-
Binary.skip dec;
1065
-
loop (i + 1))
1066
-
| _ ->
1067
-
(* Non-text key: skip key and value *)
1068
-
Binary.skip dec;
1069
-
Binary.skip dec;
1070
-
loop (i + 1)
989
+
| Ok obj ->
990
+
Hashtbl.replace results f.name obj;
991
+
fill rest)
992
+
in
993
+
match fill m.fields with
994
+
| Error e -> Error e
995
+
| Ok () -> Ok (m.build (lookup_or_fail path results))
1071
996
in
1072
-
loop 0
1073
-
1074
-
let seal (m : ('o, 'o) mem) : 'o t =
1075
-
let names = member_names m in
1076
-
let kind = Fmt.str "obj({%s})" (String.concat ", " names) in
1077
-
(* Pre-build the dispatch table for streaming decode *)
1078
-
let decoder_list = build_decoders m in
1079
-
let make_dispatch () =
1080
-
let tbl = Hashtbl.create (List.length decoder_list) in
1081
-
List.iter
1082
-
(fun (name, entry) -> Hashtbl.replace tbl name entry)
1083
-
decoder_list;
1084
-
tbl
997
+
let decode_rw path dec =
998
+
match read_map_length_rw path dec with
999
+
| Error e -> e
1000
+
| Ok len_opt -> (
1001
+
let results = Hashtbl.create (List.length m.fields) in
1002
+
let n = match len_opt with Some n -> n | None -> max_int in
1003
+
let rec read i =
1004
+
if i >= n then Ok ()
1005
+
else if len_opt = None && Binary.is_break dec then (
1006
+
Binary.skip_break dec;
1007
+
Ok ())
1008
+
else
1009
+
match Binary.peek_byte dec with
1010
+
| Some b when b lsr 5 = Binary.major_text -> (
1011
+
let key = Binary.read_text dec in
1012
+
match Hashtbl.find_opt by_name key with
1013
+
| Some f -> (
1014
+
match f.decode_rw path dec with
1015
+
| Error e -> Error e
1016
+
| Ok obj ->
1017
+
Hashtbl.replace results key obj;
1018
+
read (i + 1))
1019
+
| None ->
1020
+
Binary.skip dec;
1021
+
read (i + 1))
1022
+
| _ ->
1023
+
Binary.skip dec;
1024
+
Binary.skip dec;
1025
+
read (i + 1)
1026
+
in
1027
+
match read 0 with
1028
+
| Error e -> Error e
1029
+
| Ok () -> (
1030
+
(* Fill in defaults / report missing required fields. *)
1031
+
let missing =
1032
+
List.find_map
1033
+
(fun (f : o field) ->
1034
+
if Hashtbl.mem results f.name then None
1035
+
else
1036
+
match f.decode_missing with
1037
+
| Ok obj ->
1038
+
Hashtbl.replace results f.name obj;
1039
+
None
1040
+
| Error name -> Some name)
1041
+
m.fields
1042
+
in
1043
+
match missing with
1044
+
| Some name ->
1045
+
Error (Error.v ~ctx:path (Error.Missing_member name))
1046
+
| None -> Ok (m.build (lookup_or_fail path results))))
1085
1047
in
1086
1048
{
1087
1049
kind;
1088
1050
encode =
1089
1051
(fun v ->
1090
-
let fields = encode_mem v m [] in
1091
-
Value.Map
1092
-
(List.map (fun (k, v) -> (Value.Text k, v)) (List.rev fields)));
1052
+
let pairs =
1053
+
List.filter_map
1054
+
(fun (f : o field) ->
1055
+
match f.encode v with
1056
+
| None -> None
1057
+
| Some value -> Some (Value.Text f.name, value))
1058
+
m.fields
1059
+
in
1060
+
Value.Map pairs);
1093
1061
decode =
1094
1062
(fun path v ->
1095
1063
match v with
1096
-
| Value.Map pairs -> (
1097
-
let text_pairs =
1098
-
List.filter_map
1099
-
(fun (k, v) ->
1100
-
match k with Value.Text s -> Some (s, v) | _ -> None)
1101
-
pairs
1102
-
in
1103
-
match decode_mem path text_pairs m with
1104
-
| Error e -> Error e
1105
-
| Ok (result, _remaining) -> Ok result)
1064
+
| Value.Map pairs -> decode_value path pairs
1106
1065
| _ -> type_error path "map" v);
1107
-
decode_rw =
1108
-
(fun path dec ->
1109
-
match read_map_length_rw path dec with
1110
-
| Error e -> e
1111
-
| Ok len_opt -> (
1112
-
let dispatch = make_dispatch () in
1113
-
let results = Hashtbl.create (List.length decoder_list) in
1114
-
match decode_map_rw path dec len_opt dispatch results with
1115
-
| Error e -> Error e
1116
-
| Ok () -> resolve_mem path results m));
1066
+
decode_rw;
1117
1067
}
1118
1068
end
1119
1069
1120
1070
(* Integer-keyed object codec module *)
1071
+
1072
+
(* Integer-keyed object codec module. Mirrors {!Obj} but indexes fields by
1073
+
integer keys instead of text strings (the COSE/CWT layout). Same
1074
+
applicative shape; same Obj.magic-free assembly. *)
1121
1075
1122
1076
module Obj_int = struct
1123
-
type enc = (int * Value.t) list
1077
+
type 'o field = {
1078
+
key : int;
1079
+
encode : 'o -> Value.t option;
1080
+
decode_value :
1081
+
Loc.Context.t -> Value.t option -> (Stdlib.Obj.t, Error.t) result;
1082
+
decode_rw :
1083
+
Loc.Context.t -> Binary.decoder -> (Stdlib.Obj.t, Error.t) result;
1084
+
decode_missing : (Stdlib.Obj.t, int) result;
1085
+
}
1124
1086
1125
-
let field key (v : Value.t) (acc : enc) : enc = (key, v) :: acc
1087
+
type ('o, 'dec) mem = {
1088
+
fields : 'o field list;
1089
+
build : (int -> Stdlib.Obj.t) -> 'dec;
1090
+
}
1091
+
1092
+
let map ctor = { fields = []; build = (fun _ -> ctor) }
1126
1093
1127
-
let find_remove key pairs =
1128
-
let rec loop acc = function
1129
-
| [] -> (None, List.rev acc)
1130
-
| (k, v) :: rest when k = key -> (Some v, List.rev_append acc rest)
1131
-
| kv :: rest -> loop (kv :: acc) rest
1094
+
let mem (type o a b) key (get : o -> a) (codec : a t) (m : (o, a -> b) mem) :
1095
+
(o, b) mem =
1096
+
let key_str = string_of_int key in
1097
+
let encode o = Some (codec.encode (get o)) in
1098
+
let decode_value ctx v =
1099
+
let path' = Error.ctx_with_key key_str ctx in
1100
+
match v with
1101
+
| None -> Error (Error.v ~ctx:path' (Error.Missing_member key_str))
1102
+
| Some v -> (
1103
+
match codec.decode path' v with
1104
+
| Ok x -> Ok (Stdlib.Obj.repr x)
1105
+
| Error e -> Error e)
1132
1106
in
1133
-
loop [] pairs
1107
+
let decode_rw ctx dec =
1108
+
let path' = Error.ctx_with_key key_str ctx in
1109
+
match codec.decode_rw path' dec with
1110
+
| Ok x -> Ok (Stdlib.Obj.repr x)
1111
+
| Error e -> Error e
1112
+
in
1113
+
let field =
1114
+
{ key; encode; decode_value; decode_rw; decode_missing = Error key }
1115
+
in
1116
+
{
1117
+
fields = m.fields @ [ field ];
1118
+
build =
1119
+
(fun lookup ->
1120
+
let f = m.build lookup in
1121
+
let v : a = Stdlib.Obj.obj (lookup key) in
1122
+
f v);
1123
+
}
1134
1124
1135
-
type (_, _) mem =
1136
-
| Return : 'a -> ('o, 'a) mem
1137
-
| Mem : {
1138
-
key : int;
1139
-
get : 'o -> 'x;
1140
-
codec : 'x t;
1141
-
cont : 'x -> ('o, 'a) mem;
1142
-
}
1143
-
-> ('o, 'a) mem
1144
-
| Mem_opt : {
1145
-
key : int;
1146
-
get : 'o -> 'x option;
1147
-
codec : 'x t;
1148
-
cont : 'x option -> ('o, 'a) mem;
1149
-
}
1150
-
-> ('o, 'a) mem
1151
-
| Mem_default : {
1152
-
key : int;
1153
-
get : 'o -> 'x;
1154
-
codec : 'x t;
1155
-
default : 'x;
1156
-
cont : 'x -> ('o, 'a) mem;
1157
-
}
1158
-
-> ('o, 'a) mem
1159
-
1160
-
let return v = Return v
1161
-
let mem key get codec = Mem { key; get; codec; cont = (fun x -> Return x) }
1162
-
1163
-
let mem_opt key get codec =
1164
-
Mem_opt { key; get; codec; cont = (fun x -> Return x) }
1165
-
1166
-
let mem_default key get ~default codec =
1167
-
Mem_default { key; get; codec; default; cont = (fun x -> Return x) }
1168
-
1169
-
let rec ( let* ) : type o a b. (o, a) mem -> (a -> (o, b) mem) -> (o, b) mem =
1170
-
fun m f ->
1171
-
match m with
1172
-
| Return a -> f a
1173
-
| Mem r ->
1174
-
Mem
1175
-
{
1176
-
r with
1177
-
cont =
1178
-
(fun x ->
1179
-
let* y = r.cont x in
1180
-
f y);
1181
-
}
1182
-
| Mem_opt r ->
1183
-
Mem_opt
1184
-
{
1185
-
r with
1186
-
cont =
1187
-
(fun x ->
1188
-
let* y = r.cont x in
1189
-
f y);
1190
-
}
1191
-
| Mem_default r ->
1192
-
Mem_default
1193
-
{
1194
-
r with
1195
-
cont =
1196
-
(fun x ->
1197
-
let* y = r.cont x in
1198
-
f y);
1199
-
}
1200
-
1201
-
let rec decode_mem : type o a.
1202
-
Loc.Context.t ->
1203
-
(int * Value.t) list ->
1204
-
(o, a) mem ->
1205
-
(a * (int * Value.t) list, Error.t) result =
1206
-
fun path pairs m ->
1207
-
match m with
1208
-
| Return a -> Ok (a, pairs)
1209
-
| Mem { key; codec; cont; _ } -> (
1210
-
match find_remove key pairs with
1211
-
| None, _ ->
1212
-
Error (Error.v ~ctx:path (Error.Missing_member (string_of_int key)))
1213
-
| Some v, remaining -> (
1214
-
let path' = Error.ctx_with_key (string_of_int key) path in
1215
-
match codec.decode path' v with
1216
-
| Error e -> Error e
1217
-
| Ok x -> decode_mem path remaining (cont x)))
1218
-
| Mem_opt { key; codec; cont; _ } -> (
1219
-
match find_remove key pairs with
1220
-
| None, remaining -> decode_mem path remaining (cont None)
1221
-
| Some Value.Null, remaining -> decode_mem path remaining (cont None)
1222
-
| Some v, remaining -> (
1223
-
let path' = Error.ctx_with_key (string_of_int key) path in
1224
-
match codec.decode path' v with
1225
-
| Error e -> Error e
1226
-
| Ok x -> decode_mem path remaining (cont (Some x))))
1227
-
| Mem_default { key; codec; default; cont; _ } -> (
1228
-
match find_remove key pairs with
1229
-
| None, remaining -> decode_mem path remaining (cont default)
1230
-
| Some Value.Null, remaining -> decode_mem path remaining (cont default)
1231
-
| Some v, remaining -> (
1232
-
let path' = Error.ctx_with_key (string_of_int key) path in
1233
-
match codec.decode path' v with
1234
-
| Error e -> Error e
1235
-
| Ok x -> decode_mem path remaining (cont x)))
1236
-
1237
-
let rec encode_mem : type o a. o -> (o, a) mem -> enc -> enc =
1238
-
fun o m acc ->
1239
-
match m with
1240
-
| Return _ -> acc
1241
-
| Mem { key; get; codec; cont } ->
1242
-
let v = get o in
1243
-
let acc = field key (codec.encode v) acc in
1244
-
encode_mem o (cont v) acc
1245
-
| Mem_opt { key; get; codec; cont } ->
1246
-
let v = get o in
1247
-
let acc =
1248
-
match v with None -> acc | Some x -> field key (codec.encode x) acc
1249
-
in
1250
-
encode_mem o (cont v) acc
1251
-
| Mem_default { key; get; codec; cont; _ } ->
1252
-
let v = get o in
1253
-
let acc = field key (codec.encode v) acc in
1254
-
encode_mem o (cont v) acc
1255
-
1256
-
let rec member_keys : type o a. (o, a) mem -> int list = function
1257
-
| Return _ -> []
1258
-
| Mem { key; cont; _ } -> key :: member_keys (cont (Stdlib.Obj.magic ()))
1259
-
| Mem_opt { key; cont; _ } ->
1260
-
key :: member_keys (cont (Stdlib.Obj.magic ()))
1261
-
| Mem_default { key; cont; _ } ->
1262
-
key :: member_keys (cont (Stdlib.Obj.magic ()))
1263
-
1264
-
(* Build a dispatch table from integer key to a streaming decoder that
1265
-
stores the typed result into a hashtable keyed by int. *)
1266
-
type mem_decoder = {
1267
-
decode_rw_store :
1268
-
Loc.Context.t ->
1269
-
Binary.decoder ->
1270
-
(int, Stdlib.Obj.t) Hashtbl.t ->
1271
-
(unit, Error.t) result;
1272
-
}
1273
-
1274
-
let rec build_decoders : type o a. (o, a) mem -> (int * mem_decoder) list =
1275
-
function
1276
-
| Return _ -> []
1277
-
| Mem { key; codec; cont; _ } ->
1278
-
let entry =
1279
-
{
1280
-
decode_rw_store =
1281
-
(fun path dec tbl ->
1282
-
match codec.decode_rw path dec with
1283
-
| Ok v ->
1284
-
Hashtbl.replace tbl key (Stdlib.Obj.repr v);
1285
-
Ok ()
1286
-
| Error e -> Error e);
1287
-
}
1288
-
in
1289
-
(key, entry) :: build_decoders (cont (Stdlib.Obj.magic ()))
1290
-
| Mem_opt { key; codec; cont; _ } ->
1291
-
let entry =
1292
-
{
1293
-
decode_rw_store =
1294
-
(fun path dec tbl ->
1295
-
match Binary.peek_byte dec with
1296
-
| Some b
1297
-
when b lsr 5 = Binary.major_simple
1298
-
&& b land 0x1f = Binary.simple_null ->
1299
-
ignore (Binary.read_byte dec);
1300
-
Hashtbl.replace tbl key (Stdlib.Obj.repr None);
1301
-
Ok ()
1302
-
| _ -> (
1303
-
match codec.decode_rw path dec with
1304
-
| Ok v ->
1305
-
Hashtbl.replace tbl key (Stdlib.Obj.repr (Some v));
1306
-
Ok ()
1307
-
| Error e -> Error e));
1308
-
}
1309
-
in
1310
-
(key, entry) :: build_decoders (cont (Stdlib.Obj.magic ()))
1311
-
| Mem_default { key; codec; default; cont; _ } ->
1312
-
let entry =
1313
-
{
1314
-
decode_rw_store =
1315
-
(fun path dec tbl ->
1316
-
match Binary.peek_byte dec with
1317
-
| Some b
1318
-
when b lsr 5 = Binary.major_simple
1319
-
&& b land 0x1f = Binary.simple_null ->
1320
-
ignore (Binary.read_byte dec);
1321
-
Hashtbl.replace tbl key (Stdlib.Obj.repr default);
1322
-
Ok ()
1323
-
| _ -> (
1324
-
match codec.decode_rw path dec with
1325
-
| Ok v ->
1326
-
Hashtbl.replace tbl key (Stdlib.Obj.repr v);
1327
-
Ok ()
1328
-
| Error e -> Error e));
1329
-
}
1330
-
in
1331
-
(key, entry) :: build_decoders (cont (Stdlib.Obj.magic ()))
1125
+
let mem_opt (type o a b) key (get : o -> a option) (codec : a t)
1126
+
(m : (o, a option -> b) mem) : (o, b) mem =
1127
+
let key_str = string_of_int key in
1128
+
let none_obj : Stdlib.Obj.t = Stdlib.Obj.repr (None : a option) in
1129
+
let encode o =
1130
+
match get o with None -> None | Some x -> Some (codec.encode x)
1131
+
in
1132
+
let decode_value ctx v =
1133
+
match v with
1134
+
| None | Some Value.Null -> Ok none_obj
1135
+
| Some v -> (
1136
+
let path' = Error.ctx_with_key key_str ctx in
1137
+
match codec.decode path' v with
1138
+
| Ok x -> Ok (Stdlib.Obj.repr (Some x : a option))
1139
+
| Error e -> Error e)
1140
+
in
1141
+
let decode_rw ctx dec =
1142
+
match Binary.peek_byte dec with
1143
+
| Some b
1144
+
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
1145
+
->
1146
+
ignore (Binary.read_byte dec);
1147
+
Ok none_obj
1148
+
| _ -> (
1149
+
let path' = Error.ctx_with_key key_str ctx in
1150
+
match codec.decode_rw path' dec with
1151
+
| Ok x -> Ok (Stdlib.Obj.repr (Some x : a option))
1152
+
| Error e -> Error e)
1153
+
in
1154
+
let field =
1155
+
{ key; encode; decode_value; decode_rw; decode_missing = Ok none_obj }
1156
+
in
1157
+
{
1158
+
fields = m.fields @ [ field ];
1159
+
build =
1160
+
(fun lookup ->
1161
+
let f = m.build lookup in
1162
+
let v : a option = Stdlib.Obj.obj (lookup key) in
1163
+
f v);
1164
+
}
1332
1165
1333
-
let rec resolve_mem : type o a.
1334
-
Loc.Context.t ->
1335
-
(int, Stdlib.Obj.t) Hashtbl.t ->
1336
-
(o, a) mem ->
1337
-
(a, Error.t) result =
1338
-
fun path tbl m ->
1339
-
match m with
1340
-
| Return a -> Ok a
1341
-
| Mem { key; cont; _ } -> (
1342
-
match Hashtbl.find_opt tbl key with
1343
-
| None ->
1344
-
Error (Error.v ~ctx:path (Error.Missing_member (string_of_int key)))
1345
-
| Some obj -> resolve_mem path tbl (cont (Stdlib.Obj.obj obj)))
1346
-
| Mem_opt { key; cont; _ } -> (
1347
-
match Hashtbl.find_opt tbl key with
1348
-
| None -> resolve_mem path tbl (cont None)
1349
-
| Some obj -> resolve_mem path tbl (cont (Stdlib.Obj.obj obj)))
1350
-
| Mem_default { key; default; cont; _ } -> (
1351
-
match Hashtbl.find_opt tbl key with
1352
-
| None -> resolve_mem path tbl (cont default)
1353
-
| Some obj -> resolve_mem path tbl (cont (Stdlib.Obj.obj obj)))
1166
+
let mem_default (type o a b) key (get : o -> a) ~(default : a) (codec : a t)
1167
+
(m : (o, a -> b) mem) : (o, b) mem =
1168
+
let key_str = string_of_int key in
1169
+
let default_obj : Stdlib.Obj.t = Stdlib.Obj.repr default in
1170
+
let encode o = Some (codec.encode (get o)) in
1171
+
let decode_value ctx v =
1172
+
match v with
1173
+
| None | Some Value.Null -> Ok default_obj
1174
+
| Some v -> (
1175
+
let path' = Error.ctx_with_key key_str ctx in
1176
+
match codec.decode path' v with
1177
+
| Ok x -> Ok (Stdlib.Obj.repr x)
1178
+
| Error e -> Error e)
1179
+
in
1180
+
let decode_rw ctx dec =
1181
+
match Binary.peek_byte dec with
1182
+
| Some b
1183
+
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
1184
+
->
1185
+
ignore (Binary.read_byte dec);
1186
+
Ok default_obj
1187
+
| _ -> (
1188
+
let path' = Error.ctx_with_key key_str ctx in
1189
+
match codec.decode_rw path' dec with
1190
+
| Ok x -> Ok (Stdlib.Obj.repr x)
1191
+
| Error e -> Error e)
1192
+
in
1193
+
let field =
1194
+
{ key; encode; decode_value; decode_rw; decode_missing = Ok default_obj }
1195
+
in
1196
+
{
1197
+
fields = m.fields @ [ field ];
1198
+
build =
1199
+
(fun lookup ->
1200
+
let f = m.build lookup in
1201
+
let v : a = Stdlib.Obj.obj (lookup key) in
1202
+
f v);
1203
+
}
1354
1204
1355
-
(* Read an integer key from the stream, returning Some int or None
1356
-
if the key is not an integer or does not fit in OCaml int. *)
1357
1205
let read_int_key dec =
1358
1206
let key_hdr = Binary.read_header dec in
1359
1207
if key_hdr.major = 0 || key_hdr.major = 1 then
···
1364
1212
if Z.fits_int kz then Some (Z.to_int kz) else None
1365
1213
else None
1366
1214
1367
-
let decode_int_map_rw path dec len_opt dispatch tbl =
1368
-
let n = match len_opt with Some n -> n | None -> max_int in
1369
-
let rec loop i =
1370
-
if i >= n then Ok ()
1371
-
else if len_opt = None && Binary.is_break dec then (
1372
-
Binary.skip_break dec;
1373
-
Ok ())
1374
-
else
1375
-
match Binary.peek_byte dec with
1376
-
| Some b when b lsr 5 = Binary.major_uint || b lsr 5 = Binary.major_nint
1377
-
-> (
1378
-
match read_int_key dec with
1379
-
| Some key -> (
1380
-
match Hashtbl.find_opt dispatch key with
1381
-
| Some entry -> (
1382
-
let path' = Error.ctx_with_key (string_of_int key) path in
1383
-
match entry.decode_rw_store path' dec tbl with
1384
-
| Ok () -> loop (i + 1)
1385
-
| Error e -> Error e)
1386
-
| None ->
1387
-
Binary.skip dec;
1388
-
loop (i + 1))
1389
-
| None ->
1390
-
(* Key too large for int, skip value *)
1391
-
Binary.skip dec;
1392
-
loop (i + 1))
1393
-
| _ ->
1394
-
(* Non-integer key: skip key and value *)
1395
-
Binary.skip dec;
1396
-
Binary.skip dec;
1397
-
loop (i + 1)
1398
-
in
1399
-
loop 0
1400
-
1401
-
let seal (m : ('o, 'o) mem) : 'o t =
1402
-
let keys = member_keys m in
1215
+
let seal (type o) (m : (o, o) mem) : o t =
1216
+
let keys = List.map (fun (f : o field) -> f.key) m.fields in
1403
1217
let kind =
1404
1218
Fmt.str "obj_int({%s})" (String.concat ", " (List.map string_of_int keys))
1405
1219
in
1406
-
let decoder_list = build_decoders m in
1407
-
let make_dispatch () =
1408
-
let tbl = Hashtbl.create (List.length decoder_list) in
1409
-
List.iter (fun (key, entry) -> Hashtbl.replace tbl key entry) decoder_list;
1410
-
tbl
1220
+
let by_key : (int, o field) Hashtbl.t =
1221
+
Hashtbl.create (List.length m.fields)
1222
+
in
1223
+
List.iter (fun (f : o field) -> Hashtbl.replace by_key f.key f) m.fields;
1224
+
let lookup_or_fail path tbl =
1225
+
let lookup key =
1226
+
match Hashtbl.find_opt tbl key with
1227
+
| Some v -> v
1228
+
| None ->
1229
+
Stdlib.invalid_arg
1230
+
(Fmt.str "Cbor.Obj_int.seal: missing %d for %a" key Loc.Context.pp
1231
+
path)
1232
+
in
1233
+
lookup
1234
+
in
1235
+
let decode_value path values =
1236
+
let pairs =
1237
+
List.filter_map
1238
+
(fun (k, v) ->
1239
+
match k with
1240
+
| Value.Int n when Z.fits_int n -> Some (Z.to_int n, v)
1241
+
| _ -> None)
1242
+
values
1243
+
in
1244
+
let pairs_tbl = Hashtbl.create (List.length pairs) in
1245
+
List.iter (fun (k, v) -> Hashtbl.replace pairs_tbl k v) pairs;
1246
+
let results = Hashtbl.create (List.length m.fields) in
1247
+
let rec fill = function
1248
+
| [] -> Ok ()
1249
+
| (f : o field) :: rest -> (
1250
+
let v_opt = Hashtbl.find_opt pairs_tbl f.key in
1251
+
match f.decode_value path v_opt with
1252
+
| Error e -> Error e
1253
+
| Ok obj ->
1254
+
Hashtbl.replace results f.key obj;
1255
+
fill rest)
1256
+
in
1257
+
match fill m.fields with
1258
+
| Error e -> Error e
1259
+
| Ok () -> Ok (m.build (lookup_or_fail path results))
1260
+
in
1261
+
let decode_rw path dec =
1262
+
match read_map_length_rw path dec with
1263
+
| Error e -> e
1264
+
| Ok len_opt -> (
1265
+
let results = Hashtbl.create (List.length m.fields) in
1266
+
let n = match len_opt with Some n -> n | None -> max_int in
1267
+
let rec read i =
1268
+
if i >= n then Ok ()
1269
+
else if len_opt = None && Binary.is_break dec then (
1270
+
Binary.skip_break dec;
1271
+
Ok ())
1272
+
else
1273
+
match Binary.peek_byte dec with
1274
+
| Some b
1275
+
when b lsr 5 = Binary.major_uint || b lsr 5 = Binary.major_nint
1276
+
-> (
1277
+
match read_int_key dec with
1278
+
| Some key -> (
1279
+
match Hashtbl.find_opt by_key key with
1280
+
| Some f -> (
1281
+
match f.decode_rw path dec with
1282
+
| Error e -> Error e
1283
+
| Ok obj ->
1284
+
Hashtbl.replace results key obj;
1285
+
read (i + 1))
1286
+
| None ->
1287
+
Binary.skip dec;
1288
+
read (i + 1))
1289
+
| None ->
1290
+
Binary.skip dec;
1291
+
read (i + 1))
1292
+
| _ ->
1293
+
Binary.skip dec;
1294
+
Binary.skip dec;
1295
+
read (i + 1)
1296
+
in
1297
+
match read 0 with
1298
+
| Error e -> Error e
1299
+
| Ok () -> (
1300
+
let missing =
1301
+
List.find_map
1302
+
(fun (f : o field) ->
1303
+
if Hashtbl.mem results f.key then None
1304
+
else
1305
+
match f.decode_missing with
1306
+
| Ok obj ->
1307
+
Hashtbl.replace results f.key obj;
1308
+
None
1309
+
| Error key -> Some key)
1310
+
m.fields
1311
+
in
1312
+
match missing with
1313
+
| Some key ->
1314
+
Error
1315
+
(Error.v ~ctx:path
1316
+
(Error.Missing_member (string_of_int key)))
1317
+
| None -> Ok (m.build (lookup_or_fail path results))))
1411
1318
in
1412
1319
{
1413
1320
kind;
1414
1321
encode =
1415
1322
(fun v ->
1416
-
let fields = encode_mem v m [] in
1417
-
Value.Map
1418
-
(List.map
1419
-
(fun (k, v) -> (Value.Int (Z.of_int k), v))
1420
-
(List.rev fields)));
1323
+
let pairs =
1324
+
List.filter_map
1325
+
(fun (f : o field) ->
1326
+
match f.encode v with
1327
+
| None -> None
1328
+
| Some value -> Some (Value.Int (Z.of_int f.key), value))
1329
+
m.fields
1330
+
in
1331
+
Value.Map pairs);
1421
1332
decode =
1422
1333
(fun path v ->
1423
1334
match v with
1424
-
| Value.Map pairs -> (
1425
-
let int_pairs =
1426
-
List.filter_map
1427
-
(fun (k, v) ->
1428
-
match k with
1429
-
| Value.Int n when Z.fits_int n -> Some (Z.to_int n, v)
1430
-
| _ -> None)
1431
-
pairs
1432
-
in
1433
-
match decode_mem path int_pairs m with
1434
-
| Error e -> Error e
1435
-
| Ok (result, _remaining) -> Ok result)
1335
+
| Value.Map pairs -> decode_value path pairs
1436
1336
| _ -> type_error path "map" v);
1437
-
decode_rw =
1438
-
(fun path dec ->
1439
-
match read_map_length_rw path dec with
1440
-
| Error e -> e
1441
-
| Ok len_opt -> (
1442
-
let dispatch = make_dispatch () in
1443
-
let results = Hashtbl.create (List.length decoder_list) in
1444
-
match decode_int_map_rw path dec len_opt dispatch results with
1445
-
| Error e -> Error e
1446
-
| Ok () -> resolve_mem path results m));
1337
+
decode_rw;
1447
1338
}
1448
1339
end
1449
1340
+78
-43
lib/cbor.mli
+78
-43
lib/cbor.mli
···
19
19
type person = { name : string; age : int }
20
20
21
21
let person_codec : person Cbor.t =
22
-
let open Cbor.Obj in
23
-
seal
24
-
(let* name = mem "name" (fun p -> p.name) Cbor.string in
25
-
let* age = mem "age" (fun p -> p.age) Cbor.int in
26
-
return { name; age })
22
+
Cbor.Obj.map (fun name age -> { name; age })
23
+
|> Cbor.Obj.mem "name" (fun p -> p.name) Cbor.string
24
+
|> Cbor.Obj.mem "age" (fun p -> p.age) Cbor.int
25
+
|> Cbor.Obj.seal
27
26
28
27
let alice = { name = "Alice"; age = 30 }
29
28
let cbor_bytes = Cbor.encode_string person_codec alice
···
172
171
(** {1:objects Object Codecs}
173
172
174
173
Build codecs for records and objects from CBOR maps with text string keys.
175
-
Uses a monadic interface for composing member codecs. *)
176
-
module Obj : sig
177
-
type ('o, 'a) mem
178
-
(** A member specification. ['o] is the object type being built, ['a] is the
179
-
decoded value at this step. *)
174
+
The shape mirrors [Json.Codec.Object]: start with {!map} and a curried
175
+
record constructor, thread the constructor through {!mem} / {!mem_opt} /
176
+
{!mem_default} (one application per field), and close with {!seal}.
180
177
181
-
val ( let* ) : ('o, 'a) mem -> ('a -> ('o, 'b) mem) -> ('o, 'b) mem
182
-
(** Monadic bind for sequencing member decoders. *)
178
+
{[
179
+
type person = { name : string; age : int; email : string option }
183
180
184
-
val mem : string -> ('o -> 'a) -> 'a t -> ('o, 'a) mem
185
-
(** [mem name get c] declares a required member with key [name] decoded by
186
-
[c]. The [get] function extracts the field value from the object for
187
-
encoding. *)
181
+
let person_codec : person Cbor.t =
182
+
Cbor.Obj.map (fun name age email -> { name; age; email })
183
+
|> Cbor.Obj.mem "name" (fun p -> p.name) Cbor.string
184
+
|> Cbor.Obj.mem "age" (fun p -> p.age) Cbor.int
185
+
|> Cbor.Obj.mem_opt "email" (fun p -> p.email) Cbor.string
186
+
|> Cbor.Obj.seal
187
+
]}
188
188
189
-
val mem_opt : string -> ('o -> 'a option) -> 'a t -> ('o, 'a option) mem
190
-
(** [mem_opt name get c] declares an optional member. Returns [None] if the
191
-
key is absent or the value is null. *)
189
+
The pipeline never inspects a synthetic value to walk its own shape, so the
190
+
implementation is free of [Obj.magic]. *)
191
+
module Obj : sig
192
+
type ('o, 'dec) mem
193
+
(** A partially-applied curried constructor for an object of type ['o]. The
194
+
['dec] parameter is the constructor's remaining arrow type — every {!mem}
195
+
application consumes one argument; {!seal} fires when ['dec] equals ['o].
196
+
*)
192
197
193
-
val mem_default : string -> ('o -> 'a) -> default:'a -> 'a t -> ('o, 'a) mem
194
-
(** [mem_default name get ~default c] declares a member with a default value
195
-
used when the key is absent. *)
198
+
val map : 'dec -> ('o, 'dec) mem
199
+
(** [map ctor] starts a member chain with [ctor] as the unsaturated
200
+
constructor (e.g. [fun a b c -> { a; b; c }]). *)
196
201
197
-
val return : 'o -> ('o, 'o) mem
198
-
(** [return v] completes the object codec, returning the built value. *)
202
+
val mem : string -> ('o -> 'a) -> 'a t -> ('o, 'a -> 'b) mem -> ('o, 'b) mem
203
+
(** [mem name get c m] declares a required member at key [name] decoded by
204
+
[c]. [get] extracts the field for encoding. Consumes one argument of the
205
+
curried constructor in [m]. *)
206
+
207
+
val mem_opt :
208
+
string ->
209
+
('o -> 'a option) ->
210
+
'a t ->
211
+
('o, 'a option -> 'b) mem ->
212
+
('o, 'b) mem
213
+
(** [mem_opt name get c m] declares an optional member. The constructor
214
+
receives the field's value as an [option]; absent / null both decode to
215
+
[None]. *)
216
+
217
+
val mem_default :
218
+
string ->
219
+
('o -> 'a) ->
220
+
default:'a ->
221
+
'a t ->
222
+
('o, 'a -> 'b) mem ->
223
+
('o, 'b) mem
224
+
(** [mem_default name get ~default c m] declares a member that falls back to
225
+
[default] when the key is absent or the value is null. *)
199
226
200
227
val seal : ('o, 'o) mem -> 'o t
201
-
(** [seal m] converts the member specification to a codec. *)
228
+
(** [seal m] converts the saturated member chain into a codec. *)
202
229
end
203
230
204
231
(** {1:int_objects Integer-Keyed Objects}
205
232
206
-
Build codecs for maps with integer keys. Common in COSE, CWT, and other
207
-
space-efficient binary protocols. *)
233
+
Same pipeline as {!Obj}, but indexes fields by integer keys (the COSE / CWT
234
+
layout). *)
208
235
module Obj_int : sig
209
-
type ('o, 'a) mem
210
-
(** A member specification. ['o] is the object type being built, ['a] is the
211
-
decoded value at this step. *)
212
-
213
-
val ( let* ) : ('o, 'a) mem -> ('a -> ('o, 'b) mem) -> ('o, 'b) mem
214
-
(** Monadic bind for sequencing member decoders. *)
236
+
type ('o, 'dec) mem
237
+
(** As in {!Obj.mem} but keyed by integer. *)
215
238
216
-
val mem : int -> ('o -> 'a) -> 'a t -> ('o, 'a) mem
217
-
(** [mem key get c] declares a required member with integer key [key]. The
218
-
[get] function extracts the field value for encoding. *)
239
+
val map : 'dec -> ('o, 'dec) mem
240
+
(** [map ctor] starts a member chain with [ctor] as the unsaturated
241
+
constructor. *)
219
242
220
-
val mem_opt : int -> ('o -> 'a option) -> 'a t -> ('o, 'a option) mem
221
-
(** [mem_opt key get c] declares an optional member with integer key. *)
243
+
val mem : int -> ('o -> 'a) -> 'a t -> ('o, 'a -> 'b) mem -> ('o, 'b) mem
244
+
(** [mem key get c m] declares a required member at integer key [key]. *)
222
245
223
-
val mem_default : int -> ('o -> 'a) -> default:'a -> 'a t -> ('o, 'a) mem
224
-
(** [mem_default key get ~default c] declares a member with default value. *)
246
+
val mem_opt :
247
+
int ->
248
+
('o -> 'a option) ->
249
+
'a t ->
250
+
('o, 'a option -> 'b) mem ->
251
+
('o, 'b) mem
252
+
(** [mem_opt key get c m] declares an optional member with integer key. *)
225
253
226
-
val return : 'o -> ('o, 'o) mem
227
-
(** [return v] completes the codec. *)
254
+
val mem_default :
255
+
int ->
256
+
('o -> 'a) ->
257
+
default:'a ->
258
+
'a t ->
259
+
('o, 'a -> 'b) mem ->
260
+
('o, 'b) mem
261
+
(** [mem_default key get ~default c m] declares a member that falls back to
262
+
[default] when the key is absent or the value is null. *)
228
263
229
264
val seal : ('o, 'o) mem -> 'o t
230
-
(** [seal m] converts to a codec. *)
265
+
(** [seal m] converts the saturated member chain into a codec. *)
231
266
end
232
267
233
268
(** {1:tags Tagged Values}
+8
-10
test/test_cbor.ml
+8
-10
test/test_cbor.ml
···
352
352
let decoded = Cbor.decode_string_exn (Cbor.tag 1 Cbor.int) encoded in
353
353
assert (decoded = v));
354
354
Alcotest.test_case "codec: Obj" `Quick (fun () ->
355
-
let open Cbor.Obj in
356
355
let codec =
357
-
let* name = mem "name" fst Cbor.string in
358
-
let* age = mem "age" snd Cbor.int in
359
-
return (name, age)
356
+
Cbor.Obj.map (fun name age -> (name, age))
357
+
|> Cbor.Obj.mem "name" fst Cbor.string
358
+
|> Cbor.Obj.mem "age" snd Cbor.int
359
+
|> Cbor.Obj.seal
360
360
in
361
-
let codec = seal codec in
362
361
let v = ("Alice", 30) in
363
362
let encoded = Cbor.encode_string codec v in
364
363
let decoded = Cbor.decode_string_exn codec encoded in
···
676
675
(Cbor.kind (Cbor.tag 1 Cbor.int)));
677
676
Alcotest.test_case "kind: obj codec" `Quick (fun () ->
678
677
let codec =
679
-
let open Cbor.Obj in
680
-
let* name = mem "name" fst Cbor.string in
681
-
let* age = mem "age" snd Cbor.int in
682
-
return (name, age)
678
+
Cbor.Obj.map (fun name age -> (name, age))
679
+
|> Cbor.Obj.mem "name" fst Cbor.string
680
+
|> Cbor.Obj.mem "age" snd Cbor.int
681
+
|> Cbor.Obj.seal
683
682
in
684
-
let codec = Cbor.Obj.seal codec in
685
683
let k = Cbor.kind codec in
686
684
Alcotest.(check string) "obj kind" "obj({name, age})" k);
687
685
Alcotest.test_case "kind: query codecs" `Quick (fun () ->
+10
-14
test/test_value.ml
+10
-14
test/test_value.ml
···
497
497
type person = { name : string; age : int; email : string option }
498
498
499
499
let person_codec =
500
-
Cbor.Obj.seal
501
-
@@
502
-
let open Cbor.Obj in
503
-
let* name = mem "name" (fun p -> p.name) Cbor.string in
504
-
let* age = mem "age" (fun p -> p.age) Cbor.int in
505
-
let* email = mem_opt "email" (fun p -> p.email) Cbor.string in
506
-
return { name; age; email }
500
+
Cbor.Obj.map (fun name age email -> { name; age; email })
501
+
|> Cbor.Obj.mem "name" (fun p -> p.name) Cbor.string
502
+
|> Cbor.Obj.mem "age" (fun p -> p.age) Cbor.int
503
+
|> Cbor.Obj.mem_opt "email" (fun p -> p.email) Cbor.string
504
+
|> Cbor.Obj.seal
507
505
508
506
let test_obj_codec_basic () =
509
507
let v = { name = "Alice"; age = 30; email = None } in
···
536
534
}
537
535
538
536
let cwt_claims_codec =
539
-
Cbor.Obj_int.seal
540
-
@@
541
-
let open Cbor.Obj_int in
542
-
let* iss = mem_opt 1 (fun c -> c.iss) Cbor.string in
543
-
let* sub = mem_opt 2 (fun c -> c.sub) Cbor.string in
544
-
let* exp = mem_opt 4 (fun c -> c.exp) Cbor.int64 in
545
-
return { iss; sub; exp }
537
+
Cbor.Obj_int.map (fun iss sub exp -> { iss; sub; exp })
538
+
|> Cbor.Obj_int.mem_opt 1 (fun c -> c.iss) Cbor.string
539
+
|> Cbor.Obj_int.mem_opt 2 (fun c -> c.sub) Cbor.string
540
+
|> Cbor.Obj_int.mem_opt 4 (fun c -> c.exp) Cbor.int64
541
+
|> Cbor.Obj_int.seal
546
542
547
543
let test_obj_int_codec () =
548
544
let v =