refactor: Error.t

Author: mattjbray

src/decode.ml

@@ -2,17 +2,10 @@
 
 open Decoders_util
 
-type 'value exposed_error =
-  | Decoder_error of string * 'value option
-  | Decoder_errors of 'value exposed_error list
-  | Decoder_tag of string * 'value exposed_error
-
 type ('good, 'bad) result = ('good, 'bad) My_result.t =
   | Ok of 'good
   | Error of 'bad
 
-type ('value, 'a) exposed_decoder = ('value, 'a, 'value exposed_error) Decoder.t
-
 (** Signature of things that can be decoded. *)
 module type Decodeable = sig
   type value
@@ -44,7 +37,7 @@ end
 module type S = sig
   type value
 
-  type error = value exposed_error
+  type error = value Error.t
 
   val pp_error : Format.formatter -> error -> unit
 
@@ -165,41 +158,18 @@ end
 module Make (Decodeable : Decodeable) :
   S
     with type value = Decodeable.value
-     and type 'a decoder = (Decodeable.value, 'a) exposed_decoder = struct
+     and type 'a decoder =
+          (Decodeable.value, 'a, Decodeable.value Error.t) Decoder.t = struct
   type value = Decodeable.value
 
   let pp = Decodeable.pp
 
-  type error = value exposed_error
-
-  let rec pp_error fmt = function
-    | Decoder_error (msg, Some t) ->
-        Format.fprintf fmt "@[%s, but got@ @[%a@]@]" msg pp t
-    | Decoder_error (msg, None) ->
-        Format.fprintf fmt "@[%s@]" msg
-    | Decoder_errors errors ->
-        let errors_trunc = My_list.take 5 errors in
-        let not_shown = List.length errors - 5 in
-        Format.fprintf
-          fmt
-          "@[%a@ %s@]"
-          (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_error)
-          errors_trunc
-          ( if not_shown > 0
-          then Printf.sprintf "(...%d errors not shown...)" not_shown
-          else "" )
-    | Decoder_tag (msg, error) ->
-        Format.fprintf fmt "@[<2>%s:@ @[%a@]@]" msg pp_error error
+  type error = value Error.t
 
+  let pp_error = Error.pp ~pp_i:pp
 
   let string_of_error e : string = Format.asprintf "@[<2>%a@?@]" pp_error e
 
-  let tag_error (msg : string) (error : error) : error = Decoder_tag (msg, error)
-
-  let tag_errors (msg : string) (errors : error list) : error =
-    Decoder_tag (msg, Decoder_errors errors)
-
-
   let combine_errors (results : ('a, error) result list) :
       ('a list, error list) result =
     let rec aux combined = function
@@ -230,31 +200,25 @@ module Make (Decodeable : Decodeable) :
    fun string ->
     Decodeable.of_string string
     |> My_result.map_err (fun msg ->
-           Decoder_tag ("Json parse error", Decoder_error (msg, None)))
+           Error.tag "Json parse error" (Error.make msg) )
 
 
   let of_file : string -> (value, error) result =
    fun file ->
     Decodeable.of_file file
     |> My_result.map_err (fun msg ->
-           Decoder_tag
-             (Printf.sprintf "While reading %s" file, Decoder_error (msg, None)))
+           Error.tag (Printf.sprintf "While reading %s" file) (Error.make msg) )
 
 
-  type 'a decoder = (value, 'a) exposed_decoder
+  type 'a decoder = (value, 'a, value Error.t) Decoder.t
 
   let succeed x = Decoder.pure x
 
-  let fail msg input = Error (Decoder_error (msg, Some input))
+  let fail msg input = Error (Error.make msg ~context:input)
 
   let fail_with error = Decoder.fail error
 
-  let from_result = function
-    | Ok ok ->
-        succeed ok
-    | Error error ->
-        fail_with error
-
+  let from_result = Decoder.of_result
 
   let value = Decoder.value
 
@@ -296,7 +260,7 @@ module Make (Decodeable : Decodeable) :
     | None ->
         decoder input
         |> My_result.map My_opt.return
-        |> My_result.map_err (tag_error "Expected null or")
+        |> My_result.map_err (Error.tag "Expected null or")
 
 
   let one_of (decoders : (string * 'a decoder) list) : 'a decoder =
@@ -305,12 +269,12 @@ module Make (Decodeable : Decodeable) :
       |> My_list.map (fun (name, d) ->
              d
              |> Decoder.map_err (fun e ->
-                    tag_errors (Printf.sprintf "%S decoder" name) [ e ] ) )
+                    Error.tag_group (Printf.sprintf "%S decoder" name) [ e ] ) )
     in
     Decoder.one_of
       decoders
       ~combine_errors:
