Repository: ocaml-ppx/ppx_deriving (ocaml)

Issue:
`ppx_deriving.make` breaks on mutually recurive types
In `ex.ml`

```ocaml
module Ex = struct
  type t = {a : int; b: s}
  [@@deriving make]
  and s = t list
end
```

With the `dune` file:

```scheme
(library
 (name ex)
 (modules ex)
 (preprocess (pps ppx_deriving.make)))
```

`dune build` gives

```sh
$ dune build                    
File "ex.ml", line 5, characters 2-16:
5 |   and s = t list
      ^^^^^^^^^^^^^^
Error: make can be derived only for record types
```

If we put another deriving annotation on `s` and swap the order the types are declared, the compilation goes thru but the `make` annotation is ignored:

```ocaml
module Ex = struct
  type s = t list
  [@@deriving show]

  and t = {a : int; b: s}
  [@@deriving make]
end
```

Which produces

```ocaml
[@@@ocaml.ppx.context
  {
    tool_name = "ppx_driver";
    include_dirs = [];
    load_path = [];
    open_modules = [];
    for_package = None;
    debug = false;
    use_threads = false;
    use_vmthreads = false;
    recursive_types = false;
    principal = false;
    transparent_modules = false;
    unboxed_types = false;
    unsafe_string = false;
    cookies = [("library-name", "ex")]
  }]
module Ex =
  struct
    type s = t list[@@deriving show]
    and t = {
      a: int ;
      b: s }[@@deriving make]
    let rec pp_s :
      Ppx_deriving_runtime.Format.formatter -> s -> Ppx_deriving_runtime.unit
      =
      let __0 () = pp in
      ((let open! ((Ppx_deriving_runtime)[@ocaml.warning "-A"]) in
          fun fmt ->
            fun x ->
              Ppx_deriving_runtime.Format.fprintf fmt "@[<2>[";
              ignore
                (List.fold_left
                   (fun sep ->
                      fun x ->
                        if sep
                        then Ppx_deriving_runtime.Format.fprintf fmt ";@ ";
                        ((__0 ()) fmt) x;
                        true) false x);
              Ppx_deriving_runtime.Format.fprintf fmt "@,]@]")
        [@ocaml.warning "-A"])
    and show_s : s -> Ppx_deriving_runtime.string =
      fun x -> Ppx_deriving_runtime.Format.asprintf "%a" pp_s x[@@ocaml.warning
                                                                 "-32"]
    and pp :
      Ppx_deriving_runtime.Format.formatter -> t -> Ppx_deriving_runtime.unit
      =
      let __0 () = pp_s in
      ((let open! ((Ppx_deriving_runtime)[@ocaml.warning "-A"]) in
          fun fmt ->
            fun x ->
              Ppx_deriving_runtime.Format.fprintf fmt "@[<2>{ ";
              ((Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " "Ex.Ex.a";
                (Ppx_deriving_runtime.Format.fprintf fmt "%d") x.a;
                Ppx_deriving_runtime.Format.fprintf fmt "@]");
               Ppx_deriving_runtime.Format.fprintf fmt ";@ ";
               Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " "b";
               ((__0 ()) fmt) x.b;
               Ppx_deriving_runtime.Format.fprintf fmt "@]");
              Ppx_deriving_runtime.Format.fprintf fmt "@ }@]")
        [@ocaml.warning "-A"])
    and show : t -> Ppx_deriving_runtime.string =
      fun x -> Ppx_deriving_runtime.Format.asprintf "%a" pp x[@@ocaml.warning
                                                               "-32"]
  end
```

As per `dune describe pp ex.ml`.

If the additional deriving annotation is not added, we get the same error.  



Pull request:
Fix a bug with [@@deriving make] on type declarations sets
Fixes #272.

There was a bug with `[@@deriving make]` that caused errors if it was used on a set of type declarations, recursive or non recursive, that contained a non record type.

The deriver was applied to all type declarations in the set, regardless of where the attributes was attached and failed on the ones that weren't record types.

There is no particularly nice way to handle this in ppxlib, I assume the design decision was that one would only attach a single `[@@deriving ...]` attribute per set and the individual derivers would be responsible to decide which type declarations are relevant.
The driver does allow attaching multiple `[@@deriving ...]` attributes in the same set but performs a merge of all of them so it can lead to confusing situations for the end user.

