Add support for mutually recursive types

Signed-off-by: Nathan Rebours <[email protected]>

deriver/error.ml

@@ -4,10 +4,6 @@ let error_extensionf ~loc fmt =
   Location.error_extensionf ~loc ("ppx_deriving_dyn: " ^^ fmt)
 ;;
 
-let unsupported_mutually_rec_type_decl ~loc =
-  error_extensionf ~loc "Mutually recursive type declarations are not supported."
-;;
-
 let unsupported_type_param ~loc = error_extensionf ~loc "unsupported type parameter"
 let unsupported_longident ~loc = error_extensionf ~loc "unsupported longident"
 let unsupported_type ~loc = error_extensionf ~loc "cannot derive to_dyn for this type"

deriver/error.mli

@@ -1,6 +1,5 @@
 open Ppxlib
 
-val unsupported_mutually_rec_type_decl : loc:Location.t -> extension
 val unsupported_type_param : loc:Location.t -> extension
 val unsupported_longident : loc:Location.t -> extension
 val unsupported_type : loc:Location.t -> extension

deriver/ppx_deriving_dyn.ml

@@ -278,7 +278,7 @@ module Impl = struct
       Ast_builder.Default.pexp_extension ~loc (Error.unsupported_type_param ~loc)
   ;;
 
-  let to_dyn_fun ~loc ~rec_flag:_ ~type_declaration =
+  let to_dyn_fun ~loc ~type_declaration =
     match type_declaration with
     | { ptype_kind = Ptype_abstract; ptype_manifest = Some core_type; ptype_params; _ } ->
       let main_arg_name = type_declaration.ptype_name.txt in
@@ -318,22 +318,23 @@ module Impl = struct
         (Error.unsupported_type ~loc:ptype_loc)
   ;;
 
+  let value_binding ~loc type_declaration =
+    let fun_name = to_dyn_name type_declaration.ptype_name.txt in
+    let pat = Ast_builder.Default.(ppat_var ~loc { txt = fun_name; loc }) in
+    let expr = to_dyn_fun ~loc ~type_declaration in
+    Ast_builder.Default.value_binding ~loc ~pat ~expr
+  ;;
+
   let generate ~ctxt (rec_flag, type_declarations) =
     let loc = Expansion_context.Deriver.derived_item_loc ctxt in
     match type_declarations with
     | [] -> assert false
-    | _ :: _ :: _ ->
-      [ Ast_builder.Default.pstr_extension
-          ~loc
-          (Error.unsupported_mutually_rec_type_decl ~loc)
-          []
-      ]
     | [ type_declaration ] ->
-      let fun_name = to_dyn_name type_declaration.ptype_name.txt in
-      let pat = Ast_builder.Default.(ppat_var ~loc { txt = fun_name; loc }) in
-      let expr = to_dyn_fun ~loc ~rec_flag ~type_declaration in
-      let value_binding = Ast_builder.Default.value_binding ~loc ~pat ~expr in
+      let value_binding = value_binding ~loc type_declaration in
       [ Ast_builder.Default.pstr_value ~loc Nonrecursive [ value_binding ] ]
+    | type_decls ->
+      let value_bindings = List.map (value_binding ~loc) type_decls in
+      [ Ast_builder.Default.pstr_value ~loc rec_flag value_bindings ]
   ;;
 
   let generator = Deriving.Generator.V2.make_noarg generate
@@ -372,22 +373,19 @@ module Intf = struct
     with_type_param_args ~loc ~type_params type_
   ;;
 
+  let to_dyn_value ~loc type_declaration =
+    let fun_name = to_dyn_name type_declaration.ptype_name.txt in
+    let name = { txt = fun_name; loc } in
+    let type_ = to_dyn_type ~loc type_declaration in
+    let descr = Ast_builder.Default.value_description ~loc ~name ~type_ ~prim:[] in
+    Ast_builder.Default.psig_value ~loc descr
+  ;;
+
   let generate ~ctxt (_rec_flag, type_declarations) =
     let loc = Expansion_context.Deriver.derived_item_loc ctxt in
     match type_declarations with
     | [] -> assert false
