diff --git a/CHANGELOG.md b/CHANGELOG.md index a3d885e2..66379c1c 100644 --- a/CHANGELOG.md +++ b/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. diff --git a/ppx_deriving.opam b/ppx_deriving.opam index d56732ff..2c649cc1 100644 --- a/ppx_deriving.opam +++ b/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} ] diff --git a/src/api/ppx_deriving.cppo.ml b/src/api/ppx_deriving.cppo.ml index b212fc9e..63b0c056 100644 --- a/src/api/ppx_deriving.cppo.ml +++ b/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 diff --git a/src_plugins/create/ppx_deriving_create.cppo.ml b/src_plugins/create/ppx_deriving_create.cppo.ml index a62ee9dc..b8612887 100644 --- a/src_plugins/create/ppx_deriving_create.cppo.ml +++ b/src_plugins/create/ppx_deriving_create.cppo.ml @@ -7,21 +7,26 @@ 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 @@ -29,8 +34,7 @@ let find_main labels = 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 diff --git a/src_plugins/enum/ppx_deriving_enum.cppo.ml b/src_plugins/enum/ppx_deriving_enum.cppo.ml index 40d847ec..4be9ebdf 100644 --- a/src_plugins/enum/ppx_deriving_enum.cppo.ml +++ b/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 diff --git a/src_plugins/eq/ppx_deriving_eq.cppo.ml b/src_plugins/eq/ppx_deriving_eq.cppo.ml index 559bbf10..21f86643 100644 --- a/src_plugins/eq/ppx_deriving_eq.cppo.ml +++ b/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] diff --git a/src_plugins/fold/ppx_deriving_fold.cppo.ml b/src_plugins/fold/ppx_deriving_fold.cppo.ml index 65be6947..d161ffdd 100644 --- a/src_plugins/fold/ppx_deriving_fold.cppo.ml +++ b/src_plugins/fold/ppx_deriving_fold.cppo.ml @@ -7,13 +7,7 @@ open Ppx_deriving.Ast_convenience let deriver = "fold" 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_nobuiltin attrs = - Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) +let ct_attr_nobuiltin = Attribute.declare_flag "deriving.fold.nobuiltin" Attribute.Context.core_type let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" @@ -33,7 +27,7 @@ let rec expr_of_typ typ = match typ with | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun acc _ -> acc] | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> - 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: [%t? typ] ref] -> [%expr fun acc x -> [%e expr_of_typ typ] acc !x] | true, [%type: [%t? typ] list] -> @@ -89,8 +83,7 @@ and expr_of_label_decl { pld_type; pld_attributes } = let attrs = pld_type.ptyp_attributes @ pld_attributes in expr_of_typ { pld_type with ptyp_attributes = attrs } -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 mapper = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ manifest @@ -128,8 +121,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize mapper)] -let sig_of_type ~options ~path type_decl = - parse_options options; +let sig_of_type type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let vars = @@ -142,12 +134,23 @@ let sig_of_type ~options ~path type_decl = [Sig.value ~loc (Val.mk (mkloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl) loc) (polymorphize [%type: [%t acc] -> [%t typ] -> [%t acc]]))] -let () = - Ppx_deriving.(register (create deriver - ~core_type: 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.fold" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt:_ -> expr_of_typ) +let derive_transformation = + Driver.register_transformation + deriver + ~rules:[Context_free.Rule.extension derive_extension] diff --git a/src_plugins/iter/ppx_deriving_iter.cppo.ml b/src_plugins/iter/ppx_deriving_iter.cppo.ml index 340db0ae..2b075fe9 100644 --- a/src_plugins/iter/ppx_deriving_iter.cppo.ml +++ b/src_plugins/iter/ppx_deriving_iter.cppo.ml @@ -7,13 +7,7 @@ open Ppx_deriving.Ast_convenience let deriver = "iter" 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_nobuiltin attrs = - Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) +let ct_attr_nobuiltin = Attribute.declare_flag "deriving.iter.nobuiltin" Attribute.Context.core_type let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" @@ -29,7 +23,7 @@ let rec expr_of_typ typ = match typ with | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun _ -> ()] | { 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: [%t? typ] ref] -> [%expr fun x -> [%e expr_of_typ typ] !x] @@ -84,8 +78,7 @@ and expr_of_label_decl { pld_type; pld_attributes } = let attrs = pld_type.ptyp_attributes @ pld_attributes in expr_of_typ { pld_type with ptyp_attributes = attrs } -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 iterator = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ manifest @@ -125,21 +118,32 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize iterator)] -let sig_of_type ~options ~path type_decl = +let sig_of_type type_decl = let loc = !Ast_helper.default_loc in - parse_options options; let typ = Ppx_deriving.core_type_of_type_decl type_decl in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t var] -> Ppx_deriving_runtime.unit]) type_decl in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize [%type: [%t typ] -> Ppx_deriving_runtime.unit]))] -let () = - Ppx_deriving.(register (create deriver - ~core_type: 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.iter" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt:_ -> expr_of_typ) +let derive_transformation = + Driver.register_transformation + deriver + ~rules:[Context_free.Rule.extension derive_extension] diff --git a/src_plugins/make/ppx_deriving_make.cppo.ml b/src_plugins/make/ppx_deriving_make.cppo.ml index 907f906b..49947bc0 100644 --- a/src_plugins/make/ppx_deriving_make.cppo.ml +++ b/src_plugins/make/ppx_deriving_make.cppo.ml @@ -7,21 +7,26 @@ open Ppx_deriving.Ast_convenience let deriver = "make" 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.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_default attrs = - Ppx_deriving.(attrs |> attr ~deriver "default" |> Arg.(get_attr ~deriver expr)) +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 attr_split attrs = - Ppx_deriving.(attrs |> attr ~deriver "split" |> Arg.get_flag ~deriver) +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 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 @@ -30,19 +35,17 @@ let find_main labels = (None, []) labels -let is_optional { pld_name = { txt = name }; pld_type; pld_attributes } = - let attrs = pld_attributes @ pld_type.ptyp_attributes in - match attr_default attrs with +let is_optional ({ pld_name = { txt = name }; pld_type; pld_attributes } as label) = + match get_label_attribute attr_default label with | Some _ -> true | None -> - attr_split attrs || + Attribute.has_flag label_attr_split label || Attribute.has_flag ct_attr_split pld_type || (match Ppx_deriving.remove_pervasives ~deriver pld_type with | [%type: [%t? _] list] | [%type: [%t? _] option] -> true | _ -> false) -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 @@ -61,14 +64,13 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = | None -> 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 @@ -93,8 +95,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 @@ -108,13 +109,12 @@ let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = | 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 } -> - 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 @@ -134,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 diff --git a/src_plugins/map/ppx_deriving_map.cppo.ml b/src_plugins/map/ppx_deriving_map.cppo.ml index 41ac1f43..f4ec2c51 100644 --- a/src_plugins/map/ppx_deriving_map.cppo.ml +++ b/src_plugins/map/ppx_deriving_map.cppo.ml @@ -7,13 +7,7 @@ open Ppx_deriving.Ast_convenience let deriver = "map" 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_nobuiltin attrs = - Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) +let ct_attr_nobuiltin = Attribute.declare_flag "deriving.map.nobuiltin" Attribute.Context.core_type let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" @@ -30,7 +24,7 @@ let rec expr_of_typ ?decl typ = match typ with | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun x -> x] | { 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: [%t? typ] list] -> [%expr Ppx_deriving_runtime.List.map [%e expr_of_typ ?decl typ]] @@ -91,8 +85,7 @@ and expr_of_label_decl ?decl { pld_type; pld_attributes } = let attrs = pld_type.ptyp_attributes @ pld_attributes in expr_of_typ ?decl { pld_type with ptyp_attributes = attrs } -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 mapper = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ ~decl:type_decl manifest @@ -130,9 +123,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize mapper)] -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_arg, var_arg, bound = Ppx_deriving.instantiate [] type_decl in let typ_ret, var_ret, _ = Ppx_deriving.instantiate bound type_decl in let arrow = Typ.arrow Label.nolabel in @@ -141,12 +133,23 @@ let sig_of_type ~options ~path type_decl = let typ = List.fold_right arrow poly_fns (arrow typ_arg typ_ret) in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) typ)] -let () = - Ppx_deriving.(register (create deriver - ~core_type: (expr_of_typ ?decl:None) - ~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.map" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt:_ -> expr_of_typ ?decl:None) +let derive_transformation = + Driver.register_transformation + deriver + ~rules:[Context_free.Rule.extension derive_extension] diff --git a/src_plugins/ord/ppx_deriving_ord.cppo.ml b/src_plugins/ord/ppx_deriving_ord.cppo.ml index c36d57d6..872377e7 100644 --- a/src_plugins/ord/ppx_deriving_ord.cppo.ml +++ b/src_plugins/ord/ppx_deriving_ord.cppo.ml @@ -8,16 +8,10 @@ open Ppx_deriving.Ast_convenience let deriver = "ord" 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.ord.nobuiltin" Attribute.Context.core_type -let attr_nobuiltin attrs = - Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) - -let attr_compare attrs = - Ppx_deriving.(attrs |> attr ~deriver "compare" |> Arg.(get_attr ~deriver expr)) +let ct_attr_compare = Attribute.declare "deriving.ord.compare" 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") @@ -66,14 +60,14 @@ and expr_of_label_decl quoter { pld_type; pld_attributes } = and expr_of_typ quoter typ = let loc = typ.ptyp_loc in let expr_of_typ = expr_of_typ quoter in - match attr_compare typ.ptyp_attributes with + match Attribute.get ct_attr_compare typ with | Some fn -> Ppx_deriving.quote ~quoter fn | None -> let typ = Ppx_deriving.remove_pervasives ~deriver typ in match typ with | [%type: _] -> [%expr fun _ _ -> 0] | { 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: _] -> [%expr fun _ _ -> 0] @@ -170,20 +164,18 @@ 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 core_type_of_decl ~options ~path type_decl = - parse_options options; +let core_type_of_decl type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t var] -> [%t var] -> Ppx_deriving_runtime.int]) type_decl in (polymorphize [%type: [%t typ] -> [%t typ] -> Ppx_deriving_runtime.int]) -let sig_of_type ~options ~path type_decl = +let sig_of_type type_decl = [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl)) - (core_type_of_decl ~options ~path type_decl))] + (core_type_of_decl type_decl))] -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 @@ -232,19 +224,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 out_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl) in [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]] (Pat.constraint_ out_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.ord" 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] diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml index 7b0f5742..7492081f 100644 --- a/src_plugins/show/ppx_deriving_show.cppo.ml +++ b/src_plugins/show/ppx_deriving_show.cppo.ml @@ -7,37 +7,27 @@ open Ppx_deriving.Ast_convenience let deriver = "show" let raise_errorf = Ppx_deriving.raise_errorf -type options = { with_path : bool } - (* The option [with_path] controls whether a full path should be displayed as part of data constructor names and record field names. (In the case of record fields, it is displayed only as part of the name of the first field.) By default, this option is [true], which means that full paths are shown. *) -let expand_path show_opts ~path name = - let path = if show_opts.with_path then path else [] in +let expand_path ~with_path ~path name = + let path = if with_path then path else [] in Ppx_deriving.expand_path ~path name -let parse_options options = - let with_path = ref true in - options |> List.iter (fun (name, expr) -> - match name with - | "with_path" -> with_path := Ppx_deriving.Arg.(get_expr ~deriver bool) expr - | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name); - { with_path = !with_path } - -let attr_nobuiltin attrs = - Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) +let ct_attr_nobuiltin = Attribute.declare_flag "deriving.show.nobuiltin" Attribute.Context.core_type -let attr_printer attrs = - Ppx_deriving.(attrs |> attr ~deriver "printer" |> Arg.(get_attr ~deriver expr)) +let attr_printer context = Attribute.declare "deriving.show.printer" context + Ast_pattern.(single_expr_payload __) (fun e -> e) +let ct_attr_printer = attr_printer Attribute.Context.core_type +let constr_attr_printer = attr_printer Attribute.Context.constructor_declaration -let attr_polyprinter attrs = - Ppx_deriving.(attrs |> attr ~deriver "polyprinter" |> Arg.(get_attr ~deriver expr)) +let ct_attr_polyprinter = Attribute.declare "deriving.show.polyprinter" Attribute.Context.core_type + Ast_pattern.(single_expr_payload __) (fun e -> e) -let attr_opaque attrs = - Ppx_deriving.(attrs |> attr ~deriver "opaque" |> Arg.get_flag ~deriver) +let ct_attr_opaque = Attribute.declare_flag "deriving.show.opaque" Attribute.Context.core_type let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" @@ -52,38 +42,35 @@ let wrap_printer quoter printer = Ppx_deriving.quote ~quoter [%expr (let fprintf = Ppx_deriving_runtime.Format.fprintf in [%e printer]) [@ocaml.warning "-26"]] -let pp_type_of_decl ~options ~path type_decl = +let pp_type_of_decl type_decl = let loc = type_decl.ptype_loc in - let _ = parse_options options in let typ = Ppx_deriving.core_type_of_type_decl type_decl in Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Ppx_deriving_runtime.Format.formatter -> [%t var] -> Ppx_deriving_runtime.unit]) type_decl [%type: Ppx_deriving_runtime.Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit] -let show_type_of_decl ~options ~path type_decl = +let show_type_of_decl type_decl = let loc = type_decl.ptype_loc in - let _ = parse_options options in let typ = Ppx_deriving.core_type_of_type_decl type_decl in Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Ppx_deriving_runtime.Format.formatter -> [%t var] -> Ppx_deriving_runtime.unit]) type_decl [%type: [%t typ] -> Ppx_deriving_runtime.string] -let sig_of_type ~options ~path type_decl = - let _ = parse_options options in +let sig_of_type type_decl = [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl)) - (pp_type_of_decl ~options ~path type_decl)); + (pp_type_of_decl type_decl)); Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl)) - (show_type_of_decl ~options ~path type_decl))] + (show_type_of_decl type_decl))] let rec expr_of_typ quoter typ = let loc = typ.ptyp_loc in let expr_of_typ = expr_of_typ quoter in - match attr_printer typ.ptyp_attributes with + match Attribute.get ct_attr_printer typ with | Some printer -> [%expr [%e wrap_printer quoter printer] fmt] | None -> - if attr_opaque typ.ptyp_attributes then + if Attribute.has_flag ct_attr_opaque typ then [%expr fun _ -> Ppx_deriving_runtime.Format.pp_print_string fmt ""] else let format x = [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str x]] in @@ -101,7 +88,7 @@ let rec expr_of_typ quoter typ = | { ptyp_desc = Ptyp_arrow _ } -> [%expr fun _ -> Ppx_deriving_runtime.Format.pp_print_string fmt ""] | { 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 () -> Ppx_deriving_runtime.Format.pp_print_string fmt "()"] | true, [%type: int] -> format "%d" @@ -153,7 +140,7 @@ let rec expr_of_typ quoter typ = | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> let args_pp = List.map (fun typ -> [%expr fun fmt -> [%e expr_of_typ typ]]) args in let printer = - match attr_polyprinter typ.ptyp_attributes with + match Attribute.get ct_attr_polyprinter typ with | Some printer -> wrap_printer quoter printer | None -> let printer = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix "pp") lid)) in @@ -202,8 +189,7 @@ and expr_of_label_decl quoter { pld_type; pld_attributes } = let attrs = pld_type.ptyp_attributes @ pld_attributes in expr_of_typ quoter { pld_type with ptyp_attributes = attrs } -let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = - let show_opts = parse_options options in +let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = let quoter = Ppx_deriving.create_quoter () in let path = Ppx_deriving.path_of_type_decl ~path type_decl in let prettyprinter = @@ -212,12 +198,12 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = [%expr fun fmt -> [%e expr_of_typ quoter manifest]] | Ptype_variant constrs, _ -> let cases = - constrs |> List.map (fun { pcd_name = { txt = name' }; pcd_args; pcd_attributes } -> + constrs |> List.map (fun ({ pcd_name = { txt = name' }; pcd_args; pcd_attributes } as constr) -> let constr_name = - expand_path show_opts ~path name' + expand_path ~with_path ~path name' in - match attr_printer pcd_attributes, pcd_args with + match Attribute.get constr_attr_printer constr, pcd_args with | Some printer, Pcstr_tuple(args) -> let rec range from_idx to_idx = if from_idx = to_idx @@ -281,7 +267,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = | Ptype_record labels, _ -> let fields = labels |> List.mapi (fun i ({ pld_name = { txt = name }; _} as pld) -> - let field_name = if i = 0 then expand_path show_opts ~path name else name in + let field_name = if i = 0 then expand_path ~with_path ~path name else name in [%expr Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str field_name]; [%e expr_of_label_decl quoter pld] @@ -304,10 +290,10 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = let stringprinter = [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" [%e pp_poly_apply] x] in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in let pp_type = - Ppx_deriving.strong_type_of_type @@ pp_type_of_decl ~options ~path type_decl in + Ppx_deriving.strong_type_of_type @@ pp_type_of_decl type_decl in let show_type = Ppx_deriving.strong_type_of_type @@ - show_type_of_decl ~options ~path type_decl in + show_type_of_decl type_decl in let pp_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl) in let show_var = @@ -317,14 +303,50 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = (Ppx_deriving.sanitize ~quoter (polymorphize prettyprinter)); Vb.mk ~attrs:[no_warn_32] (Pat.constraint_ show_var show_type) (polymorphize stringprinter);] -let () = - let loc = !Ast_helper.default_loc in - Ppx_deriving.(register (create deriver - ~core_type: (Ppx_deriving.with_quoter (fun quoter typ -> - [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" (fun fmt -> [%e expr_of_typ quoter typ]) x])) - ~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 args = Deriving.Args.(empty +> arg "with_path" (Ast_pattern.ebool __)) +(* TODO: add arg_default to ppxlib? *) + +let impl_generator = Deriving.Generator.V2.make args (fun ~ctxt (_, type_decls) with_path -> + let path = + let code_path = Expansion_context.Deriver.code_path ctxt in + (* Cannot use main_module_name from code_path because that contains .cppo suffix (via line directives), so it's actually not the module name. *) + (* Ppx_deriving.module_from_input_name ported to ppxlib. *) + let main_module_path = match Expansion_context.Deriver.input_name ctxt with + | "" + | "_none_" -> [] + | input_name -> + match Filename.chop_suffix input_name ".ml" with + | exception _ -> + (* see https://github.com/ocaml-ppx/ppx_deriving/pull/196 *) + [] + | path -> + [String.capitalize_ascii (Filename.basename path)] + in + main_module_path @ Code_path.submodule_path code_path + in + let with_path = match with_path with + | Some with_path -> with_path + | None -> true (* true by default *) + in + [Str.value Recursive (List.concat (List.map (str_of_type ~with_path ~path) 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.show" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + Ppx_deriving.with_quoter (fun quoter typ -> + [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" (fun fmt -> [%e expr_of_typ quoter typ]) x])) +let derive_transformation = + Driver.register_transformation + deriver + ~rules:[Context_free.Rule.extension derive_extension] diff --git a/src_test/deriving/test_ppx_deriving.ml b/src_test/deriving/test_ppx_deriving.ml index 5e2125c5..fb6831ec 100644 --- a/src_test/deriving/test_ppx_deriving.ml +++ b/src_test/deriving/test_ppx_deriving.ml @@ -9,8 +9,9 @@ let test_inline_shorthand ctxt = assert_equal ~printer:(fun x -> x) "[(1, 1); (2, 0)]" ([%show: (int * int) list] [(1,1); (2,0)]) -type optional_deriver = string -[@@deriving missing { optional = true }] +(* TODO: optional is incompatible with ppxlib derivers: https://github.com/ocaml-ppx/ppx_deriving/issues/247 *) +(* type optional_deriver = string +[@@deriving missing { optional = true }] *) type prefix = { field : int [@deriving.eq.compare fun _ _ -> true]