ppx: add the culprit json fragment in the error messages systematical…

…ly. (#47)

ppx/browser/dune

@@ -1,21 +1,13 @@
 (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_js_test)
  (libraries ppxlib)
  (ppx_runtime_libraries melange-json melange-json.ppx-runtime)
  (preprocess
   (pps ppxlib.metaquot))
  (kind ppx_deriver))
 
-(library
- (public_name melange-json.ppx-runtime)
- (name ppx_deriving_json_js_runtime)
- (modules ppx_deriving_json_runtime)
- (libraries melange-json)
- (wrapped false)
- (modes melange))
-
 (executable
  (name ppx_deriving_json_js_test)
  (modules ppx_deriving_json_js_test)
@@ -36,7 +28,7 @@
    (run echo "let () = Ppxlib.Driver.standalone ()"))))
 
 (copy_files#
- (files ../native/ppx_deriving_json_common.ml))
+ (files ../common/ppx_deriving_json_common.ml))
 
 (copy_files#
- (files ../native/ppx_deriving_tools.{ml,mli}))
+ (files ../common/ppx_deriving_tools.{ml,mli}))

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/native/ppx_deriving_tools.ml → ppx/common/ppx_deriving_tools.ml

@@ -503,17 +503,30 @@ module Conv = struct
 
        method! derive_of_variant td cs x =
          let loc = td.ptype_loc in
+         let error_message =
+           Printf.sprintf "expected %s"
+             (cs
+             |> List.map ~f:(fun c ->
+                    let name = c.pcd_name in
+                    match c.pcd_args with
+                    | Pcstr_record _fs ->
+                        Printf.sprintf {|["%s", { _ }]|} name.txt
+                    | Pcstr_tuple li ->
+                        Printf.sprintf {|["%s"%s]|} name.txt
+                          (li
+                          |> List.map ~f:(fun _ -> ", _")
+                          |> String.concat ~sep:""))
+             |> String.concat ~sep:" or ")
+         in
          let cs = repr_variant_cases cs in
          let cases =
            List.fold_left cs
              ~init:
                [
                  [%pat? _]
                  --> [%expr
-                       raise
-                         (Ppx_deriving_json_runtime.Of_json_error
-                            (Ppx_deriving_json_runtime.Unexpected_variant
-                               "unexpected variant"))];
+                       Ppx_deriving_json_runtime.of_json_error ~json:x
+                         [%e estring ~loc error_message]];
                ]
              ~f:(fun next (c : constructor_declaration) ->
                let ctx = Vcs_ctx_variant c in

ppx/native/dune

@@ -1,24 +1,13 @@
 (library
  (public_name melange-json-native.ppx)
  (name ppx_deriving_json_native)
- (modules
-  :standard
-  \
-  ppx_deriving_json_runtime
-  ppx_deriving_json_native_test)
+ (modules :standard \ ppx_deriving_json_native_test)
  (libraries ppxlib)
  (ppx_runtime_libraries melange-json-native.ppx-runtime yojson)
  (preprocess
   (pps ppxlib.metaquot))
  (kind ppx_deriver))
 
-(library
- (public_name melange-json-native.ppx-runtime)
- (name ppx_deriving_json_native_runtime)
- (wrapped false)
- (modules ppx_deriving_json_runtime)
- (libraries yojson))
-
 (executable
  (name ppx_deriving_json_native_test)
  (modules ppx_deriving_json_native_test)
@@ -37,3 +26,9 @@
   (with-stdout-to
    %{target}
    (run echo "let () = Ppxlib.Driver.standalone ()"))))
+
+(copy_files#
+ (files ../common/ppx_deriving_json_common.ml))
+
+(copy_files#
+ (files ../common/ppx_deriving_tools.{ml,mli}))

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,10 +81,10 @@ 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)]]]]
+                                  (sprintf "expected field %S" key.txt)]]]]
             ))
       in
       pexp_record ~loc fields None
@@ -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")]];
       ]
 

ppx/runtime/browser/dune

@@ -0,0 +1,10 @@
+(library
+ (public_name melange-json.ppx-runtime)
+ (name ppx_deriving_json_js_runtime)
+ (libraries melange-json)
+ (wrapped false)
+ (modes melange))
+
+
+(copy_files#
+ (files ../common/ppx_deriving_json_errors.ml))

ppx/runtime/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/runtime/browser/ppx_deriving_json_exception.ml

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