-    | _ :: _ :: _ ->
-      [ Ast_builder.Default.psig_extension
-          ~loc
-          (Error.unsupported_mutually_rec_type_decl ~loc)
-          []
-      ]
-    | [ type_declaration ] ->
-      let fun_name = to_dyn_name type_declaration.ptype_name.txt in
-      let name = { txt = fun_name; loc } in
-      let type_ = to_dyn_type ~loc type_declaration in
-      let descr = Ast_builder.Default.value_description ~loc ~name ~type_ ~prim:[] in
-      [ Ast_builder.Default.psig_value ~loc descr ]
+    | type_decls -> List.map (to_dyn_value ~loc) type_decls
   ;;
 
   let generator = Deriving.Generator.V2.make_noarg generate

test/deriver/test_to_dyn.expected.ml

@@ -66,6 +66,36 @@ include
        | `C (x0, x1) -> Dyn.variant "C" [Dyn.int x0; Dyn.string x1])
         polymorphic_variant
   end[@@ocaml.doc "@inline"][@@merlin.hide ]
+type mrec_1 =
+  | A of int 
+  | B of mrec_2 
+  | C of mrec_3 [@@ocaml.warning "-37"]
+and mrec_2 =
+  | D of mrec_1 
+  | E of string 
+  | F of mrec_3 [@@ocaml.warning "-37"]
+and mrec_3 =
+  | G of mrec_1 
+  | H of mrec_2 
+  | I of bool [@@deriving dyn][@@ocaml.warning "-37"]
+include
+  struct
+    let rec mrec_1_to_dyn =
+      function
+      | A a -> Dyn.variant "A" [Dyn.int a]
+      | B b -> Dyn.variant "B" [mrec_2_to_dyn b]
+      | C c -> Dyn.variant "C" [mrec_3_to_dyn c]
+    and mrec_2_to_dyn =
+      function
+      | D d -> Dyn.variant "D" [mrec_1_to_dyn d]
+      | E e -> Dyn.variant "E" [Dyn.string e]
+      | F f -> Dyn.variant "F" [mrec_3_to_dyn f]
+    and mrec_3_to_dyn =
+      function
+      | G g -> Dyn.variant "G" [mrec_1_to_dyn g]
+      | H h -> Dyn.variant "H" [mrec_2_to_dyn h]
+      | I i -> Dyn.variant "I" [Dyn.bool i]
+  end[@@ocaml.doc "@inline"][@@merlin.hide ]
 module Base_types =
   struct
     type t = int[@@deriving dyn]

test/deriver/test_to_dyn.expected.mli

@@ -21,6 +21,15 @@ type long_tuple
 val long_tuple_to_dyn : long_tuple Dyn.builder
 type polymorphic_variant
 val polymorphic_variant_to_dyn : polymorphic_variant Dyn.builder
+type mrec_1
+and mrec_2
+and mrec_3[@@deriving dyn]
+include
+  sig
+    val mrec_1_to_dyn : mrec_1 Dyn.builder
+    val mrec_2_to_dyn : mrec_2 Dyn.builder
+    val mrec_3_to_dyn : mrec_3 Dyn.builder
+  end[@@ocaml.doc "@inline"][@@merlin.hide ]
 module Base_types :
 sig
   type t[@@deriving dyn]

test/deriver/test_to_dyn.ml

@@ -37,6 +37,24 @@ type polymorphic_variant =
   ]
 [@@deriving dyn]
 
+type mrec_1 =
+  | A of int
+  | B of mrec_2
+  | C of mrec_3
+[@@ocaml.warning "-37"]
+
+and mrec_2 =
+  | D of mrec_1
+  | E of string
+  | F of mrec_3
+[@@ocaml.warning "-37"]
+
+and mrec_3 =
+  | G of mrec_1
+  | H of mrec_2
+  | I of bool
+[@@deriving dyn] [@@ocaml.warning "-37"]
+
 module Base_types = struct
   type t = int [@@deriving dyn]
   type t1 = unit [@@deriving dyn]

test/deriver/test_to_dyn.mli

@@ -23,6 +23,10 @@ type polymorphic_variant
 
 val polymorphic_variant_to_dyn : polymorphic_variant Dyn.builder
 
+type mrec_1
+and mrec_2
+and mrec_3 [@@deriving dyn]
+
 module Base_types : sig
   type t [@@deriving dyn]
   type t1