diff --git a/src-bs/decoders_util.ml b/src-bs/decoders_util.ml index 2e41740..6813caf 100644 --- a/src-bs/decoders_util.ml +++ b/src-bs/decoders_util.ml @@ -24,6 +24,8 @@ end module My_opt = struct let return x = Some x + let map f x = Belt.Option.map x f + let flat_map f x = Belt.Option.flatMap x f end @@ -37,7 +39,7 @@ module My_list = struct let find_map f xs = xs |. Belt.List.getBy (fun x -> - match f x with Some _ -> true | None -> false) + match f x with Some _ -> true | None -> false ) |. Belt.Option.flatMap f diff --git a/src-bs/decoders_util.mli b/src-bs/decoders_util.mli index a2a71b2..1e31194 100644 --- a/src-bs/decoders_util.mli +++ b/src-bs/decoders_util.mli @@ -19,6 +19,8 @@ end module My_opt : sig val return : 'a -> 'a option + val map : ('a -> 'b) -> 'a option -> 'b option + val flat_map : ('a -> 'b option) -> 'a option -> 'b option end diff --git a/src/decode.ml b/src/decode.ml index b96fba6..44583bf 100644 --- a/src/decode.ml +++ b/src/decode.ml @@ -1,6 +1,7 @@ (** Functors for creating Decoders. *) -open Decoders_util +module U = Decoders_util +open U type ('good, 'bad) result = ('good, 'bad) My_result.t = | Ok of 'good @@ -228,6 +229,163 @@ module Make (Decodeable : Decodeable) : e ) + let keys' : 'k decoder -> 'k list decoder = + fun key_decoder value -> + match Decodeable.get_key_value_pairs value with + | Some assoc -> + assoc + |> List.map (fun (key, _) -> key_decoder key) + |> combine_errors + |> My_result.map_err + (Error.tag_group "Failed while decoding the keys of an object") + | None -> + (fail "Expected an object") value + + + let keys = keys' string + + let key_value_pairs' : 'k decoder -> 'v decoder -> ('k * 'v) list decoder = + fun key_decoder value_decoder value -> + match Decodeable.get_key_value_pairs value with + | Some assoc -> + assoc + |> List.map + My_result.Infix.( + fun (key_val, value_val) -> + key_decoder key_val + >>= fun key -> + value_decoder value_val >|= fun value -> (key, value)) + |> combine_errors + |> My_result.map_err + (Error.tag_group "Failed while decoding key-value pairs") + | None -> + (fail "Expected an object") value + + + let key_value_pairs value_decoder = key_value_pairs' string value_decoder + + let key_value_pairs_seq' : 'k decoder -> ('k -> 'v decoder) -> 'v list decoder + = + fun key_decoder value_decoder value -> + match Decodeable.get_key_value_pairs value with + | Some assoc -> + assoc + |> List.map + My_result.Infix.( + fun (key_val, value_val) -> + key_decoder key_val + >>= fun key -> (value_decoder key) value_val) + |> combine_errors + |> My_result.map_err + (Error.tag_group "Failed while decoding key-value pairs") + | None -> + (fail "Expected an object") value + + + let key_value_pairs_seq value_decoder = + key_value_pairs_seq' string value_decoder + + + module Obj = struct + type t = + { context : value + ; map : value U.String_map.t + } + + type 'a obj = (t, 'a * t) Decoder.t + + let succeed x t = Ok (x, t) + + let bind : ('a -> 'b obj) -> 'a obj -> 'b obj = + fun f dec t -> match dec t with Ok (x, t) -> f x t | Error e -> Error e + + + let map f dec t = + match dec t with Ok (x, t) -> Ok (f x, t) | Error e -> Error e + + + let apply f dec t = + match f t with + | Ok (f, t) -> + (match dec t with Ok (x, t) -> Ok (f x, t) | Error e -> Error e) + | Error e -> + Error e + + + module Infix = struct + let ( >>= ) x f = bind f x + + let ( >|= ) x f = map f x + + let ( <*> ) x f = apply f x + + (* let monoid_product a b = map (fun x y -> (x, y)) a <*> b *) + + let ( let+ ) = ( >|= ) + + (* let ( and+ ) = monoid_product *) + + let ( let* ) = ( >>= ) + + (* let ( and* ) = monoid_product *) + end + + let field_opt key v_dec : 'a option obj = + fun t -> + match U.String_map.get key t.map with + | None -> + Ok (None, t) + | Some value -> + let m = U.String_map.remove key t.map in + let t = { t with map = m } in + ( match v_dec value with + | Ok x -> + Ok (Some x, t) + | Error e -> + Error (Error.map_context (fun context -> { t with context }) e) ) + + + let field key v_dec : 'a obj = + fun t -> + match field_opt key v_dec t with + | Ok (Some x, t) -> + Ok (x, t) + | Ok (None, _t) -> + Error + (Error.make + (Printf.sprintf "Expected an object with an attribute %S" key) + ~context:t ) + | Error e -> + Error e + + + let empty : unit obj = + fun t -> + match U.String_map.choose_opt t.map with + | None -> + Ok ((), t) + | Some (k, _) -> + Error + (Error.make + (Printf.sprintf + "Expected an empty object, but have unconsumed field %S" + k ) + ~context:t ) + + + let run : 'a obj -> 'a decoder = + fun dec context -> + match key_value_pairs value context with + | Ok l -> + let map = U.String_map.of_list l in + let t = { context; map } in + dec t + |> U.My_result.map (fun (x, _) -> x) + |> U.My_result.map_err (Error.map_context (fun t -> t.context)) + | Error e -> + Error e + end + let field : string -> 'a decoder -> 'a decoder = fun key value_decoder t -> let value = @@ -343,63 +501,6 @@ module Make (Decodeable : Decodeable) : fail "Must provide at least one key to 'at'" - let keys' : 'k decoder -> 'k list decoder = - fun key_decoder value -> - match Decodeable.get_key_value_pairs value with - | Some assoc -> - assoc - |> List.map (fun (key, _) -> key_decoder key) - |> combine_errors - |> My_result.map_err - (Error.tag_group "Failed while decoding the keys of an object") - | None -> - (fail "Expected an object") value - - - let keys = keys' string - - let key_value_pairs' : 'k decoder -> 'v decoder -> ('k * 'v) list decoder = - fun key_decoder value_decoder value -> - match Decodeable.get_key_value_pairs value with - | Some assoc -> - assoc - |> List.map - My_result.Infix.( - fun (key_val, value_val) -> - key_decoder key_val - >>= fun key -> - value_decoder value_val >|= fun value -> (key, value)) - |> combine_errors - |> My_result.map_err - (Error.tag_group "Failed while decoding key-value pairs") - | None -> - (fail "Expected an object") value - - - let key_value_pairs value_decoder = key_value_pairs' string value_decoder - - let key_value_pairs_seq' : 'k decoder -> ('k -> 'v decoder) -> 'v list decoder - = - fun key_decoder value_decoder value -> - match Decodeable.get_key_value_pairs value with - | Some assoc -> - assoc - |> List.map - My_result.Infix.( - fun (key_val, value_val) -> - key_decoder key_val - >>= fun key -> (value_decoder key) value_val) - |> combine_errors - |> My_result.map_err - (Error.tag_group "Failed while decoding key-value pairs") - | None -> - (fail "Expected an object") value - - - let key_value_pairs_seq value_decoder = - key_value_pairs_seq' string value_decoder - - let decode_value (decoder : 'a decoder) (input : value) : ('a, error) result = decoder input diff --git a/src/decoders_util.ml b/src/decoders_util.ml index 20b3fa6..95023df 100644 --- a/src/decoders_util.ml +++ b/src/decoders_util.ml @@ -163,6 +163,18 @@ module My_list = struct aux f l (fun l -> l) end +module String_map = struct + include Map.Make (String) + + let add_list m l = List.fold_left (fun m (k, v) -> add k v m) m l + + let of_list l = add_list empty l + + let get = find_opt + + let choose_opt m = try Some (choose m) with Not_found -> None +end + let with_file_in file f = let ic = open_in file in try diff --git a/src/decoders_util.mli b/src/decoders_util.mli index 913a1db..7a59ed8 100644 --- a/src/decoders_util.mli +++ b/src/decoders_util.mli @@ -47,6 +47,18 @@ module My_list : sig val flat_map : ('a -> 'b list) -> 'a list -> 'b list end +module String_map : sig + type 'a t + + val of_list : (string * 'a) list -> 'a t + + val get : string -> 'a t -> 'a option + + val remove : string -> 'a t -> 'a t + + val choose_opt : 'a t -> (string * 'a) option +end + val with_file_in : string -> (in_channel -> 'a) -> 'a val read_all : in_channel -> string diff --git a/src/error.ml b/src/error.ml index ead1fb0..7c77229 100644 --- a/src/error.ml +++ b/src/error.ml @@ -1,3 +1,5 @@ +module U = Decoders_util + type 'a t = | E of { msg : string @@ -25,7 +27,7 @@ let rec pp pp_context fmt = fprintf fmt "@[<2>%s:@ %a@]" msg (pp pp_context) e | Group es -> let max_errors = 5 in - let es_trunc = Decoders_util.My_list.take max_errors es in + let es_trunc = U.My_list.take max_errors es in let not_shown = List.length es - max_errors in fprintf fmt @@ -38,3 +40,11 @@ let rec pp pp_context fmt = let map_tag f = function Tag (s, e) -> Tag (f s, e) | e -> e + +let rec map_context f = function + | E { msg; context } -> + E { msg; context = U.My_opt.map f context } + | Tag (s, e) -> + Tag (s, map_context f e) + | Group es -> + Group (U.My_list.map (map_context f) es) diff --git a/src/error.mli b/src/error.mli index 9b29f9c..d33730f 100644 --- a/src/error.mli +++ b/src/error.mli @@ -12,3 +12,5 @@ val tag_group : string -> 'a t list -> 'a t val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit val map_tag : (string -> string) -> 'a t -> 'a t + +val map_context : ('a -> 'b) -> 'a t -> 'b t diff --git a/src/sig.ml b/src/sig.ml index f1d3eb9..68fd444 100644 --- a/src/sig.ml +++ b/src/sig.ml @@ -119,6 +119,36 @@ module type S = sig (** {1 Object primitives} *) + module Obj : sig + type 'a obj + + val run : 'a obj -> 'a decoder + + val succeed : 'a -> 'a obj + + val bind : ('a -> 'b obj) -> 'a obj -> 'b obj + + val map : ('a -> 'b) -> 'a obj -> 'b obj + + val field : string -> 'a decoder -> 'a obj + + val field_opt : string -> 'a decoder -> 'a option obj + + val empty : unit obj + + module Infix : sig + val ( >>= ) : 'a obj -> ('a -> 'b obj) -> 'b obj + + val ( >|= ) : 'a obj -> ('a -> 'b) -> 'b obj + + val ( <*> ) : 'a obj -> ('a -> 'b) obj -> 'b obj + + val ( let* ) : 'a obj -> ('a -> 'b obj) -> 'b obj + + val ( let+ ) : 'a obj -> ('a -> 'b) -> 'b obj + end + end + val field : string -> 'a decoder -> 'a decoder (** Decode an object, requiring a particular field. *) diff --git a/test-yojson/main.ml b/test-yojson/main.ml index 3bced63..42f375c 100644 --- a/test-yojson/main.ml +++ b/test-yojson/main.ml @@ -172,6 +172,57 @@ let yojson_basic_suite = Format.asprintf "@,@[%a@]" pp_error e) in + let obj_test = + "objects" + >:: fun _test_ctxt -> + let obj = + Obj.( + let open Infix in + let* name = field "name" string in + let* age = field "age" int in + let* () = empty in + succeed (name, age)) + in + let decoder = Obj.run obj in + let input = {| {"name": "Jim", "age": 42} |} in + match decode_string decoder input with + | Ok value -> + assert_equal value ("Jim", 42) + | Error error -> + assert_string (Format.asprintf "%a" pp_error error) + in + + let obj_test_2 = + "objects with remaining fields" + >:: fun _test_ctxt -> + let obj = + Obj.( + let open Infix in + let* name = field "name" string in + let* age = field "age" int in + let* () = empty in + succeed (name, age)) + in + let decoder = Obj.run obj in + let input = {| {"name": "Jim", "age": 42, "another": "thing"} |} in + match decode_string decoder input with + | Ok _ -> + assert_string "Expected an error" + | Error error -> + let open Decoders in + assert_equal + error + (Error.make + {|Expected an empty object, but have unconsumed field "another"|} + ~context: + (`Assoc + [ ("name", `String "Jim") + ; ("age", `Int 42) + ; ("another", `String "thing") + ] ) ) + ~printer:(fun e -> Format.asprintf "@,@[%a@]" pp_error e) + in + "Yojson.Basic" >::: [ list_string_test ; array_string_test @@ -179,6 +230,8 @@ let yojson_basic_suite = ; mut_rec_test ; string_or_floatlit_test ; grouping_errors_test + ; obj_test + ; obj_test_2 ]