Add the culprit json fragment in the error messages systematically.

ppx/browser/ppx_deriving_json_js.ml

@@ -40,9 +40,9 @@ module Of_json = struct
                 | Some default -> default
                 | None ->
                     [%expr
-                      Ppx_deriving_json_runtime.of_json_error
+                      Ppx_deriving_json_runtime.of_json_error ~json:x
                         [%e
-                          estring ~loc (sprintf "missing field %S" n.txt)]]]]
+                          estring ~loc (sprintf "expected field %S to be present" n.txt)]]]]
       )
     in
     [%expr
@@ -65,13 +65,13 @@ module Of_json = struct
   let ensure_json_object ~loc x =
     [%expr
       if Stdlib.not [%e eis_json_object ~loc x] then
-        Ppx_deriving_json_runtime.of_json_error
+        Ppx_deriving_json_runtime.of_json_msg_error
           [%e estring ~loc (sprintf "expected a JSON object")]]
 
   let ensure_json_array_len ~loc n len =
     [%expr
       if Stdlib.( <> ) [%e len] [%e eint ~loc n] then
-        Ppx_deriving_json_runtime.of_json_error
+        Ppx_deriving_json_runtime.of_json_msg_error ~json:x
           [%e
             estring ~loc (sprintf "expected a JSON array of length %i" n)]]
 
@@ -89,7 +89,7 @@ module Of_json = struct
         let es = (Obj.magic [%e x] : Js.Json.t array) in
         [%e build_tuple ~loc derive 0 t.tpl_types [%expr es]]
       else
-        Ppx_deriving_json_runtime.of_json_error
+        Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
           [%e
             estring ~loc (sprintf "expected a JSON array of length %i" n)]]
 
@@ -111,14 +111,14 @@ module Of_json = struct
             let tag = (Obj.magic tag : string) in
             [%e body]
           else
-            Ppx_deriving_json_runtime.of_json_error
+            Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
               "expected a non empty JSON array with element being a \
                string"
         else
-          Ppx_deriving_json_runtime.of_json_error
+          Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
             "expected a non empty JSON array"
       else
-        Ppx_deriving_json_runtime.of_json_error
+        Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
           "expected a non empty JSON array"]
 
   let derive_of_variant_case derive make c next =
@@ -153,7 +153,7 @@ module Of_json = struct
   let deriving : Ppx_deriving_tools.deriving =
     deriving_of () ~name:"of_json"
       ~error:(fun ~loc ->
-        [%expr Ppx_deriving_json_runtime.of_json_error "invalid JSON"])
+        [%expr Ppx_deriving_json_runtime.of_json_msg_error "invalid JSON"])
       ~of_t:(fun ~loc -> [%type: Js.Json.t])
       ~derive_of_tuple ~derive_of_record ~derive_of_variant
       ~derive_of_variant_case

ppx/browser/ppx_deriving_json_runtime.ml

@@ -6,6 +6,100 @@ let to_string t = Js.Json.stringify t
 
 exception Of_string_error of string
 
