diff --git a/src/util/ser_decode.ml b/src/util/ser_decode.ml index 47f01518..530537c3 100644 --- a/src/util/ser_decode.ml +++ b/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 = diff --git a/src/util/ser_decode.mli b/src/util/ser_decode.mli index b6bf15ff..7f14f789 100644 --- a/src/util/ser_decode.mli +++ b/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