Keep the error type opaque. #13

Author: andersfugmann

drivers/generic/ppx_protocol_driver.ml

@@ -70,19 +70,28 @@ let mangle str =
 
 module Make(Driver: Driver)(P: Parameters) = struct
   type t = Driver.t
+  type error = string * t option
+  exception Protocol_error of error
+
+  let error_to_string_hum: error -> string = function
+    | (s, Some t) -> Printf.sprintf "%s. Got: %s" s (Driver.to_string_hum t)
+    | (s, None) -> s
 
-  exception Protocol_error of string * t option
   (* Register exception printer *)
   let () = Printexc.register_printer (function
-      | Protocol_error (s, Some t) -> Some (Printf.sprintf "%s, %s" s (Driver.to_string_hum t))
-      | Protocol_error (s, None) -> Some (Printf.sprintf "%s" s)
+      | Protocol_error err -> Some (error_to_string_hum err)
       | _ -> None)
 
   let to_string_hum = Driver.to_string_hum
 
   let raise_errorf t fmt =
     Caml.Printf.kprintf (fun s -> raise (Protocol_error (s, t))) fmt
 
+  let try_with: (t -> 'a) -> t -> ('a, error) Runtime.result = fun f t ->
+    match f t with
+    | v -> Ok v
+    | exception (Protocol_error e) -> Error e
+
   let wrap t f x = match f x with
     | v -> v
     | exception Helper.Protocol_error s -> raise (Protocol_error (s, Some t))

drivers/json/test/bench.ml

@@ -18,7 +18,7 @@ module type Test = sig
   val t: unit -> t
   val to_json: t -> Json.t
   val to_yojson: t -> Yojson.Safe.json
-  val of_json: Json.t -> t Protocol_conv.Runtime.or_error
+  val of_json: Json.t -> (t, Json.t) Protocol_conv.Runtime.result
   val of_yojson: Yojson.Safe.json -> t Ppx_deriving_yojson_runtime.error_or
 end
 

drivers/json/test/test_expect.ml

@@ -169,14 +169,13 @@ module Test = struct
     [@@deriving protocol ~driver:(module Json)]
 
     let%expect_test _ =
