feat(util): more functions in Ser_decode

src/util/ser_decode.ml

@@ -30,6 +30,7 @@ let[@inline] fail_ msg v = raise_notrace (Fail (Error.mk msg v))
 let[@inline] fail_e e = raise_notrace (Fail e)
 let return x = { deser = (fun _ -> x) }
 let fail s = { deser = (fun v -> fail_ s v) }
+let failf fmt = Printf.ksprintf fail fmt
 
 let unwrap_opt msg = function
   | Some x -> return x
@@ -61,6 +62,17 @@ let string =
       | v -> fail_ "expected string" v);
   }
 
+let reflect dec v =
+  {
+    deser =
+      (fun _ ->
+        match dec.deser v with
+        | x -> Ok x
+        | exception Fail e -> Error e);
+  }
+
+let reflect_or_fail dec v = { deser = (fun _ -> dec.deser v) }
+
 let list d =
   {
     deser =
@@ -146,6 +158,35 @@ end
 
 include Infix
 
+let tup2 d1 d2 =
+  let* l = list any in
+  match l with
+  | [ x1; x2 ] ->
+    let+ x1 = reflect_or_fail d1 x1 and+ x2 = reflect_or_fail d2 x2 in
+    x1, x2
+  | _ -> fail "expected a pair"
+
+let tup3 d1 d2 d3 =
+  let* l = list any in
+  match l with
+  | [ x1; x2; x3 ] ->
+    let+ x1 = reflect_or_fail d1 x1
+    and+ x2 = reflect_or_fail d2 x2
+    and+ x3 = reflect_or_fail d3 x3 in
+    x1, x2, x3
+  | _ -> fail "expected a triple"
+
+let tup4 d1 d2 d3 d4 =
+  let* l = list any in
+  match l with
+  | [ x1; x2; x3; x4 ] ->
+    let+ x1 = reflect_or_fail d1 x1
+    and+ x2 = reflect_or_fail d2 x2
+    and+ x3 = reflect_or_fail d3 x3
+    and+ x4 = reflect_or_fail d4 x4 in
+    x1, x2, x3, x4
+  | _ -> fail "expected a 4-tuple"
+
 let run d v = try Ok (d.deser v) with Fail err -> Error err
 
 let run_exn d v =

src/util/ser_decode.mli

@@ -2,6 +2,17 @@
 
     Combinators to decode values. *)
 
+(** Errors *)
+module Error : sig
+  type t
+
+  include Sidekick_sigs.PRINT with type t := t
+
+  val to_string : t -> string
+end
+
+(** {2 Main combinators *)
+
 type +'a t
 (** Decode a value of type ['a] *)
 
@@ -10,14 +21,24 @@ val bool : bool t
 val string : string t
 val return : 'a -> 'a t
 val fail : string -> 'a t
+val failf : ('a, unit, string, 'b t) format4 -> 'a
 val unwrap_opt : string -> 'a option -> 'a t
 (** Unwrap option, or fail *)
 val any : Ser_value.t t
 val list : 'a t -> 'a list t
+val tup2 : 'a t -> 'b t -> ('a*'b) t
+val tup3 : 'a t -> 'b t -> 'c t -> ('a*'b*'c) t
+val tup4 : 'a t -> 'b t ->  'c t -> 'd t -> ('a*'b*'c*'d) t
 val dict_field : string -> 'a t -> 'a t
 val dict_field_opt : string -> 'a t -> 'a option t
 val both : 'a t -> 'b t -> ('a * 'b) t
+val reflect : 'a t -> Ser_value.t -> ('a, Error.t) result t
+(** [reflect dec v] returns the result of decoding [v] with [dec] *)
+
+val reflect_or_fail : 'a t -> Ser_value.t -> 'a t
+
 val try_l : 'a t list -> 'a t
+(** [try_l fs] tries each [f in fs] turn by turn, until one succeeds *)
 
 module Infix : sig
   val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t
@@ -32,14 +53,6 @@ include module type of Infix
 
 (** {2 Deserializing} *)
 
-module Error : sig
-  type t
-
-  include Sidekick_sigs.PRINT with type t := t
-
-  val to_string : t -> string
-end
-
 val run : 'a t -> Ser_value.t -> ('a, Error.t) result
 
 val run_exn : 'a t -> Ser_value.t -> 'a