ppx: remove poly special case

melange-community · Nov 16, 2024 · 1794441 · 1794441
1 parent db0ab3c
commit 1794441
Show file tree

Hide file tree

Showing 12 changed files with 261 additions and 467 deletions.
diff --git a/examples/decode.ml b/examples/decode.ml
@@ -25,4 +25,4 @@ let _ =
   let json = {|{ "y": 42 } |} |> Json.parseOrRaise in
   match Json.Decode.(field "x" int json) with
   | x -> Js.log x
-  | exception Json.Decode.DecodeError msg -> Js.log ("Error:" ^ msg)
+  | exception Json.Decode.DecodeError err -> Js.log ("Error:" ^ Json.Decode.error_to_string err)
diff --git a/ppx/browser/ppx_deriving_json_runtime.ml b/ppx/browser/ppx_deriving_json_runtime.ml
@@ -20,9 +20,16 @@ let of_string s =
     in
     raise (Of_string_error msg)
 
+type error = Json.Decode.error =
+  | Json_error of string
+  | Unpexpected_variant of string
+
 exception Of_json_error = Json.Decode.DecodeError
 
-let of_json_error msg = raise (Of_json_error msg)
+let of_json_error msg = raise (Of_json_error (Json_error msg))
+
+let unexpected_variant_error tag =
+  raise (Of_json_error (Unpexpected_variant tag))
 
 module To_json = struct
   external string_to_json : string -> t = "%identity"

diff --git a/ppx/native/ppx_deriving_json_runtime.ml b/ppx/native/ppx_deriving_json_runtime.ml
@@ -10,9 +10,11 @@ let of_string s =
   try Yojson.Basic.from_string s
   with Yojson.Json_error msg -> raise (Of_string_error msg)
 
-exception Of_json_error of string
+type error = Json_error of string | Unpexpected_variant of string
 
-let of_json_error msg = raise (Of_json_error msg)
+exception Of_json_error of error
+
+let of_json_error msg = raise (Of_json_error (Json_error msg))
 
 let show_json_type = function
   | `Assoc _ -> "object"
@@ -24,9 +26,8 @@ let show_json_type = function
   | `String _ -> "string"
 
 let of_json_error_type_mismatch json expected =