+module Classify = struct
+  let classify :
+      t ->
+      [ `Null
+      | `String of string
+      | `Float of float
+      | `Int of int
+      | `Bool of bool
+      | `List of t list
+      | `Assoc of (string * t) list ] =
+   fun json ->
+    if (Obj.magic json : 'a Js.null) == Js.null then `Null
+    else
+      match Js.typeof json with
+      | "string" -> `String (Obj.magic json : string)
+      | "number" ->
+          let v = (Obj.magic json : float) in
+          if Js.Float.isFinite v && Js.Math.floor_float v == v then
+            `Int (Obj.magic v : int)
+          else `Float v
+      | "boolean" -> `Bool (Obj.magic json : bool)
+      | "object" ->
+          if Js.Array.isArray json then
+            let xs = Array.to_list (Obj.magic json : t array) in
+            `List xs
+          else
+            let xs = Js.Dict.entries (Obj.magic json : t Js.Dict.t) in
+            `Assoc (Array.to_list xs)
+      | typ -> failwith ("unknown JSON value type: " ^ typ)
+end
+
+let show_json_error ?depth json =
+  let buffer = Buffer.create 1 in
+  let rec loop ?depth json =
+    let json = Classify.classify json in
+    let depth = Option.map (fun i -> i - 1) depth in
+    match depth with
+    | Some 0 -> Buffer.add_string buffer "_"
+    | _ -> (
+        match json with
+        | `Assoc assoc ->
+            Buffer.add_string buffer "{";
+            List.iter
+              (fun (k, v) ->
+                Buffer.add_string buffer {|"|};
+                Buffer.add_string buffer k;
+                Buffer.add_string buffer {|": |};
+                loop ?depth v;
+                Buffer.add_string buffer {|, |})
+              assoc;
+            Buffer.add_string buffer "}"
+        | `Bool bool ->
+            Buffer.add_string buffer (if bool then "true" else "false")
+        | `Float float -> Buffer.add_string buffer (string_of_float float)
+        | `Int int -> Buffer.add_string buffer (string_of_int int)
+        | `List li ->
+            Buffer.add_string buffer "[";
+            List.iter
+              (fun elt ->
+                loop ?depth elt;
+                Buffer.add_string buffer ", ")
+              li;
+            Buffer.add_string buffer "]"
+        | `Null -> Buffer.add_string buffer "null"
+        | `String str ->
+            Buffer.add_string buffer {|"|};
+            Buffer.add_string buffer (String.escaped str);
+            Buffer.add_string buffer {|"|})
+  in
+
+  (loop ?depth:(Option.map (fun i -> i + 1) depth)) json;
+  Buffer.contents buffer
+
+exception Of_json_error = Json.Decode.DecodeError
+
+let of_json_msg_error msg = raise (Of_json_error (Json_error msg))
+
+let of_json_error ?(depth = 2) ~json msg =
+  of_json_msg_error
+    (Printf.sprintf "%s but got %s" msg (show_json_error ~depth json))
+
+let show_json_type = function
+  | `Assoc _ -> "object"
+  | `Bool _ -> "bool"
+  | `Float _ -> "float"
+  | `Int _ -> "int"
+  | `List _ -> "array"
+  | `Null -> "null"
+  | `String _ -> "string"
+
+let of_json_error_type_mismatch json expected =
+  of_json_msg_error
+    ("expected " ^ expected ^ " but got " ^ show_json_type json)
+
 let of_string s =
   try Js.Json.parseExn s
   with exn ->
@@ -24,10 +118,6 @@ type error = Json.Decode.error =
   | Json_error of string
   | Unexpected_variant of string
 
-exception Of_json_error = Json.Decode.DecodeError
-
-let of_json_error msg = raise (Of_json_error (Json_error msg))
-
 let unexpected_variant_error tag =
   raise (Of_json_error (Unexpected_variant tag))
 
@@ -62,11 +152,11 @@ end
 module Of_json = struct
   let string_of_json (json : t) : string =
     if Js.typeof json = "string" then (Obj.magic json : string)
-    else of_json_error "expected a string"
+    else of_json_error ~json "expected a string"
 
   let bool_of_json (json : t) : bool =
     if Js.typeof json = "boolean" then (Obj.magic json : bool)
-    else of_json_error "expected a boolean"
+    else of_json_error ~json "expected a boolean"
 
   let is_int value =
     Js.Float.isFinite value && Js.Math.floor_float value == value
@@ -75,30 +165,30 @@ module Of_json = struct
     if Js.typeof json = "number" then
       let v = (Obj.magic json : float) in
       if is_int v then (Obj.magic v : int)
-      else of_json_error "expected an integer"
-    else of_json_error "expected an integer"
+      else of_json_error ~json "expected an integer"
+    else of_json_error ~json "expected an integer"
 
   let int64_of_json (json : t) : int64 =
     if Js.typeof json = "string" then
       let v = (Obj.magic json : string) in
       match Int64.of_string_opt v with
       | Some v -> v
-      | None -> of_json_error "expected int64 as string"
-    else of_json_error "expected int64 as string"
+      | None -> of_json_error ~json "expected int64 as string"
+    else of_json_error ~json "expected int64 as string"
 
   let float_of_json (json : t) : float =
     if Js.typeof json = "number" then (Obj.magic json : float)
-    else of_json_error "expected a float"
+    else of_json_error ~json "expected a float"
 
   let unit_of_json (json : t) =
     if (Obj.magic json : 'a Js.null) == Js.null then ()
-    else of_json_error "expected null"
+    else of_json_error ~json "expected null"
 
   let array_of_json v_of_json (json : t) =
     if Js.Array.isArray json then
       let json = (Obj.magic json : Js.Json.t array) in
       Js.Array.map ~f:v_of_json json
-    else of_json_error "expected a JSON array"
+    else of_json_error ~json "expected a JSON array"
 
   let list_of_json v_of_json (json : t) =
     array_of_json v_of_json json |> Array.to_list
@@ -117,50 +207,21 @@ module Of_json = struct
           let tag = (Obj.magic tag : string) in
           if Stdlib.( = ) tag "Ok" then (
             if Stdlib.( <> ) len 2 then
-              of_json_error "expected a JSON array of length 2";
+              of_json_error ~json "expected a JSON array of length 2";
             Ok (ok_of_json (Js.Array.unsafe_get array 1)))
           else if Stdlib.( = ) tag "Error" then (
             if Stdlib.( <> ) len 2 then
-              of_json_error "expected a JSON array of length 2";
+              of_json_error ~json "expected a JSON array of length 2";
             Error (err_of_json (Js.Array.unsafe_get array 1)))
-          else of_json_error "invalid JSON"
+          else of_json_error ~json {|expected ["Ok", _] or ["Error", _]|}
         else
-          of_json_error
+          of_json_error ~json
             "expected a non empty JSON array with element being a string"
-      else of_json_error "expected a non empty JSON array"
-    else of_json_error "expected a non empty JSON array"
+      else of_json_error ~json "expected a non empty JSON array"
+    else of_json_error ~json "expected a non empty JSON array"
 end
 
 module Primitives = struct
   include Of_json
   include To_json
 end
-
-module Classify = struct
-  let classify :
-      t ->
-      [ `Null
-      | `String of string
-      | `Float of float
-      | `Int of int
-      | `Bool of bool
-      | `List of t list
-      | `Assoc of (string * t) list ] =
-   fun json ->
-    if (Obj.magic json : 'a Js.null) == Js.null then `Null
-    else
-      match Js.typeof json with
-      | "string" -> `String (Obj.magic json : string)
-      | "number" ->
-          let v = (Obj.magic json : float) in
-          if Of_json.is_int v then `Int (Obj.magic v : int) else `Float v
-      | "boolean" -> `Bool (Obj.magic json : bool)
-      | "object" ->
-          if Js.Array.isArray json then
-            let xs = Array.to_list (Obj.magic json : t array) in
-            `List xs
-          else
-            let xs = Js.Dict.entries (Obj.magic json : t Js.Dict.t) in
-            `Assoc (Array.to_list xs)
-      | typ -> failwith ("unknown JSON value type: " ^ typ)
-end

ppx/native/ppx_deriving_json_native.ml

@@ -47,8 +47,8 @@ module Of_json = struct
         if allow_extra_fields then [%expr ()]
         else
           [%expr
-            Ppx_deriving_json_runtime.of_json_error
-              (Stdlib.Printf.sprintf "unknown field: %s" name)]
+            Ppx_deriving_json_runtime.of_json_error ~json:x
+              (Stdlib.Printf.sprintf "did not expect field: %s" name)]
       in
       let cases =
         List.fold_left (List.rev fs) ~init:[ fail_case ]
@@ -81,7 +81,7 @@ module Of_json = struct
                       | Some default -> default
                       | None ->
                           [%expr
-                            Ppx_deriving_json_runtime.of_json_error
+                            Ppx_deriving_json_runtime.of_json_error ~json:x
                               [%e
                                 estring ~loc:key.loc
                                   (sprintf "missing field %S" key.txt)]]]]
@@ -109,7 +109,7 @@ module Of_json = struct
         xpatt --> build_tuple ~loc derive xexprs t.tpl_types;
         [%pat? _]
         --> [%expr
-              Ppx_deriving_json_runtime.of_json_error
+              Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
                 [%e
                   estring ~loc
                     (sprintf "expected a JSON array of length %i" n)]];
@@ -127,7 +127,7 @@ module Of_json = struct
               [%expr fs] Fun.id;
         [%pat? _]
         --> [%expr
-              Ppx_deriving_json_runtime.of_json_error
+              Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
                 [%e estring ~loc (sprintf "expected a JSON object")]];
       ]