With all that in mind, there is currently no proper way to tell to which individual type declarations the deriver was attached and even though there might be a hacky one, I'm not sure it would be desirable to use it as it's unlikely that other derivers do so and we probably don't want to have `ppx_deriving.make` behave differently to the rest of the ppx universe in that regard.

The fix will derive `make` for all record types in the set if there is at least one, or will report errors about a misuse of the
deriver otherwise.

The PR contains the initial regression test added in #273 by @shonfeder along with a small refactoring to properly embed errors. This allows us to treat regular errors, for example errors coming from misuse of `[@main]` or `[@split]`, and the `make can only be derived for record types` error differently which we use for the actual fix.

I also updated the README to document how to use `ppx_deriving.make` with type declaration sets. 

Patch:
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 817ce30..78059e2 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,16 @@
 unreleased
 ----------
 
+* Fix a bug in `[@@deriving make]` that caused errors when it was used on a set
+  of type declarations containing at least one non record type.
+  #<PR_NUMBER>
+  (@NathanReb)
+
+* Embed errors instead of raising exceptions when generating code
+  with `ppx_deriving.make`
+  #<PR_NUMBER>
+  (@NathanReb)
+
 * Remove `[%derive.iter ...]`, `[%derive.map ...]` and `[%derive.fold ...]`
   extensions
   #278
diff --git a/README.md b/README.md
index 9237e5e..f0fcb6a 100644
--- a/README.md
+++ b/README.md
@@ -287,6 +287,10 @@ val make_record :
   record
 ```
 
+To use _make_ with a set of mutually recursive type definitions, simply attach a
+single `[@@deriving make]` attribute and it will derive a `make_*` function for
+each record type in the set.
+
 The deriving runtime
 --------------------
 
diff --git a/src_plugins/make/ppx_deriving_make.ml b/src_plugins/make/ppx_deriving_make.ml
index 49947bc..cd4545c 100644
--- a/src_plugins/make/ppx_deriving_make.ml
+++ b/src_plugins/make/ppx_deriving_make.ml
@@ -11,134 +11,202 @@ let attr_default context = Attribute.declare "deriving.make.default" context
   Ast_pattern.(single_expr_payload __) (fun e -> e)
 let attr_default = (attr_default Attribute.Context.label_declaration, attr_default Attribute.Context.core_type)
 
-let attr_split context = Attribute.declare_flag "deriving.make.split" context
-let ct_attr_split = attr_split Attribute.Context.core_type
-let label_attr_split = attr_split Attribute.Context.label_declaration
+let mk_attr_split context = Attribute.declare_flag "deriving.make.split" context
+let ct_attr_split = mk_attr_split Attribute.Context.core_type
+let label_attr_split = mk_attr_split Attribute.Context.label_declaration
 
-let attr_main context = Attribute.declare_flag "deriving.make.main" context
-let ct_attr_main = attr_main Attribute.Context.core_type
-let label_attr_main = attr_main Attribute.Context.label_declaration
+let attr_split = (label_attr_split, ct_attr_split)
+
+let mk_attr_main context = Attribute.declare_flag "deriving.make.main" context
+let ct_attr_main = mk_attr_main Attribute.Context.core_type
+let label_attr_main = mk_attr_main Attribute.Context.label_declaration
+
+let attr_main = (label_attr_main, ct_attr_main)
 
 let get_label_attribute (label_attr, ct_attr) label =
   match Attribute.get label_attr label with
   | Some _ as v -> v
   | None -> Attribute.get ct_attr label.pld_type
 
-let find_main labels =
-  List.fold_left (fun (main, labels) ({ pld_type; pld_loc; pld_attributes } as label) ->
-    if Attribute.has_flag ct_attr_main pld_type || Attribute.has_flag label_attr_main label then
-      match main with
-      | Some _ -> raise_errorf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" deriver
-      | None -> Some label, labels
-    else
-      main, label :: labels)
-    (None, []) labels
+let has_label_flag (label_flag, ct_flag) ({pld_type; _} as label) =
+  Attribute.has_flag ct_flag pld_type || Attribute.has_flag label_flag label
 
+let find_main labels =
+  let mains, regulars = List.partition (has_label_flag attr_main) labels in
+  match mains, regulars with
+  | [], labels -> Ok (None, labels)
+  | [main], labels -> Ok (Some main, labels)
+  | _::{pld_loc; _}::_ , _ ->
+    Error
+      (Location.error_extensionf ~loc:pld_loc
+         "Duplicate [@deriving.%s.main] annotation" deriver)
 
-let is_optional ({ pld_name = { txt = name }; pld_type; pld_attributes } as label) =
+let is_optional ({ pld_name = { txt = name }; pld_type; _ } as label) =
   match get_label_attribute attr_default label with
   | Some _ -> true
   | None ->
-    Attribute.has_flag label_attr_split label || Attribute.has_flag ct_attr_split pld_type ||
+    has_label_flag attr_split label ||
     (match Ppx_deriving.remove_pervasives ~deriver pld_type with
      | [%type: [%t? _] list]
      | [%type: [%t? _] option] -> true
      | _ -> false)
 
+let add_str_label_arg ~quoter ~loc accum
+    ({pld_name = {txt = name}; pld_type; _} as label) =
+  match get_label_attribute attr_default label with
+  | Some default ->
+    Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default))
+      (pvar name) accum
+  | None ->
+    let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
+    if has_label_flag attr_split label then
+      match pld_type with
+      | [%type: [%t? lhs] * [%t? rhs] list] when name.[String.length name - 1] = 's' ->
+        let name' = String.sub name 0 (String.length name - 1) in
+        Exp.fun_ (Label.labelled name') None (pvar name')
+          (Exp.fun_ (Label.optional name) (Some [%expr []]) (pvar name)
+             [%expr let [%p pvar name] = [%e evar name'], [%e evar name] in [%e accum]])
+      | _ ->
+        Ast_builder.Default.pexp_extension ~loc
+          (Location.error_extensionf ~loc
+             "[@deriving.%s.split] annotation requires a type of form \
+              'a * 'a list and label name ending with `s'"
+             deriver)
+    else
+      match pld_type with
+      | [%type: [%t? _] list] ->
+        Exp.fun_ (Label.optional name) (Some [%expr []]) (pvar name) accum
+      | [%type: [%t? _] option] ->
+        Exp.fun_ (Label.optional name) None (pvar name) accum
+      | _ -> Exp.fun_ (Label.labelled name) None (pvar name) accum
+
+let str_of_record_type ~quoter ~loc labels =
+  let fields =
+    labels |> List.map (fun { pld_name = { txt = name; loc } } ->
+        name, evar name) in
+  match find_main labels with
+  | Error extension -> Ast_builder.Default.pexp_extension ~loc extension
+  | Ok (main, labels) ->
+    let has_option = List.exists is_optional labels in
+    let fn =
+      match main with
+      | Some { pld_name = { txt = name }} ->
+        Exp.fun_ Label.nolabel None (pvar name) (record fields)
+      | None when has_option ->
+        Exp.fun_ Label.nolabel None (punit ()) (record fields)
+      | None ->
+        record fields
+    in
+    List.fold_left (add_str_label_arg ~quoter ~loc) fn labels
+
 let str_of_type ({ ptype_loc = loc } as type_decl) =
   let quoter = Ppx_deriving.create_quoter () in
