Repository: ocaml-ppx/ppx_deriving_yojson (ocaml)

Issue:
Fails on recursive variant types with the same constructor name
Consider:

```ocaml
type t1 =
  | Foo of int
  | Bar of t2

and t2 =
  | Foo of string
  | Baz of t1
```

Add:

```ocaml
[@@deriving yojson]
```

and you will get:

```
File "_none_", line 1:
Error: This expression has type string but an expression was expected of type
         int
```

coming from the fact, presumably, that the generated pattern matchings both contain a match on `Foo _ ->` and OCaml gets confused typing them. This does not happen if we type explicitly the functions. For instance, the manually written:

```ocaml
let rec t1_to_yojson : t1 -> Yojson.Safe.t = function
  | Foo n -> `List [`String "Foo"; `Int n]
  | Bar x -> `List [`String "Bar"; t2_to_yojson x]

and t2_to_yojson : t2 -> Yojson.Safe.t = function
  | Foo s -> `List [`String "Foo"; `String s]
  | Baz x -> `List [`String "Baz"; t1_to_yojson x]

let rec t1_of_yojson : Yojson.Safe.t -> (t1, string) result = function
  | `List [`String "Foo"; `Int n] -> Ok (Foo n)
  | `List [`String "Bar"; x] -> Result.map (fun x -> (Bar x)) (t2_of_yojson x)
  | _ -> Error "nope"

and t2_of_yojson : Yojson.Safe.t -> (t2, string) result = function
  | `List [`String "Foo"; `String s] -> Ok (Foo s)
  | `List [`String "Baz"; x] -> Result.map (fun x -> (Baz x)) (t1_of_yojson x)
  | _ -> Error "nope"
```

compiles just fine. Note that `ppx_deriving.std` must also be doing something like that because it compiles successfully in this situation.

Tested with `ppx_deriving_yojson` 3.9 and 3.10.

I am happy to write a PR - are they welcome?

I know `ppx_deriving_yojson` isn't maintained so much and `ppx_yojson_conv` should be preferred (although https://github.com/ocaml-ppx/ppx_deriving_yojson/issues/158?), but I'm in a rather big project that has been using `ppx_deriving_yojson` for a long time, and switching would be difficult. (In fact, I even stumbled upon a bug in the OCaml compiler when trying to switch!)

Pull request description:
Add granular type constraints on cases in `of_yojson` - fix #163
Closes https://github.com/ocaml-ppx/ppx_deriving_yojson/issues/163

We might find this solution to be way too ad-hoc. I am fine trying to find a better approach.

Patch:
diff --git a/src/ppx_deriving_yojson.ml b/src/ppx_deriving_yojson.ml
index 15df80e..c933ca2 100644
--- a/src/ppx_deriving_yojson.ml
+++ b/src/ppx_deriving_yojson.ml
@@ -609,9 +609,18 @@ let desu_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
             Exp.case
               [%pat? `List ((`String [%p pstr name]) ::
                                      [%p plist (List.mapi (fun i _ -> pvar (argn i)) args)])]
-              (desu_fold ~quoter ~loc ~path (fun x -> constr name' x) args)
+              (desu_fold ~quoter ~loc ~path
+                 (fun x ->
+                    (* https://github.com/ocaml-ppx/ppx_deriving_yojson/issues/163 *)
+                    let typ = Ppx_deriving.core_type_of_type_decl type_decl in
+                    Exp.constraint_ (constr name' x) typ)
+                 args)
           | Pcstr_record labels ->
-            let wrap_record r = constr name' [r] in
+            let wrap_record r =
+              (* https://github.com/ocaml-ppx/ppx_deriving_yojson/issues/163 *)
+              let typ = Ppx_deriving.core_type_of_type_decl type_decl in
+              Exp.constraint_ (constr name' [r]) typ
+            in
             let sub =
               desu_str_of_record ~quoter ~loc ~is_strict ~error ~path wrap_record labels in
             let name = match Attribute.get constr_attr_name constr' with Some s -> s | None -> name' in


Test patch:
diff --git a/src_test/test_ppx_yojson.ml b/src_test/test_ppx_yojson.ml
index ca4d95b..a5162b7 100644
--- a/src_test/test_ppx_yojson.ml
+++ b/src_test/test_ppx_yojson.ml
@@ -502,6 +502,44 @@ let test_recursive _ctxt =
   assert_roundtrip pp_bar bar_to_yojson bar_of_yojson
                    {lhs="x"; rhs=42} "{\"lhs\":\"x\",\"rhs\":42}"
 
+type recursive2 = Nil2 | Rec3 of recursive2'
+and recursive2' = Nil3 | Rec2 of recursive2
+[@@deriving show, yojson]
+
+let test_recursive_2 _ctxt =
+  assert_roundtrip pp_recursive2
+                   recursive2_to_yojson
+                   recursive2_of_yojson
+                   (Rec3 (Rec2 Nil2)) "[\"Rec3\", [\"Rec2\", [\"Nil2\"]]]"
+
+module Recursive3 = struct
+  [@@@ocaml.warning "-30"]
+  type t = Nil | Rec of t'
+  and t' = Nil | Rec of t
+  [@@deriving show, yojson]
+
+  let test _ctxt =
+    assert_roundtrip pp
+      to_yojson
+      of_yojson
+      (Rec (Rec Nil)) "[\"Rec\", [\"Rec\", [\"Nil\"]]]"
+end
+let test_recursive_3 = Recursive3.test
+
+module Recursive4 = struct
+  [@@@ocaml.warning "-30"]
+  type t = Nil | Rec of {x: t'}
+  and t' = Nil | Rec of {x: t}
+  [@@deriving show, yojson]
+
+  let test _ctxt =
+    assert_roundtrip pp
+      to_yojson
+      of_yojson
+      (Rec {x = Rec {x = Nil }}) "[\"Rec\", {\"x\": [\"Rec\", {\"x\": [\"Nil\"]}]}]"
+end
+let test_recursive_4 = Recursive4.test
+
 let test_int_redefined ctxt =
   let module M = struct
     type int = Break_things
@@ -593,6 +631,9 @@ let suite = "Test ppx_yojson" >::: [
     "test_nostrict"  >:: test_nostrict;
     "test_opentype"  >:: test_opentype;
     "test_recursive" >:: test_recursive;
+    "test_recursive_2" >:: test_recursive_2;
+    "test_recursive_3" >:: test_recursive_3;
+    "test_recursive_4" >:: test_recursive_4;
     "test_int_redefined" >:: test_int_redefined;
     "test_equality_redefined" >:: test_equality_redefined;
   ]