-      let (a, b) = of_json_exn (`List [ `Int 5; `String "string"]) in
-      Printf.printf "`Fst: %d\n%!" a;
+      let (a, b) = of_json_exn (`List [ `Int 5; `String "ipsum"]) in
+      Printf.printf "First: %d\n%!" a;
       begin
         try
-          Printf.printf "`Snd: %d\n" (Lazy.force b)
+          Printf.printf "Lazy: %d\n" (Lazy.force b)
         with
-        | Json.Protocol_error (msg, Some t) -> Printf.eprintf "`Snd: %s. Got: %s"  msg (Json.to_string_hum t);
-        | Json.Protocol_error (msg, None) -> Printf.eprintf "`Snd: %s. Got: None"  msg
+        | Json.Protocol_error err -> Printf.eprintf "Lazy: Got expected error: %s" (Json.error_to_string_hum err);
       end;
       [%expect {|
         `Fst: 5

drivers/xml_light/xml_light.ml

@@ -3,11 +3,24 @@ open Base
 open Protocol_conv.Runtime
 type t = Xml.xml
 
-exception Protocol_error of string * t option
-let () = Printexc.register_printer
-    (function Protocol_error (s, Some t) -> Some (s ^ ": " ^ (Xml.to_string t))
-            | Protocol_error (s, None) -> Some (s)
-            | _ -> None)
+type error = string * t option
+exception Protocol_error of error
+
+let to_string_hum xml = Xml.to_string_fmt xml
+
+let error_to_string_hum: error -> string = function
+  | (s, Some t) -> Printf.sprintf "%s. T: '%s'" s (to_string_hum t)
+  | (s, None) -> s
+
+(* Register exception printer *)
+let () = Printexc.register_printer (function
+    | Protocol_error err -> Some (error_to_string_hum err)
+    | _ -> None)
+
+let try_with: (t -> 'a) -> t -> ('a, error) result = fun f t ->
+  match f t with
+  | v -> Ok v
+  | exception (Protocol_error e) -> Error e
 
 let raise_errorf t fmt =
   Caml.Printf.kprintf (fun s -> raise (Protocol_error (s, t))) fmt
@@ -16,9 +29,6 @@ let wrap t f x = match f x with
   | v -> v
   | exception Helper.Protocol_error s -> raise (Protocol_error (s, Some t))
 
-let to_string_hum xml =
-  Xml.to_string_fmt xml
-
 let element name t = Xml.Element (name, [], t)
 
 let record_to_xml assoc =

ppx/ppx_protocol_conv.ml

@@ -658,7 +658,8 @@ let type_of_of_func ~loc driver ~as_result tydecl =
   let result_type = match as_result with
     | false -> typ
     | true ->
-      ptyp_constr ~loc { loc; txt = Ldot (Ldot (Lident "Protocol_conv", "Runtime"), "or_error") } [typ]
+      let error_typ = ptyp_constr ~loc { loc; txt = Ldot (driver, "error") } [] in
+      ptyp_constr ~loc { loc; txt = Ldot (Ldot (Lident "Protocol_conv", "Runtime"), "result") } [typ; error_typ]
   in
   [%type: [%t ptyp_constr ~loc { loc; txt = Ldot (driver, "t")} [] ] -> [%t result_type]]
 
@@ -753,16 +754,21 @@ let of_protocol_str_type_decls t rec_flag ~loc tydecls =
               pexp_ident ~loc { loc; txt = Lident (name_of_core_type ~prefix:"of" ct).txt })
           tdecl.ptype_params
       in
+      (*
       let args =
         type_params @ [ pexp_ident ~loc { loc; txt = Lident "t"} ]
         |> List.map ~f:(fun e -> (Nolabel, e))
       in
       pexp_apply ~loc (pexp_ident ~loc { loc; txt = Lident of_p.txt}) args
+
+*)
+      let args =
+        type_params
+        |> List.map ~f:(fun e -> (Nolabel, e))
+      in
+      pexp_apply ~loc (pexp_ident ~loc { loc; txt = Lident of_p.txt}) args
     in
-    [%expr fun t -> match [%e expr] with
-      | v -> Protocol_conv.Runtime.ok v
-      | exception exn -> Protocol_conv.Runtime.error exn
-    ]
+    pexp_apply ~loc (driver_func t ~loc "try_with") [Nolabel, expr]
   in
   let (defs, err_defs, is_recursive) =
     let is_recursive_f = is_recursive tydecls rec_flag in

ppx/test/test_driver.ml

@@ -1,6 +1,7 @@
-open Base
 open Protocol_conv
 open Runtime
+open Base
+
 type t =
   | Record of (string * t) list
   | Variant of string * t list
@@ -18,13 +19,27 @@ type t =
   | Unit
 [@@deriving sexp]
 
-exception Protocol_error of string * t option
+type error = string * t option
+exception Protocol_error of error
 
 let to_string_hum t = sexp_of_t t |> Sexp.to_string_hum
+let error_to_string_hum: error -> string = function
+  | (s, Some t) -> Printf.sprintf "%s. T: '%s'" s (to_string_hum t)
+  | (s, None) -> s
+
+(* Register exception printer *)
+let () = Caml.Printexc.register_printer (function
+    | Protocol_error err -> Some (error_to_string_hum err)
+    | _ -> None)
 
 let raise_errorf t fmt =
   Caml.Printf.kprintf (fun s -> raise (Protocol_error (s, Some t))) fmt
 
+let try_with: (t -> 'a) -> t -> ('a, error) Runtime.result = fun f t ->
+  match f t with
+  | v -> Ok v
+  | exception (Protocol_error e) -> Error e
+
 let to_variant: (t, 'a) Variant_in.t list -> t -> 'a = fun spec -> function
   | Variant (name, args) -> Helper.to_variant spec name args
   | t -> raise_errorf t "Variant expected"

runtime/runtime.ml

@@ -1,8 +1,6 @@
 open Base
 
-type 'a or_error = ('a, exn) Result.t
-let error exn = Result.Error exn
-let ok v = Result.Ok v
+type ('v, 'e) result = ('v, 'e) Result.t
 
 module Record_in = struct
   type (_, _, _) t =
@@ -36,15 +34,40 @@ module Variant_in = struct
   type (_, _) t = Variant: string * ('a, 'constr, 'c) Tuple_in.t  * 'constr -> ('a, 'c) t
 end
 
+(** Signature for a driver. Serialization function are on the form [of_XXX] and
+    deserialization function are on the form [to_XXX].
+
+    All deserialization functions should only raise [Protocol_error] is the type could not be desrialized.
+*)
 module type Driver = sig
+
+  (** Serialized type. This type should not be opaque, so it is recommended that
+      drivers implement the signature as [Runtime.Driver with type t = ... ]
+  *)
   type t
-  exception Protocol_error of string * t option
+
+  (** Opaque error type *)
+  type error
+
+  (** Exception for protocol errors. The driver should make sure that
+      this is the only exception raised when deserializing *)
+  exception Protocol_error of error
+
+  (** Convert an error type to a human readable string *)
+  val error_to_string_hum: error -> string
+
+  (** Convert t to a string *)
   val to_string_hum: t -> string
 
+  (** Wrap deserialization function to convert exceptions into an result type *)
+  val try_with: (t -> 'v) -> t -> ('v, error) result
+
   val to_variant: (t, 'a) Variant_in.t list -> t -> 'a
   val of_variant: string -> (t, 'a, t) Tuple_out.t -> 'a
+
   val to_record:  (t, 'constr, 'b) Record_in.t -> 'constr -> t -> 'b
   val of_record:  (t, 'a, t) Record_out.t -> 'a
+
   val to_tuple:   (t, 'constr, 'b) Tuple_in.t -> 'constr -> t -> 'b
   val of_tuple:   (t, 'a, t) Tuple_out.t -> 'a