Regression test for incorrect behavior when deriving on mutually recursive types

CHANGELOG.md

@@ -1,6 +1,10 @@
 (unreleased)
 ------------
 
+* Port standard plugins to ppxlib registration and attributes
+  #263
+  (Simmo Saan)
+
 * Introduce `Ppx_deriving_runtime.Stdlib` with OCaml >= 4.07. This module
   already exists in OCaml < 4.07 but was missing otherwise.
 

ppx_deriving.opam

@@ -19,7 +19,7 @@ depends: [
   "cppo" {build}
   "ocamlfind"
   "ppx_derivers"
-  "ppxlib" {>= "0.20.0"}
+  "ppxlib" {>= "0.29.0"}
   "result"
   "ounit2" {with-test}
 ]

src/api/ppx_deriving.cppo.ml

@@ -309,39 +309,24 @@ let attr_warning expr =
     attr_loc = loc;
   }
 
-type quoter = {
-  mutable next_id : int;
-  mutable bindings : value_binding list;
-}
+type quoter = Expansion_helpers.Quoter.t
 
-let create_quoter () = { next_id = 0; bindings = [] }
+let create_quoter () = Expansion_helpers.Quoter.create ()
 
 let quote ~quoter expr =
-  let loc = !Ast_helper.default_loc in
-  let name = "__" ^ string_of_int quoter.next_id in
-  let (binding_body, quoted_expr) = match expr with
-    (* Optimize identifier quoting by avoiding closure.
-       See https://github.com/ocaml-ppx/ppx_deriving/pull/252. *)
-    | { pexp_desc = Pexp_ident _; _ } ->
-      (expr, evar name)
-    | _ ->
-      ([%expr fun () -> [%e expr]], [%expr [%e evar name] ()])
-  in
-  quoter.bindings <- (Vb.mk (pvar name) binding_body) :: quoter.bindings;
-  quoter.next_id <- quoter.next_id + 1;
-  quoted_expr
+  Expansion_helpers.Quoter.quote quoter expr
 
 let sanitize ?(module_=Lident "Ppx_deriving_runtime") ?(quoter=create_quoter ()) expr =
+  let loc = !Ast_helper.default_loc in
   let body =
-    let loc = !Ast_helper.default_loc in
     let attrs = [attr_warning [%expr "-A"]] in
     let modname = { txt = module_; loc } in
     Exp.open_ ~loc ~attrs
       (Opn.mk ~loc ~attrs ~override:Override (Mod.ident ~loc ~attrs modname))
       expr in
-  match quoter.bindings with
-  | [] -> body
-  | bindings -> Exp.let_ Nonrecursive bindings body
+  let sanitized = Expansion_helpers.Quoter.sanitize quoter body in
+  (* ppxlib quoter uses Recursive, ppx_deriving's used Nonrecursive - silence warning *)
+  { sanitized with pexp_attributes = attr_warning [%expr "-39"] :: sanitized.pexp_attributes}
 
 let with_quoter fn a =
   let quoter = create_quoter () in

src_plugins/create/ppx_deriving_create.cppo.ml

@@ -7,30 +7,41 @@ open Ppx_deriving.Ast_convenience
 let deriver = "create"
 let raise_errorf = Ppx_deriving.raise_errorf
 
-let parse_options options =
-  options |> List.iter (fun (name, expr) ->
-    match name with
-    | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name)
+let attr_default context = Attribute.declare "deriving.create.default" context
+  Ast_pattern.(single_expr_payload __) (fun e -> e)
+let ct_attr_default = attr_default Attribute.Context.core_type
+let label_attr_default = attr_default Attribute.Context.label_declaration
 
-let attr_default attrs =
-  Ppx_deriving.(attrs |> attr ~deriver "default" |> Arg.(get_attr ~deriver expr))
+let attr_split context = Attribute.declare "deriving.create.split" context
+  Ast_pattern.(pstr nil) ()
+let ct_attr_split = attr_split Attribute.Context.core_type
+let label_attr_split = attr_split Attribute.Context.label_declaration
 
-let attr_split attrs =
-  Ppx_deriving.(attrs |> attr ~deriver "split" |> Arg.get_flag ~deriver)
+let attr_main context = Attribute.declare "deriving.create.main" context
+  Ast_pattern.(pstr nil) ()
+let ct_attr_main = attr_main Attribute.Context.core_type
+let label_attr_main = attr_main Attribute.Context.label_declaration
+
+let attribute_get2 attr1 x1 attr2 x2 =
+  match Attribute.get attr1 x1, Attribute.get attr2 x2 with
+  | Some _ as y, _ -> y
+  | None, y -> y
 
 let find_main labels =
   List.fold_left (fun (main, labels) ({ pld_type; pld_loc; pld_attributes } as label) ->
-    if Ppx_deriving.(pld_type.ptyp_attributes @ pld_attributes |>
-                     attr ~deriver "main" |> Arg.get_flag ~deriver) then
+    let is_main = match attribute_get2 ct_attr_main pld_type label_attr_main label with
+      | Some () -> true
+      | None -> false
+    in
+    if is_main 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 str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
-  parse_options options;
+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
@@ -46,14 +57,17 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
         | None ->
           Exp.fun_ Label.nolabel None (punit ()) (record fields)
       in
-      List.fold_left (fun accum { pld_name = { txt = name }; pld_type; pld_attributes } ->
-        let attrs = pld_attributes @ pld_type.ptyp_attributes in
-        let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
-        match attr_default attrs with
+      List.fold_left (fun accum ({ pld_name = { txt = name }; pld_type; pld_attributes } as label) ->
+        match attribute_get2 label_attr_default label ct_attr_default pld_type with
         | Some default -> Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default))
                                    (pvar name) accum
         | None ->
-        if attr_split attrs then
+        let split = match attribute_get2 label_attr_split label ct_attr_split pld_type with
+          | Some () -> true
+          | None -> false
+        in
+        let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
+        if split 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
@@ -78,8 +92,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
 let wrap_predef_option typ =
   typ
 
-let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
-  parse_options options;
+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
@@ -92,13 +105,16 @@ let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
         | None ->
           Typ.arrow Label.nolabel (tconstr "unit" []) typ
       in
-      List.fold_left (fun accum { pld_name = { txt = name; loc }; pld_type; pld_attributes } ->
-        let attrs = pld_type.ptyp_attributes @ pld_attributes in
-        let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
-        match attr_default attrs with
+      List.fold_left (fun accum ({ pld_name = { txt = name; loc }; pld_type; pld_attributes } as label) ->
+        match attribute_get2 ct_attr_default pld_type label_attr_default label with
         | Some _ -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum
         | None ->
-        if attr_split attrs then
+        let split = match attribute_get2 ct_attr_split pld_type label_attr_split label with
+          | Some () -> true
+          | None -> false
+        in
+        let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
+        if split 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
@@ -118,11 +134,14 @@ let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
   in
   [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) typ)]
 
-let () =
-  Ppx_deriving.(register (create deriver
-    ~type_decl_str: (fun ~options ~path type_decls ->
-       [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options ~path) type_decls))])
-    ~type_decl_sig: (fun ~options ~path type_decls ->
-       List.concat (List.map (sig_of_type ~options ~path) type_decls))
-    ()
-  ))
+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 intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) ->
+  List.concat (List.map sig_of_type type_decls))
+
+let deriving: Deriving.t =
+  Deriving.add
+    deriver
+    ~str_type_decl:impl_generator
+    ~sig_type_decl:intf_generator