-  let creator =
-    match type_decl.ptype_kind with
-    | Ptype_record labels ->
-      let fields =
-        labels |> List.map (fun { pld_name = { txt = name; loc } } ->
-          name, evar name) in
-      let main, labels = find_main labels in
-      let has_option = List.exists is_optional labels in
-      let fn =
-        match main with
-        | Some { pld_name = { txt = name }} ->
-          Exp.fun_ Label.nolabel None (pvar name) (record fields)
-        | None when has_option ->
-          Exp.fun_ Label.nolabel None (punit ()) (record fields)
-        | None ->
-          record fields
-      in
-      List.fold_left (fun accum ({ pld_name = { txt = name }; pld_type; pld_attributes } as label) ->
-        match get_label_attribute attr_default label with
-        | Some default -> Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default))
-                                   (pvar name) accum
-        | None ->
-        let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
-        if Attribute.has_flag label_attr_split label || Attribute.has_flag ct_attr_split pld_type then
-          match pld_type with
-          | [%type: [%t? lhs] * [%t? rhs] list] when name.[String.length name - 1] = 's' ->
-            let name' = String.sub name 0 (String.length name - 1) in
-            Exp.fun_ (Label.labelled name') None (pvar name')
-              (Exp.fun_ (Label.optional name) (Some [%expr []]) (pvar name)
-                [%expr let [%p pvar name] = [%e evar name'], [%e evar name] in [%e accum]])
-          | _ -> raise_errorf ~loc "[@deriving.%s.split] annotation requires a type of form \
-                                    'a * 'b list and label name ending with `s'" deriver
-        else
-          match pld_type with
-          | [%type: [%t? _] list] ->
-            Exp.fun_ (Label.optional name) (Some [%expr []]) (pvar name) accum
-          | [%type: [%t? _] option] ->
-            Exp.fun_ (Label.optional name) None (pvar name) accum
-          | _ -> Exp.fun_ (Label.labelled name) None (pvar name) accum)
-          fn labels
-    | _ -> raise_errorf ~loc "%s can be derived only for record types" deriver
-  in
-  [Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl))
-         (Ppx_deriving.sanitize ~quoter creator)]
+  match type_decl.ptype_kind with
+  | Ptype_record labels ->
+    let creator = str_of_record_type ~quoter ~loc labels in
+    Ok
+      (Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl))
+         (Ppx_deriving.sanitize ~quoter creator))
+  | _ ->
+    Error
+      (Location.error_extensionf ~loc
+         "%s can be derived only for record types" deriver)
 
 let wrap_predef_option typ =
   typ
 
