Obj decoders

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
 
 

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
 

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
 

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

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

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)

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

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. *)