src_plugins/enum/ppx_deriving_enum.cppo.ml

@@ -11,18 +11,15 @@ module Stdlib = Pervasives
 let deriver = "enum"
 let raise_errorf = Ppx_deriving.raise_errorf
 
-let parse_options options =
-  options |> List.iter (fun (name, expr) ->
-    match name with
-    | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name)
-
-let attr_value attrs =
-  Ppx_deriving.(attrs |> attr ~deriver "value" |> Arg.(get_attr ~deriver int))
+let attr_value context = Attribute.declare "deriving.enum.value" context
+  Ast_pattern.(single_expr_payload (eint __)) (fun i -> i)
+let constr_attr_value = attr_value Attribute.Context.constructor_declaration
+let rtag_attr_value = attr_value Attribute.Context.rtag
 
 let mappings_of_type type_decl =
-  let map acc mappings attrs constr_name =
+  let map acc mappings attr_value x constr_name =
     let value =
-      match attr_value attrs with
+      match Attribute.get attr_value x with
       | Some idx -> idx | None -> acc
     in
     (value + 1, (value, constr_name) :: mappings)
@@ -31,11 +28,11 @@ let mappings_of_type type_decl =
     match type_decl.ptype_kind, type_decl.ptype_manifest with
     | Ptype_variant constrs, _ ->
       `Regular,
-      List.fold_left (fun (acc, mappings) { pcd_name; pcd_args; pcd_attributes; pcd_loc } ->
+      List.fold_left (fun (acc, mappings) ({ pcd_name; pcd_args; pcd_attributes; pcd_loc } as constr) ->
           if pcd_args <> Pcstr_tuple([]) then
             raise_errorf ~loc:pcd_loc
                          "%s can be derived only for argumentless constructors" deriver;
-          map acc mappings pcd_attributes pcd_name)
+          map acc mappings constr_attr_value constr pcd_name)
         (0, []) constrs
     | Ptype_abstract, Some { ptyp_desc = Ptyp_variant (constrs, Closed, None); ptyp_loc } ->
       `Polymorphic,