-  raise
-    (Of_json_error
-       ("expected " ^ expected ^ " but got " ^ show_json_type json))
+  of_json_error
+    ("expected " ^ expected ^ " but got " ^ show_json_type json)
 
 module To_json = struct
   let string_to_json v = `String v

diff --git a/ppx/test/example.ml b/ppx/test/example.ml
@@ -21,6 +21,14 @@ type allow_extra_fields = {a: int} [@@deriving json] [@@json.allow_extra_fields]
 type allow_extra_fields2 = A of {a: int} [@json.allow_extra_fields] [@@deriving json]
 type drop_default_option = { a: int; b_opt: int option; [@option] [@json.drop_default] } [@@deriving json]
 
+(*module Polyvar : sig*)
+(*  type t = [`A | `B] [@@deriving json]*)
+(*end = struct*)
+(*  type t = [`A | `B] [@@deriving json]*)
+(*end*)
+(**)
+(*type polyvar = [Polyvar.t|`C] [@@deriving json]*)
+
 type json = Ppx_deriving_json_runtime.t
 type of_json = C : string * (json -> 'a) * ('a -> json) * 'a -> of_json
 let of_json_cases = [
@@ -40,6 +48,7 @@ let of_json_cases = [
   C ({|["A"]|}, sum_of_json, sum_to_json, (A : sum));
   C ({|["S2", 42, "hello"]|}, sum2_of_json, sum2_to_json, (S2 (42, "hello")));
   C ({|["B", 42]|}, poly_of_json, poly_to_json, (`B 42 : poly));
+  C ({|["C"]|}, poly_of_json, poly_to_json, (`C : poly));
   C ({|["P2", 42, "hello"]|}, poly2_of_json, poly2_to_json, (`P2 (42, "hello") : poly2));
   C ({|["Fix",["Fix",["Fix",["A"]]]]|}, recur_of_json, recur_to_json, (Fix (Fix (Fix A))));
   C ({|["Fix",["Fix",["Fix",["A"]]]]|}, polyrecur_of_json, polyrecur_to_json, (`Fix (`Fix (`Fix `A))));

diff --git a/ppx/test/ppx_deriving_json_js.e2e.t b/ppx/test/ppx_deriving_json_js.e2e.t
@@ -59,6 +59,8 @@
   JSON REPRINT: ["S2",42,"hello"]
   JSON    DATA: ["B", 42]
   JSON REPRINT: ["B",42]
+  JSON    DATA: ["C"]
+  JSON REPRINT: ["C"]
   JSON    DATA: ["P2", 42, "hello"]
   JSON REPRINT: ["P2",42,"hello"]
   JSON    DATA: ["Fix",["Fix",["Fix",["A"]]]]

diff --git a/ppx/test/ppx_deriving_json_js.t b/ppx/test/ppx_deriving_json_js.t
@@ -490,7 +490,7 @@
   
     [@@@ocaml.warning "-39-11-27"]
   
-    let rec other_of_json_poly =
+    let rec other_of_json =
       (fun x ->
          if Js.Array.isArray x then
            let array = (Obj.magic x : Js.Json.t array) in
@@ -503,8 +503,11 @@
                  if Stdlib.( <> ) len 1 then
                    Ppx_deriving_json_runtime.of_json_error
                      "expected a JSON array of length 1";
-                 Some `C)
-               else None
+                 `C)
+               else
+                 raise
+                   (Ppx_deriving_json_runtime.Of_json_error
+                      (Unpexpected_variant "unexpected variant"))
              else
                Ppx_deriving_json_runtime.of_json_error
                  "expected a non empty JSON array with element being a \
@@ -515,17 +518,9 @@
          else
            Ppx_deriving_json_runtime.of_json_error
              "expected a non empty JSON array"
-        : Js.Json.t -> other option)
-  
-    and other_of_json =
-      (fun x ->
-         match other_of_json_poly x with
-         | Some x -> x
-         | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON"
         : Js.Json.t -> other)
   
-    let _ = other_of_json_poly
-    and _ = other_of_json
+    let _ = other_of_json
   
     [@@@ocaml.warning "-39-11-27"]
   
@@ -545,7 +540,7 @@
   
     [@@@ocaml.warning "-39-11-27"]
   
-    let rec poly_of_json_poly =
+    let rec poly_of_json =
       (fun x ->
          if Js.Array.isArray x then
            let array = (Obj.magic x : Js.Json.t array) in
@@ -558,16 +553,21 @@
                  if Stdlib.( <> ) len 1 then
                    Ppx_deriving_json_runtime.of_json_error
                      "expected a JSON array of length 1";
-                 Some `A)
+                 `A)
                else if Stdlib.( = ) tag "B" then (
                  if Stdlib.( <> ) len 2 then
                    Ppx_deriving_json_runtime.of_json_error
                      "expected a JSON array of length 2";
-                 Some (`B (int_of_json (Js.Array.unsafe_get array 1))))
+                 `B (int_of_json (Js.Array.unsafe_get array 1)))
                else
-                 match other_of_json_poly x with
-                 | Some x -> (Some x :> [ `A | `B of int | other ] option)
-                 | None -> None
+                 match other_of_json x with
+                 | e -> (e :> [ `A | `B of int | other ])
+                 | exception
+                     Ppx_deriving_json_runtime.Of_json_error
+                       (Unpexpected_variant _) ->
+                     raise
+                       (Ppx_deriving_json_runtime.Of_json_error
+                          (Unpexpected_variant "unexpected variant"))
              else
                Ppx_deriving_json_runtime.of_json_error
                  "expected a non empty JSON array with element being a \
@@ -578,17 +578,9 @@
          else
            Ppx_deriving_json_runtime.of_json_error
              "expected a non empty JSON array"
-        : Js.Json.t -> poly option)
-  
-    and poly_of_json =
-      (fun x ->
-         match poly_of_json_poly x with
-         | Some x -> x
-         | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON"
         : Js.Json.t -> poly)
   
-    let _ = poly_of_json_poly
-    and _ = poly_of_json
+    let _ = poly_of_json
   
     [@@@ocaml.warning "-39-11-27"]
   
@@ -615,7 +607,7 @@
   
     [@@@ocaml.warning "-39-11-27"]
   
-    let rec poly2_of_json_poly =
+    let rec poly2_of_json =
       (fun x ->
          if Js.Array.isArray x then
            let array = (Obj.magic x : Js.Json.t array) in
@@ -628,11 +620,13 @@
                  if Stdlib.( <> ) len 3 then
                    Ppx_deriving_json_runtime.of_json_error
                      "expected a JSON array of length 3";
-                 Some
-                   (`P2
-                     ( int_of_json (Js.Array.unsafe_get array 1),
-                       string_of_json (Js.Array.unsafe_get array 2) )))
-               else None
+                 `P2
+                   ( int_of_json (Js.Array.unsafe_get array 1),
+                     string_of_json (Js.Array.unsafe_get array 2) ))
+               else
+                 raise
+                   (Ppx_deriving_json_runtime.Of_json_error
+                      (Unpexpected_variant "unexpected variant"))
              else
                Ppx_deriving_json_runtime.of_json_error
                  "expected a non empty JSON array with element being a \
@@ -643,17 +637,9 @@
          else
            Ppx_deriving_json_runtime.of_json_error
              "expected a non empty JSON array"
-        : Js.Json.t -> poly2 option)
-  
-    and poly2_of_json =
-      (fun x ->
-         match poly2_of_json_poly x with
-         | Some x -> x
-         | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON"
         : Js.Json.t -> poly2)
   
-    let _ = poly2_of_json_poly
-    and _ = poly2_of_json
+    let _ = poly2_of_json
   
     [@@@ocaml.warning "-39-11-27"]
   
@@ -681,7 +667,7 @@
 
     [@@@ocaml.warning "-39-11-27"]
 
-    let rec c_of_json_poly a_of_json : Js.Json.t -> 'a c option =
+    let rec c_of_json a_of_json : Js.Json.t -> 'a c =
      fun x ->
       if Js.Array.isArray x then
         let array = (Obj.magic x : Js.Json.t array) in
@@ -694,8 +680,11 @@
               if Stdlib.( <> ) len 2 then
                 Ppx_deriving_json_runtime.of_json_error
                   "expected a JSON array of length 2";
-              Some (`C (a_of_json (Js.Array.unsafe_get array 1))))
-            else None
+              `C (a_of_json (Js.Array.unsafe_get array 1)))
+            else
+              raise
+                (Ppx_deriving_json_runtime.Of_json_error
+                   (Unpexpected_variant "unexpected variant"))
           else
             Ppx_deriving_json_runtime.of_json_error
               "expected a non empty JSON array with element being a string"
@@ -706,14 +695,7 @@
         Ppx_deriving_json_runtime.of_json_error
           "expected a non empty JSON array"
   
-    and c_of_json a_of_json : Js.Json.t -> 'a c =
-     fun x ->
-      match (c_of_json_poly a_of_json) x with
-      | Some x -> x
-      | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON"
-
-    let _ = c_of_json_poly
-    and _ = c_of_json
+    let _ = c_of_json
   
     [@@@ocaml.warning "-39-11-27"]
   
@@ -794,7 +776,7 @@
 
     [@@@ocaml.warning "-39-11-27"]
 
-    let rec polyrecur_of_json_poly =
+    let rec polyrecur_of_json =
       (fun x ->
          if Js.Array.isArray x then
            let array = (Obj.magic x : Js.Json.t array) in
@@ -807,14 +789,16 @@
                  if Stdlib.( <> ) len 1 then
                    Ppx_deriving_json_runtime.of_json_error
                      "expected a JSON array of length 1";
-                 Some `A)
+                 `A)
                else if Stdlib.( = ) tag "Fix" then (
                  if Stdlib.( <> ) len 2 then
                    Ppx_deriving_json_runtime.of_json_error
                      "expected a JSON array of length 2";
-                 Some
-                   (`Fix (polyrecur_of_json (Js.Array.unsafe_get array 1))))
-               else None
+                 `Fix (polyrecur_of_json (Js.Array.unsafe_get array 1)))
+               else
+                 raise
+                   (Ppx_deriving_json_runtime.Of_json_error
+                      (Unpexpected_variant "unexpected variant"))
              else
                Ppx_deriving_json_runtime.of_json_error
                  "expected a non empty JSON array with element being a \
@@ -825,17 +809,9 @@
          else
            Ppx_deriving_json_runtime.of_json_error
              "expected a non empty JSON array"
-        : Js.Json.t -> polyrecur option)
-  
-    and polyrecur_of_json =
-      (fun x ->
-         match polyrecur_of_json_poly x with
-         | Some x -> x
-         | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON"
         : Js.Json.t -> polyrecur)
 
-    let _ = polyrecur_of_json_poly
-    and _ = polyrecur_of_json
+    let _ = polyrecur_of_json
 
     [@@@ocaml.warning "-39-11-27"]
 
@@ -917,7 +893,7 @@
 
     [@@@ocaml.warning "-39-11-27"]
 
-    let rec epoly_of_json_poly =
+    let rec epoly_of_json =
       (fun x ->
          if Js.Array.isArray x then
            let array = (Obj.magic x : Js.Json.t array) in
@@ -930,13 +906,16 @@
                  if Stdlib.( <> ) len 1 then
                    Ppx_deriving_json_runtime.of_json_error
                      "expected a JSON array of length 1";
-                 Some `a)
+                 `a)
                else if Stdlib.( = ) tag "b" then (
                  if Stdlib.( <> ) len 1 then
                    Ppx_deriving_json_runtime.of_json_error
                      "expected a JSON array of length 1";
-                 Some `b)
-               else None
+                 `b)
+               else
+                 raise
+                   (Ppx_deriving_json_runtime.Of_json_error
+                      (Unpexpected_variant "unexpected variant"))
              else
                Ppx_deriving_json_runtime.of_json_error
                  "expected a non empty JSON array with element being a \
@@ -947,17 +926,9 @@
          else
            Ppx_deriving_json_runtime.of_json_error
              "expected a non empty JSON array"
-        : Js.Json.t -> epoly option)
-  
-    and epoly_of_json =
-      (fun x ->
-         match epoly_of_json_poly x with
-         | Some x -> x
-         | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON"
         : Js.Json.t -> epoly)
 
-    let _ = epoly_of_json_poly
-    and _ = epoly_of_json
+    let _ = epoly_of_json
 
     [@@@ocaml.warning "-39-11-27"]
 

diff --git a/ppx/test/ppx_deriving_json_native.e2e.t b/ppx/test/ppx_deriving_json_native.e2e.t
@@ -49,6 +49,8 @@
   JSON REPRINT: ["S2",42,"hello"]
   JSON    DATA: ["B", 42]
   JSON REPRINT: ["B",42]
+  JSON    DATA: ["C"]
+  JSON REPRINT: ["C"]
   JSON    DATA: ["P2", 42, "hello"]
   JSON REPRINT: ["P2",42,"hello"]
   JSON    DATA: ["Fix",["Fix",["Fix",["A"]]]]