Port standard plugins to ppxlib registration and attributes

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.32.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,34 @@ 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 attr_default = (attr_default Attribute.Context.label_declaration, attr_default Attribute.Context.core_type)
 
-let attr_default attrs =
-  Ppx_deriving.(attrs |> attr ~deriver "default" |> Arg.(get_attr ~deriver expr))
+let attr_split context = Attribute.declare_flag "deriving.create.split" context
+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_flag "deriving.create.main" context
+let ct_attr_main = attr_main Attribute.Context.core_type
+let label_attr_main = attr_main Attribute.Context.label_declaration
+
+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 Ppx_deriving.(pld_type.ptyp_attributes @ pld_attributes |>
-                     attr ~deriver "main" |> Arg.get_flag ~deriver) then
+    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 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 +50,13 @@ 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 get_label_attribute attr_default label with
         | Some default -> Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default))
                                    (pvar name) accum
         | None ->
-        if attr_split attrs then
+        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
@@ -78,8 +81,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 +94,12 @@ 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 get_label_attribute attr_default label with
         | Some _ -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum
         | None ->
-        if attr_split attrs then
+        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
@@ -118,11 +119,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

src_plugins/eq/ppx_deriving_eq.cppo.ml

@@ -7,16 +7,10 @@ open Ppx_deriving.Ast_convenience
 let deriver = "eq"
 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 ct_attr_nobuiltin = Attribute.declare_flag "deriving.eq.nobuiltin" Attribute.Context.core_type
 
-let attr_nobuiltin attrs =
-  Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver)
-
-let attr_equal attrs =
-  Ppx_deriving.(attrs |> attr ~deriver "equal" |> Arg.(get_attr ~deriver expr))
+let ct_attr_equal = Attribute.declare "deriving.eq.equal" Attribute.Context.core_type
+  Ast_pattern.(single_expr_payload __) (fun e -> e)
 
 let argn kind =
   Printf.sprintf (match kind with `lhs -> "lhs%d" | `rhs -> "rhs%d")
@@ -33,19 +27,17 @@ let pattl side labels =
 let pconstrrec name fields =
   pconstr name [precord ~closed:Closed fields]
 
-let core_type_of_decl ~options ~path type_decl =
+let core_type_of_decl type_decl =
   let loc = !Ast_helper.default_loc in
-  parse_options options;
   let typ = Ppx_deriving.core_type_of_type_decl type_decl in
   Ppx_deriving.poly_arrow_of_type_decl
     (fun var -> [%type: [%t var] -> [%t var] -> Ppx_deriving_runtime.bool])
     type_decl
     [%type: [%t typ] -> [%t typ] -> Ppx_deriving_runtime.bool]
 
-let sig_of_type ~options ~path type_decl =
-  parse_options options;
+let sig_of_type type_decl =
   [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "equal") type_decl))
-             (core_type_of_decl ~options ~path type_decl))]
+             (core_type_of_decl type_decl))]
 
 let rec exprn quoter typs =
   typs |> List.mapi (fun i typ ->
@@ -65,13 +57,13 @@ and expr_of_typ quoter typ =
   let loc = !Ast_helper.default_loc in
   let typ = Ppx_deriving.remove_pervasives ~deriver typ in
   let expr_of_typ = expr_of_typ quoter in
-  match attr_equal typ.ptyp_attributes with
+  match Attribute.get ct_attr_equal typ with
   | Some fn -> Ppx_deriving.quote ~quoter fn
   | None ->
     match typ with
     | [%type: _] -> [%expr fun _ _ -> true]
     | { ptyp_desc = Ptyp_constr _ } ->
-      let builtin = not (attr_nobuiltin typ.ptyp_attributes) in
+      let builtin = not (Attribute.has_flag ct_attr_nobuiltin typ) in
       begin match builtin, typ with
       | true, [%type: unit] ->
         [%expr fun (_:unit) (_:unit) -> true]
@@ -146,8 +138,7 @@ and expr_of_typ quoter typ =
       raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
                    deriver (Ppx_deriving.string_of_core_type typ)
 
-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 comparator =
     match type_decl.ptype_kind, type_decl.ptype_manifest with
@@ -196,19 +187,30 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
   in
   let out_type =
     Ppx_deriving.strong_type_of_type @@
-      core_type_of_decl  ~options ~path type_decl in
+      core_type_of_decl type_decl in
   let eq_var =
     pvar (Ppx_deriving.mangle_type_decl (`Prefix "equal") type_decl) in
   [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]]
          (Pat.constraint_ eq_var out_type)
          (Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator)))]
 
-let () =
-  Ppx_deriving.(register (create deriver
-    ~core_type: (Ppx_deriving.with_quoter expr_of_typ)
-    ~type_decl_str: (fun ~options ~path type_decls ->
-       [Str.value Recursive (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 Recursive (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
+
+(* custom extension such that "derive"-prefixed also works *)
+let derive_extension =
+  Extension.V3.declare "derive.eq" Extension.Context.expression
+    Ast_pattern.(ptyp __) (fun ~ctxt:_ -> Ppx_deriving.with_quoter expr_of_typ)
+let derive_transformation =
+  Driver.register_transformation
+    deriver
+    ~rules:[Context_free.Rule.extension derive_extension]