+let add_sig_label_arg accum
+    ({pld_name = {txt = name; loc}; pld_type; _} as label) = 
+  match get_label_attribute attr_default label with
+  | Some _ ->
+    Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum
+  | None ->
+    let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
+    if has_label_flag attr_split label then
+      match pld_type with
+      | [%type: [%t? lhs] * [%t? rhs] list]
+        when name.[String.length name - 1] = 's' ->
+        let name' = String.sub name 0 (String.length name - 1) in
+        Typ.arrow (Label.labelled name') lhs
+          (Typ.arrow (Label.optional name)
+             (wrap_predef_option [%type: [%t rhs] list]) accum)
+      | _ ->
+        Ast_builder.Default.ptyp_extension ~loc
+          (Location.error_extensionf ~loc
+             "[@deriving.%s.split] annotation requires a type of form \
+              'a * 'a list and label name ending with `s'"
+             deriver)
+    else
+      match pld_type with
+      | [%type: [%t? _] list] ->
+        Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum
+      | [%type: [%t? opt] option] ->
+        Typ.arrow (Label.optional name) (wrap_predef_option opt) accum
+      | _ -> Typ.arrow (Label.labelled name) pld_type accum
+
+let sig_of_record_type ~loc ~typ labels =
+  match find_main labels with
+  | Error extension -> Ast_builder.Default.ptyp_extension ~loc extension
+  | Ok (main, labels) ->
+    let has_option = List.exists is_optional labels in
+    let typ =
+      match main with
+      | Some { pld_name = { txt = name }; pld_type } ->
+        Typ.arrow Label.nolabel pld_type typ
+      | None when has_option -> Typ.arrow Label.nolabel (tconstr "unit" []) typ
+      | None -> typ
+    in
+    List.fold_left add_sig_label_arg typ labels
+
 let sig_of_type ({ ptype_loc = loc } as type_decl) =
   let typ = Ppx_deriving.core_type_of_type_decl type_decl in
-  let typ =
-    match type_decl.ptype_kind with
-    | Ptype_record labels ->
-      let main, labels = find_main labels in
-      let has_option = List.exists is_optional labels in
-      let typ =
-        match main with
-        | Some { pld_name = { txt = name }; pld_type } ->
-          Typ.arrow Label.nolabel pld_type typ
-        | None when has_option -> Typ.arrow Label.nolabel (tconstr "unit" []) typ
-        | None -> typ
-      in
-      List.fold_left (fun accum ({ pld_name = { txt = name; loc }; pld_type; pld_attributes } as label) ->
-        match get_label_attribute attr_default label with
-        | Some _ -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum
-        | None ->
-        let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
-        if Attribute.has_flag ct_attr_split pld_type || Attribute.has_flag label_attr_split label then
-          match pld_type with
-          | [%type: [%t? lhs] * [%t? rhs] list] when name.[String.length name - 1] = 's' ->
-            let name' = String.sub name 0 (String.length name - 1) in
-            Typ.arrow (Label.labelled name') lhs
-              (Typ.arrow (Label.optional name) (wrap_predef_option [%type: [%t rhs] list]) accum)
-          | _ -> raise_errorf ~loc "[@deriving.%s.split] annotation requires a type of form \
-                                    'a * 'b list and label name ending with `s'" deriver
-        else
-          match pld_type with
-          | [%type: [%t? _] list] ->
-            Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum
-          | [%type: [%t? opt] option] ->
-            Typ.arrow (Label.optional name) (wrap_predef_option opt) accum
-          | _ -> Typ.arrow (Label.labelled name) pld_type accum)
-        typ labels
-    | _ -> raise_errorf ~loc "%s can only be derived for record types" deriver
+  match type_decl.ptype_kind with
+  | Ptype_record labels ->
+    let typ = sig_of_record_type ~loc ~typ labels in
+    let val_name = Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl in
+    Ok (Sig.value (Val.mk (mknoloc val_name) typ))
+  | _ ->
+    Error
+      (Location.error_extensionf ~loc
+         "%s can only be derived for record types" deriver)
+
+(* Ppxlib does not keep track of which type the attribute was attached to
+   in a set of type declarations and does not provide a nice and reliable
+   way to manually check it.
+   Until we have something better, we have to assume that the
+   [[@@deriving make]] attribute was meant for the whole set and properly
+   placed. That means that if there is at least one type declaration in the
+   set for which we can derive make, we will ignore errors from the rest. *)
+
+let partition_result l =
+  let errors, oks =
+    List.fold_left
+      (fun (errors, oks) res ->
+         match res with
+         | Ok x -> (errors, x :: oks)
+         | Error e -> (e :: errors, oks))
+      ([], [])
+      l
   in
-  [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) typ)]
+  List.rev errors, List.rev oks
 