@@ -51,11 +48,10 @@ let mappings_of_type type_decl =
                          deriver
           in
           let loc = row_field.prf_loc in
-          let attrs = row_field.prf_attributes in
           match row_field.prf_desc with
           | Rinherit _ -> error_inherit loc
           | Rtag (name, true, []) ->
-            map acc mappings attrs name
+            map acc mappings rtag_attr_value row_field name
           | Rtag _ -> error_arguments loc
 )
         (0, []) constrs
@@ -77,8 +73,7 @@ let mappings_of_type type_decl =
   mappings |> List.stable_sort (fun (a,_) (b,_) -> Stdlib.compare a b) |> check_dup;
   kind, mappings
 
-let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
-  parse_options options;
+let str_of_type ({ ptype_loc = loc } as type_decl) =
   let kind, mappings = mappings_of_type type_decl in
   let patt name =
     match kind with
@@ -106,9 +101,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
    Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Suffix "of_enum") type_decl))
          (Exp.function_ from_enum_cases)]
 
-let sig_of_type ~options ~path type_decl =
+let sig_of_type type_decl =
   let loc = type_decl.ptype_loc in
-  parse_options options;
   let typ = Ppx_deriving.core_type_of_type_decl type_decl in
   [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "min") type_decl))
              [%type: Ppx_deriving_runtime.int]);
@@ -119,11 +113,14 @@ let sig_of_type ~options ~path type_decl =
    Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "of_enum") type_decl))
              [%type: Ppx_deriving_runtime.int -> [%t typ] Ppx_deriving_runtime.option])]
 
-let () =
-  Ppx_deriving.(register (create deriver
-    ~type_decl_str: (fun ~options ~path type_decls ->
-       [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options ~path) type_decls))])
-    ~type_decl_sig: (fun ~options ~path type_decls ->
-       List.concat (List.map (sig_of_type ~options ~path) type_decls))
-    ()
-  ))
+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 intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) ->
+  List.concat (List.map sig_of_type type_decls))
+
+let deriving: Deriving.t =
+  Deriving.add
+    deriver
+    ~str_type_decl:impl_generator
+    ~sig_type_decl:intf_generator