-        (tag_errors "I tried the following decoders but they all failed")
+        (Error.tag_group "I tried the following decoders but they all failed")
 
 
   let primitive_decoder (get_value : value -> 'a option) (message : string) :
@@ -346,9 +310,9 @@ module Make (Decodeable : Decodeable) :
         values
         |> My_list.mapi (fun i x ->
                decoder x
-               |> My_result.map_err (tag_error (Printf.sprintf "element %i" i)) )
+               |> My_result.map_err (Error.tag (Printf.sprintf "element %i" i)) )
         |> combine_errors
-        |> My_result.map_err (tag_errors "while decoding a list")
+        |> My_result.map_err (Error.tag_group "while decoding a list")
 
 
   let list_filter : 'a option decoder -> 'a list decoder =
@@ -359,7 +323,7 @@ module Make (Decodeable : Decodeable) :
       | v :: vs ->
           My_result.Infix.(
             decoder v
-            |> My_result.map_err (tag_error (Printf.sprintf "element %i" i))
+            |> My_result.map_err (Error.tag (Printf.sprintf "element %i" i))
             >>= (function
             | Some x ->
                 go (i + 1) vs >>= fun xs -> My_result.return (x :: xs)
@@ -371,7 +335,7 @@ module Make (Decodeable : Decodeable) :
       | None ->
           (fail "Expected a list") t
       | Some values ->
-          go 0 values |> My_result.map_err (tag_error "while decoding a list")
+          go 0 values |> My_result.map_err (Error.tag "while decoding a list")
 
 
   let list_fold_left : ('a -> 'a decoder) -> 'a -> 'a decoder =
@@ -388,11 +352,11 @@ module Make (Decodeable : Decodeable) :
                    >>= fun acc ->
                    (acc |> decoder_func) el
                    |> My_result.map_err
-                        (tag_error (Printf.sprintf "element %i" i)) )
+                        (Error.tag (Printf.sprintf "element %i" i)) )
                  , i + 1 ) )
                (Ok init, 0))
         |> fst
-        |> My_result.map_err (tag_error "while decoding a list")
+        |> My_result.map_err (Error.tag "while decoding a list")
 
 
   let array : 'a decoder -> 'a array decoder =
@@ -401,8 +365,8 @@ module Make (Decodeable : Decodeable) :
     match res with
     | Ok x ->
         Ok (Array.of_list x)
-    | Error (Decoder_tag ("while decoding a list", e)) ->
-        Error (Decoder_tag ("while decoding an array", e))
+    | Error (Tag ("while decoding a list", e)) ->
+        Error (Tag ("while decoding an array", e))
     | Error e ->
         Error e
 
@@ -422,7 +386,7 @@ module Make (Decodeable : Decodeable) :
     match value with
     | Some value ->
         value_decoder value
-        |> My_result.map_err (tag_error (Printf.sprintf "in field %S" key))
+        |> My_result.map_err (Error.tag (Printf.sprintf "in field %S" key))
     | None ->
         (fail (Printf.sprintf "Expected an object with an attribute %S" key)) t
 
@@ -443,7 +407,7 @@ module Make (Decodeable : Decodeable) :
     | Some value ->
         value_decoder value
         |> My_result.map (fun v -> Some v)
-        |> My_result.map_err (tag_error (Printf.sprintf "in field %S" key))
+        |> My_result.map_err (Error.tag (Printf.sprintf "in field %S" key))
     | None ->
         Ok None
 
@@ -455,7 +419,7 @@ module Make (Decodeable : Decodeable) :
       ( match Decodeable.get_string key with
       | Some key ->
           (value_decoder key) value
-          |> My_result.map_err (tag_error (Printf.sprintf "in field %S" key))
+          |> My_result.map_err (Error.tag (Printf.sprintf "in field %S" key))
       | None ->
           (fail "Expected an object with a string key") t )
     | _ ->
@@ -490,10 +454,10 @@ module Make (Decodeable : Decodeable) :
     | Some (x :: rest) ->
         My_result.Infix.(
           head x
-          |> My_result.map_err (tag_error "while consuming a list element")
+          |> My_result.map_err (Error.tag "while consuming a list element")
           >>= fun x ->
           (tail x) (Decodeable.to_list rest)
-          |> My_result.map_err (tag_error "after consuming a list element"))
+          |> My_result.map_err (Error.tag "after consuming a list element"))
     | Some [] ->
         (fail "Expected a non-empty list") value
     | None ->
@@ -519,7 +483,7 @@ module Make (Decodeable : Decodeable) :
         |> List.map (fun (key, _) -> key_decoder key)
         |> combine_errors
         |> My_result.map_err
-             (tag_errors "Failed while decoding the keys of an object")
+             (Error.tag_group "Failed while decoding the keys of an object")
     | None ->
         (fail "Expected an object") value
 
@@ -539,7 +503,7 @@ module Make (Decodeable : Decodeable) :
                  value_decoder value_val >|= fun value -> (key, value))
         |> combine_errors
         |> My_result.map_err