-let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) ->
-  [Str.value Nonrecursive (List.concat (List.map str_of_type type_decls))])
+let impl_generator =
+  Deriving.Generator.V2.make_noarg (fun ~ctxt (_, type_decls) ->
+      match partition_result (List.map str_of_type type_decls) with
+      | _, (_::_ as vbs) -> [Str.value Nonrecursive vbs]
+      | errors, [] ->
+        let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+        List.map (fun ext -> Ast_builder.Default.pstr_extension ~loc ext [])
+          errors)
 
-let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) ->
-  List.concat (List.map sig_of_type type_decls))
+let intf_generator =
+  Deriving.Generator.V2.make_noarg (fun ~ctxt (_, type_decls) ->
+      match partition_result (List.map sig_of_type type_decls) with
+      | _, (_::_ as vds) -> vds
+      | errors, [] ->
+        let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+        List.map (fun ext -> Ast_builder.Default.psig_extension ~loc ext [])
+          errors)
 
 let deriving: Deriving.t =
   Deriving.add


Test patch:
diff --git a/src_test/make/test_deriving_make.ml b/src_test/make/test_deriving_make.ml
index 51c8a67..506f8aa 100644
--- a/src_test/make/test_deriving_make.ml
+++ b/src_test/make/test_deriving_make.ml
@@ -21,6 +21,14 @@ module M : sig
     c1 : int;
     c2 : string
   } [@@deriving show, make]
+
+  type principle_recursive_type =
+    { prt1 : int
+    ; prt2 : secondary_recursive_type
+    } [@@deriving show, make]
+
+  and secondary_recursive_type = string
+  [@@deriving show]
 end = struct
   type a = {
     a1  : int option;
@@ -42,6 +50,18 @@ end = struct
     c1 : int;
     c2 : string
   } [@@deriving show, make]
+
+  (*  Generate make for a record that is part of a mutually recursive type declaration.
+      Generation should succeed, and not try to generate `make` for non-annotated types.
+
+      Regression test for https://github.com/ocaml-ppx/ppx_deriving/issues/272 *)
+  type principle_recursive_type =
+    { prt1 : int
+    ; prt2 : secondary_recursive_type
+    } [@@deriving show, make]
+
+  and secondary_recursive_type = string
+  [@@deriving show]
 end
 
 let test_no_main ctxt =
@@ -65,10 +85,16 @@ let test_no_unit ctxt =
     { M.c1 = 0; M.c2 = "" }
     (M.make_c ~c1:0 ~c2:"")
 
+let test_recursive_types ctxt =
+  assert_equal ~printer:M.show_principle_recursive_type
+    { M.prt1 = 0; M.prt2 = "" }
+    (M.make_principle_recursive_type ~prt1:0 ~prt2:"")
+
 let suite = "Test deriving(make)" >::: [
     "test_no_main" >:: test_no_main;
     "test_main"    >:: test_main;
-    "test_no_unit" >:: test_no_unit
+    "test_no_unit" >:: test_no_unit;
+    "test_recursive_types" >:: test_recursive_types;
   ]
 
 let _ = run_test_tt_main suite