Add the culprit json fragment in the error messages systematically.

ppx/browser/dune

@@ -1,7 +1,14 @@
 (library
  (public_name melange-json.ppx)
  (name ppx_deriving_json_js)
- (modules :standard \ ppx_deriving_json_runtime ppx_deriving_json_js_test)
+ (modules
+  :standard
+  \
+  ppx_deriving_json_runtime
+  ppx_deriving_json_js_test
+  ppx_deriving_json_classify
+  ppx_deriving_json_errors
+  ppx_deriving_json_exception)
  (libraries ppxlib)
  (ppx_runtime_libraries melange-json melange-json.ppx-runtime)
  (preprocess
@@ -11,7 +18,11 @@
 (library
  (public_name melange-json.ppx-runtime)
  (name ppx_deriving_json_js_runtime)
- (modules ppx_deriving_json_runtime)
+ (modules
+  ppx_deriving_json_runtime
+  ppx_deriving_json_classify
+  ppx_deriving_json_errors
+  ppx_deriving_json_exception)
  (libraries melange-json)
  (wrapped false)
  (modes melange))
@@ -38,5 +49,8 @@
 (copy_files#
  (files ../native/ppx_deriving_json_common.ml))
 
+(copy_files#
+ (files ../native/ppx_deriving_json_errors.ml))
+
 (copy_files#
  (files ../native/ppx_deriving_tools.{ml,mli}))

ppx/browser/ppx_deriving_json_classify.ml

@@ -0,0 +1,30 @@
+type t = Js.Json.t
+
+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)

ppx/browser/ppx_deriving_json_exception.ml

@@ -0,0 +1 @@
+exception Of_json_error = Json.Decode.DecodeError

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 =
+  let ensure_json_array_len ~loc n len x =
     [%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:[%e 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 =
@@ -128,7 +128,7 @@ module Of_json = struct
         let n = Option.value ~default:n (vcs_attr_json_name r.rcd_ctx) in
         [%expr
           if Stdlib.( = ) tag [%e estring ~loc:n.loc n.txt] then (
-            [%e ensure_json_array_len ~loc 2 [%expr len]];
+            [%e ensure_json_array_len ~loc 2 [%expr len] [%expr x]];
             let fs = Js.Array.unsafe_get array 1 in
             [%e ensure_json_object ~loc [%expr fs]];
             [%e
@@ -141,7 +141,7 @@ module Of_json = struct
         let arity = List.length t.tpl_types in
         [%expr
           if Stdlib.( = ) tag [%e estring ~loc:n.loc n.txt] then (
-            [%e ensure_json_array_len ~loc (arity + 1) [%expr len]];
+            [%e ensure_json_array_len ~loc (arity + 1) [%expr len] [%expr x]];
             [%e
               if Stdlib.( = ) arity 0 then make None
               else
@@ -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

@@ -4,7 +4,8 @@ let to_json t = t
 let of_json t = t
 let to_string t = Js.Json.stringify t
 
-exception Of_string_error of string
+
+include Ppx_deriving_json_errors
 
 let of_string s =
   try Js.Json.parseExn s
@@ -24,10 +25,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 +59,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 +72,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 +114,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/dune

@@ -5,7 +5,10 @@
   :standard
   \
   ppx_deriving_json_runtime
-  ppx_deriving_json_native_test)
+  ppx_deriving_json_native_test
+  ppx_deriving_json_classify
+  ppx_deriving_json_errors
+  ppx_deriving_json_exception)
  (libraries ppxlib)
  (ppx_runtime_libraries melange-json-native.ppx-runtime yojson)
  (preprocess
@@ -16,7 +19,11 @@
  (public_name melange-json-native.ppx-runtime)
  (name ppx_deriving_json_native_runtime)
  (wrapped false)
- (modules ppx_deriving_json_runtime)
+ (modules
+  ppx_deriving_json_runtime
+  ppx_deriving_json_classify
+  ppx_deriving_json_errors
+  ppx_deriving_json_exception)
  (libraries yojson))
 
 (executable

ppx/native/ppx_deriving_json_classify.ml

@@ -0,0 +1,13 @@
+type t = Yojson.Basic.t
+
+
+  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 x -> x