-             (tag_errors "Failed while decoding key-value pairs")
+             (Error.tag_group "Failed while decoding key-value pairs")
     | None ->
         (fail "Expected an object") value
 
@@ -559,7 +523,7 @@ module Make (Decodeable : Decodeable) :
                  >>= fun key -> (value_decoder key) value_val)
         |> combine_errors
         |> My_result.map_err
-             (tag_errors "Failed while decoding key-value pairs")
+             (Error.tag_group "Failed while decoding key-value pairs")
     | None ->
         (fail "Expected an object") value
 

src/decode.mli

@@ -1,20 +1,13 @@
-type 'value exposed_error =
-  | Decoder_error of string * 'value option
-  | Decoder_errors of 'value exposed_error list
-  | Decoder_tag of string * 'value exposed_error
-
 type ('good, 'bad) result = ('good, 'bad) Decoders_util.My_result.t =
   | Ok of 'good
   | Error of 'bad
 
-type ('value, 'a) exposed_decoder = ('value, 'a, 'value exposed_error) Decoder.t
-
 (** User-facing Decoder interface. *)
 module type S = sig
   (** The type of values to be decoded (e.g. JSON or Yaml). *)
   type value
 
-  type error = value exposed_error
+  type error = value Error.t
 
   val pp_error : Format.formatter -> error -> unit
 
@@ -323,4 +316,4 @@ end
 module Make (M : Decodeable) :
   S
     with type value = M.value
-     and type 'a decoder = (M.value, 'a) exposed_decoder
+     and type 'a decoder = (M.value, 'a, M.value Error.t) Decoder.t

src/decoders.ml

@@ -1,4 +1,5 @@
 module Decoder = Decoder
+module Error = Error
 module Decode = Decode
 module Encode = Encode
 module Decoders_util = Decoders_util

src/error.ml

@@ -0,0 +1,37 @@
+type 'i t =
+  | E of
+      { msg : string
+      ; context : 'i option
+      }
+  | Tag of string * 'i t
+  | Group of 'i t list
+
+let make ?context msg = E { msg; context }
+
+let tag msg e = Tag (msg, e)
+
+let group es = Group es
+
+let tag_group msg es = tag msg (group es)
+
+let rec pp ~pp_i fmt =
+  let open Format in
+  function
+  | E { msg; context = None } ->
+      fprintf fmt "@[%s@]" msg
+  | E { msg; context = Some context } ->
+      fprintf fmt "@[%s, but got@ @[%a@]@]" msg pp_i context
+  | Tag (msg, e) ->
+      fprintf fmt "@[<2>%s:@ %a@]" msg (pp ~pp_i) e
+  | Group es ->
+      let max_errors = 5 in
+      let es_trunc = Decoders_util.My_list.take max_errors es in
+      let not_shown = List.length es - max_errors in
+      fprintf
+        fmt
+        "@[%a %s@]"
+        (Format.pp_print_list ~pp_sep:Format.pp_print_space (pp ~pp_i))
+        es_trunc
+        ( if not_shown > 0
+        then Printf.sprintf "(...%d errors not shown...)" not_shown
+        else "" )

test-yojson/main.ml

@@ -139,34 +139,30 @@ let yojson_basic_suite =
       |}
     in
     let expected_error =
-      let open Decoders.Decode in
-      Decoder_tag
-        ( {|in field "records"|}
-        , Decoder_tag
-            ( "while decoding a list"
-            , Decoder_errors
-                [ Decoder_tag
-                    ( "element 0"
-                    , Decoder_error
-                        ( {|Expected an object with an attribute "x"|}
-                        , Some (`Bool true) ) )
-                ; Decoder_tag
-                    ( "element 1"
-                    , Decoder_tag
-                        ( {|in field "x"|}
-                        , Decoder_tag
-                            ( "while decoding a list"
-                            , Decoder_errors
-                                [ Decoder_tag
-                                    ( "element 0"
-                                    , Decoder_error
-                                        ("Expected a string", Some (`Int 1)) )
-                                ; Decoder_tag
-                                    ( "element 2"
-                                    , Decoder_error
-                                        ("Expected a string", Some (`Int 3)) )
-                                ] ) ) )
-                ] ) )
+      let open Decoders in
+      Error.tag
+        {|in field "records"|}
+        (Error.tag_group
+           "while decoding a list"
+           [ Error.tag
+               "element 0"
+               (Error.make
+                  {|Expected an object with an attribute "x"|}
+                  ~context:(`Bool true) )
+           ; Error.tag
+               "element 1"
+               (Error.tag
+                  {|in field "x"|}
+                  (Error.tag_group
+                     "while decoding a list"
+                     [ Error.tag
+                         "element 0"
+                         (Error.make "Expected a string" ~context:(`Int 1))
+                     ; Error.tag
+                         "element 2"
+                         (Error.make "Expected a string" ~context:(`Int 3))
+                     ] ) )
+           ] )
     in
     match decode_string decoder input with
     | Ok _ ->