From 3668ffefc89aec1938e87e524f5da3cce0b68d60 Mon Sep 17 00:00:00 2001 From: Keigo Imai Date: Wed, 16 Oct 2024 19:02:02 +0900 Subject: [PATCH 1/5] show: GADT support --- src/api/ppx_deriving.cppo.ml | 40 +++++++++++ src/api/ppx_deriving.cppo.mli | 14 ++++ src_examples/dune | 8 ++- src_examples/print_gadt_test.ml | 21 ++++++ src_plugins/show/ppx_deriving_show.ml | 96 ++++++++++++++++++++++----- 5 files changed, 161 insertions(+), 18 deletions(-) create mode 100644 src_examples/print_gadt_test.ml diff --git a/src/api/ppx_deriving.cppo.ml b/src/api/ppx_deriving.cppo.ml index b14785b3..163f9392 100644 --- a/src/api/ppx_deriving.cppo.ml +++ b/src/api/ppx_deriving.cppo.ml @@ -491,6 +491,9 @@ let fresh_var bound = in loop 0 +let type_param_names_of_type_decl type_decl = + fold_right_type_decl (fun name tail -> name.txt :: tail) type_decl [] + let poly_fun_of_type_decl type_decl expr = fold_right_type_decl (fun name expr -> let name = name.txt in @@ -516,6 +519,15 @@ let poly_arrow_of_type_decl fn type_decl typ = let name = name.txt in Typ.arrow Label.nolabel (fn (Typ.var name)) typ) type_decl typ +let poly_arrow_of_type_decl_idx fn type_decl typ = + let len = List.length type_decl.ptype_params in + fold_right_type_decl (fun name (idx, typ) -> + let name = name.txt in + (idx + 1, Typ.arrow Label.nolabel (fn (len - idx - 1) (Typ.var name)) typ)) + type_decl + (0, typ) + |> snd + let poly_arrow_of_type_ext fn type_ext typ = fold_right_type_ext (fun name typ -> let var = @@ -530,6 +542,34 @@ let core_type_of_type_decl { ptype_name = name; ptype_params } = let core_type_of_type_ext { ptyext_path ; ptyext_params } = Typ.constr ptyext_path (List.map fst ptyext_params) +let newtype_of_type_decl type_decl expr = + fold_right_type_decl (fun name expr -> + let name = name.txt in + Exp.newtype (str_of_string name) expr) type_decl expr + +let newtype_arrow_of_type_decl fn type_decl typ = + let len = List.length type_decl.ptype_params in + fold_right_type_decl (fun name (idx,typ) -> + let name = name.txt in + (idx + 1, Typ.arrow Label.nolabel (fn (len - idx - 1) (Typ.constr (lid_of_string name) [])) typ)) + type_decl + (0, typ) + |> snd + +let core_type_of_type_decl_with_newtype { ptype_name = name; ptype_params } = + let name = mkloc (Lident name.txt) name.loc in + let newtype_params = + ptype_params |> + List.map (function + | ({ ptyp_desc = Ptyp_var varname } as param, _) -> + let varname = mkloc (Longident.parse varname) param.ptyp_loc in + Typ.constr varname [] + | ({ ptyp_desc = Ptyp_any} as anytyp, _) -> + anytyp + | _ -> raise (Invalid_argument "Ppx_deriving.core_type_of_type_decl_with_newtype")) + in + Typ.constr name newtype_params + let instantiate bound type_decl = let vars, bound = List.fold_right diff --git a/src/api/ppx_deriving.cppo.mli b/src/api/ppx_deriving.cppo.mli index d6925fd8..eb77dce8 100644 --- a/src/api/ppx_deriving.cppo.mli +++ b/src/api/ppx_deriving.cppo.mli @@ -263,6 +263,8 @@ val fold_left_type_ext : ('a -> tyvar -> 'a) -> 'a -> type_extension -> 'a wildcard) parameters in [type_]. *) val fold_right_type_ext : (tyvar -> 'a -> 'a) -> type_extension -> 'a -> 'a +val type_param_names_of_type_decl : type_declaration -> string list + (** [poly_fun_of_type_decl type_ expr] wraps [expr] into [fun poly_N -> ...] for every type parameter ['N] present in [type_]. For example, if [type_] refers to [type ('a, 'b) map], [expr] will be wrapped into [fun poly_a poly_b -> [%e expr]]. @@ -292,6 +294,9 @@ val poly_apply_of_type_ext : type_extension -> expression -> expression val poly_arrow_of_type_decl : (core_type -> core_type) -> type_declaration -> core_type -> core_type +val poly_arrow_of_type_decl_idx : (int -> core_type -> core_type) -> + type_declaration -> core_type -> core_type + (** Same as {!poly_arrow_of_type_decl} but for type extension. *) val poly_arrow_of_type_ext : (core_type -> core_type) -> type_extension -> core_type -> core_type @@ -303,6 +308,15 @@ val core_type_of_type_decl : type_declaration -> core_type (** Same as {!core_type_of_type_decl} but for type extension. *) val core_type_of_type_ext : type_extension -> core_type +val newtype_of_type_decl : type_declaration -> expression -> expression + +val newtype_arrow_of_type_decl : (int -> core_type -> core_type) -> + type_declaration -> core_type -> core_type + +(** [core_type_of_type_decl_with_newtype type_] constructs type [('a, 'b, ...) t] for + type declaration [type (a, b, ...) t = ...]. *) + val core_type_of_type_decl_with_newtype : type_declaration -> core_type + (** [instantiate bound type_] returns [typ, vars, bound'] where [typ] is a type instantiated from type declaration [type_], [vars] ≡ [free_vars_in_core_type typ] and [bound'] ≡ [bound @ vars]. *) diff --git a/src_examples/dune b/src_examples/dune index f6e5ad62..284dc72d 100644 --- a/src_examples/dune +++ b/src_examples/dune @@ -1,7 +1,13 @@ (executable (name print_test) + (modules print_test) + (preprocess (pps ppx_deriving.show))) + +(executable + (name print_gadt_test) + (modules print_gadt_test) (preprocess (pps ppx_deriving.show))) (alias (name examples) - (deps print_test.exe)) + (deps print_test.exe print_gadt_test.exe)) diff --git a/src_examples/print_gadt_test.ml b/src_examples/print_gadt_test.ml new file mode 100644 index 00000000..f8be229b --- /dev/null +++ b/src_examples/print_gadt_test.ml @@ -0,0 +1,21 @@ +type 'a expr = + | Int : int -> int expr + | Bool : bool -> bool expr + | Pair : 'x expr * 'y expr -> ('x * 'y) expr +[@@deriving show] + +let test_case = + Pair (Pair (Int 10, Bool true), Pair (Int 42, Int 42)) + +let () = + Format.printf "expr: %a@." (pp_expr (fun _ _ -> ())) test_case; + () + +(* +tree: (Print_gadt_test.Pair ( + (Print_gadt_test.Pair ((Print_gadt_test.Int 10), + (Print_gadt_test.Bool true))), + (Print_gadt_test.Pair ((Print_gadt_test.Int 42), + (Print_gadt_test.Int 42))) + )) +*) diff --git a/src_plugins/show/ppx_deriving_show.ml b/src_plugins/show/ppx_deriving_show.ml index f1bf5b02..42f409ce 100644 --- a/src_plugins/show/ppx_deriving_show.ml +++ b/src_plugins/show/ppx_deriving_show.ml @@ -42,19 +42,42 @@ 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 type_decl = +let fresh_type_maker type_decl = + let bound = ref (Ppx_deriving.type_param_names_of_type_decl type_decl) in + fun () -> + let newvar = Ppx_deriving.fresh_var !bound in + bound := newvar :: !bound; + Typ.var newvar + +let pp_type_of_decl ?(unusable_param_pos=[]) type_decl = let loc = type_decl.ptype_loc 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]) + let fresh_type = fresh_type_maker type_decl in + Ppx_deriving.poly_arrow_of_type_decl_idx + (fun pos var -> + let var_or_any = if List.mem pos unusable_param_pos then fresh_type () else var in + [%type: Ppx_deriving_runtime.Format.formatter -> [%t var_or_any ] -> Ppx_deriving_runtime.unit]) + type_decl + [%type: Ppx_deriving_runtime.Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit] + +let pp_type_of_decl_newtype ?(unusable_param_pos=[]) type_decl = + let loc = type_decl.ptype_loc in + let typ = Ppx_deriving.core_type_of_type_decl_with_newtype type_decl in + Ppx_deriving.newtype_arrow_of_type_decl + (fun pos lty -> + let lty_or_any = if List.mem pos unusable_param_pos then Typ.any () else lty in + [%type: Ppx_deriving_runtime.Format.formatter -> [%t lty_or_any] -> Ppx_deriving_runtime.unit]) type_decl [%type: Ppx_deriving_runtime.Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit] -let show_type_of_decl type_decl = +let show_type_of_decl ?(unusable_param_pos=[]) type_decl = let loc = type_decl.ptype_loc 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]) + let fresh_type = fresh_type_maker type_decl in + Ppx_deriving.poly_arrow_of_type_decl_idx + (fun pos var -> + let var_or_any = if List.mem pos unusable_param_pos then fresh_type () else var in + [%type: Ppx_deriving_runtime.Format.formatter -> [%t var_or_any] -> Ppx_deriving_runtime.unit]) type_decl [%type: [%t typ] -> Ppx_deriving_runtime.string] @@ -64,9 +87,9 @@ let sig_of_type type_decl = Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl)) (show_type_of_decl type_decl))] -let rec expr_of_typ quoter typ = +let rec expr_of_typ ~effective_variables quoter typ = let loc = typ.ptyp_loc in - let expr_of_typ = expr_of_typ quoter in + let expr_of_typ = expr_of_typ ~effective_variables quoter in match Attribute.get ct_attr_printer typ with | Some printer -> [%expr [%e wrap_printer quoter printer] fmt] | None -> @@ -179,7 +202,11 @@ let rec expr_of_typ quoter typ = deriver (Ppx_deriving.string_of_core_type typ)) in Exp.function_ cases - | { ptyp_desc = Ptyp_var name } -> [%expr [%e evar ("poly_"^name)] fmt] + | { ptyp_desc = Ptyp_var name } -> + if List.mem name effective_variables then + [%expr [%e evar ("poly_"^name)] fmt] + else + [%expr (fun ()(*never type here*) -> failwith "impossible")] | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" @@ -189,13 +216,39 @@ 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 is_gadt type_decl = + match type_decl.ptype_kind with + | Ptype_variant constrs -> + constrs |> List.exists @@ fun constr -> + begin match constr.pcd_res with None -> false | Some _ -> true end + | _ -> false + +let refined_param_pos_of_type_decl type_decl = + let constrs = + match type_decl.ptype_kind with + | Ptype_variant constrs -> constrs + | _ -> [] + in + let type_variables = Ppx_deriving.type_param_names_of_type_decl type_decl in + constrs |> List.fold_left (fun acc -> function + | {pcd_res = Some {ptyp_desc=Ptyp_constr(_, args); _} } -> + let args = args |> List.mapi (fun idx x -> (idx,x)) in + let refined_idxs = args |> List.filter_map (function + | (_idx, {ptyp_desc=Ptyp_var var}) when List.mem var type_variables -> (*not refined*)None + | (idx, _) -> (*refined*)Some idx) + in + refined_idxs @ acc + | _ -> acc) [] + + 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 type_variables = Ppx_deriving.type_param_names_of_type_decl type_decl in let prettyprinter = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> - [%expr fun fmt -> [%e expr_of_typ quoter manifest]] + [%expr fun fmt -> [%e expr_of_typ ~effective_variables:type_variables quoter manifest]] | Ptype_variant constrs, _ -> let cases = constrs |> List.map (fun ({ pcd_name = { txt = name' }; pcd_args; pcd_attributes } as constr) -> @@ -226,7 +279,7 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = (app (wrap_printer quoter printer) ([%expr fmt] :: args)) | None, Pcstr_tuple(typs) -> let args = - List.mapi (fun i typ -> app (expr_of_typ quoter typ) [evar (argn i)]) typs in + List.mapi (fun i typ -> app (expr_of_typ ~effective_variables:type_variables quoter typ) [evar (argn i)]) typs in let printer = match args with | [] -> [%expr Ppx_deriving_runtime.Format.pp_print_string fmt [%e str constr_name]] @@ -248,7 +301,7 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) -> [%expr Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str n]; - [%e expr_of_label_decl quoter pld] + [%e expr_of_label_decl ~effective_variables:type_variables quoter pld] [%e evar (argl n)]; Ppx_deriving_runtime.Format.fprintf fmt "@]" ]) @@ -270,7 +323,7 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = 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] + [%e expr_of_label_decl ~effective_variables:type_variables quoter pld] [%e Exp.field (evar "x") (mknoloc (Lident name))]; Ppx_deriving_runtime.Format.fprintf fmt "@]" ]) @@ -289,18 +342,27 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl)) in 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 unusable_param_pos = refined_param_pos_of_type_decl type_decl in + let prettyprinter = polymorphize prettyprinter in + let prettyprinter = + if is_gadt type_decl then + Ppx_deriving.newtype_of_type_decl type_decl + @@ Exp.constraint_ prettyprinter (pp_type_of_decl_newtype ~unusable_param_pos type_decl) + else + prettyprinter + in let pp_type = - Ppx_deriving.strong_type_of_type @@ pp_type_of_decl type_decl in + Ppx_deriving.strong_type_of_type @@ pp_type_of_decl ~unusable_param_pos type_decl in let show_type = Ppx_deriving.strong_type_of_type @@ - show_type_of_decl type_decl in + show_type_of_decl ~unusable_param_pos type_decl in let pp_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl) in let show_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl) in let no_warn_32 = Ppx_deriving.attr_warning [%expr "-32"] in [Vb.mk (Pat.constraint_ pp_var pp_type) - (Ppx_deriving.sanitize ~quoter (polymorphize prettyprinter)); + (Ppx_deriving.sanitize ~quoter prettyprinter); Vb.mk ~attrs:[no_warn_32] (Pat.constraint_ show_var show_type) (polymorphize stringprinter);] let impl_args = Deriving.Args.(empty +> arg "with_path" (Ast_pattern.ebool __)) @@ -347,7 +409,7 @@ let derive_extension = 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])) + [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" (fun fmt -> [%e expr_of_typ ~effective_variables:[] quoter typ]) x])) let derive_transformation = Driver.register_transformation deriver From 95538056bef4b6bd1d81d0047e835f301f816402 Mon Sep 17 00:00:00 2001 From: Keigo Imai Date: Wed, 16 Oct 2024 22:35:21 +0900 Subject: [PATCH 2/5] better docs and names --- src/api/ppx_deriving.cppo.ml | 22 +++++----- src/api/ppx_deriving.cppo.mli | 23 +++++++--- src_plugins/show/ppx_deriving_show.ml | 63 +++++++++++++++++++-------- 3 files changed, 72 insertions(+), 36 deletions(-) diff --git a/src/api/ppx_deriving.cppo.ml b/src/api/ppx_deriving.cppo.ml index 163f9392..16e0e1de 100644 --- a/src/api/ppx_deriving.cppo.ml +++ b/src/api/ppx_deriving.cppo.ml @@ -519,13 +519,22 @@ let poly_arrow_of_type_decl fn type_decl typ = let name = name.txt in Typ.arrow Label.nolabel (fn (Typ.var name)) typ) type_decl typ +let newtype_arrow_of_type_decl fn type_decl typ = + let len = List.length type_decl.ptype_params in + fold_right_type_decl (fun name (idx,typ) -> + let name = name.txt in + (idx + 1, Typ.arrow Label.nolabel (fn (len - idx - 1) (Typ.constr (lid_of_string name) [])) typ)) + type_decl + (0, typ) + |> snd + let poly_arrow_of_type_decl_idx fn type_decl typ = let len = List.length type_decl.ptype_params in fold_right_type_decl (fun name (idx, typ) -> let name = name.txt in - (idx + 1, Typ.arrow Label.nolabel (fn (len - idx - 1) (Typ.var name)) typ)) + (idx - 1, Typ.arrow Label.nolabel (fn idx (Typ.var name)) typ)) type_decl - (0, typ) + (len - 1, typ) |> snd let poly_arrow_of_type_ext fn type_ext typ = @@ -546,15 +555,6 @@ let newtype_of_type_decl type_decl expr = fold_right_type_decl (fun name expr -> let name = name.txt in Exp.newtype (str_of_string name) expr) type_decl expr - -let newtype_arrow_of_type_decl fn type_decl typ = - let len = List.length type_decl.ptype_params in - fold_right_type_decl (fun name (idx,typ) -> - let name = name.txt in - (idx + 1, Typ.arrow Label.nolabel (fn (len - idx - 1) (Typ.constr (lid_of_string name) [])) typ)) - type_decl - (0, typ) - |> snd let core_type_of_type_decl_with_newtype { ptype_name = name; ptype_params } = let name = mkloc (Lident name.txt) name.loc in diff --git a/src/api/ppx_deriving.cppo.mli b/src/api/ppx_deriving.cppo.mli index eb77dce8..4960fc27 100644 --- a/src/api/ppx_deriving.cppo.mli +++ b/src/api/ppx_deriving.cppo.mli @@ -275,6 +275,13 @@ val poly_fun_of_type_decl : type_declaration -> expression -> expression (** Same as {!poly_fun_of_type_decl} but for type extension. *) val poly_fun_of_type_ext : type_extension -> expression -> expression +(** [newtype_of_type_decl type_ expr] wraps [expr] into [fun (type N) -> expr] for every + type parameter ['N] present in [type_]. For example, if [type_] refers to + [type ('a, 'b) map], [expr] will be wrapped into [fun (type a) (type b) -> [%e expr]]. + + [_] parameters are ignored. *) +val newtype_of_type_decl : type_declaration -> expression -> expression + (** [poly_apply_of_type_decl type_ expr] wraps [expr] into [expr poly_N] for every type parameter ['N] present in [type_]. For example, if [type_] refers to [type ('a, 'b) map], [expr] will be wrapped into [[%e expr] poly_a poly_b]. @@ -294,9 +301,18 @@ val poly_apply_of_type_ext : type_extension -> expression -> expression val poly_arrow_of_type_decl : (core_type -> core_type) -> type_declaration -> core_type -> core_type +(** Same as {!poly_arrow_of_type_decl} but with indices for type parameters. *) val poly_arrow_of_type_decl_idx : (int -> core_type -> core_type) -> type_declaration -> core_type -> core_type +(** Same as {!poly_arrow_of_type_decl} but supplies locally abstract types instead of + type variables. For example, [type ('a, 'b) map] and function + [fun var -> [%type: [%t var] -> string]] wraps [typ] into + [(a -> string) -> (b -> string) -> [%t typ]] (where [type a] and [type b] comes from + type parameter names [type 'a] and [type 'b]). *) +val newtype_arrow_of_type_decl : (int -> core_type -> core_type) -> + type_declaration -> core_type -> core_type + (** Same as {!poly_arrow_of_type_decl} but for type extension. *) val poly_arrow_of_type_ext : (core_type -> core_type) -> type_extension -> core_type -> core_type @@ -308,14 +324,9 @@ val core_type_of_type_decl : type_declaration -> core_type (** Same as {!core_type_of_type_decl} but for type extension. *) val core_type_of_type_ext : type_extension -> core_type -val newtype_of_type_decl : type_declaration -> expression -> expression - -val newtype_arrow_of_type_decl : (int -> core_type -> core_type) -> - type_declaration -> core_type -> core_type - (** [core_type_of_type_decl_with_newtype type_] constructs type [('a, 'b, ...) t] for type declaration [type (a, b, ...) t = ...]. *) - val core_type_of_type_decl_with_newtype : type_declaration -> core_type +val core_type_of_type_decl_with_newtype : type_declaration -> core_type (** [instantiate bound type_] returns [typ, vars, bound'] where [typ] is a type instantiated from type declaration [type_], [vars] ≡ [free_vars_in_core_type typ] diff --git a/src_plugins/show/ppx_deriving_show.ml b/src_plugins/show/ppx_deriving_show.ml index 42f409ce..8588b6bd 100644 --- a/src_plugins/show/ppx_deriving_show.ml +++ b/src_plugins/show/ppx_deriving_show.ml @@ -49,34 +49,34 @@ let fresh_type_maker type_decl = bound := newvar :: !bound; Typ.var newvar -let pp_type_of_decl ?(unusable_param_pos=[]) type_decl = +let pp_type_of_decl ?(refined_param_pos=[]) type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let fresh_type = fresh_type_maker type_decl in Ppx_deriving.poly_arrow_of_type_decl_idx (fun pos var -> - let var_or_any = if List.mem pos unusable_param_pos then fresh_type () else var in + let var_or_any = if List.mem pos refined_param_pos then fresh_type () else var in [%type: Ppx_deriving_runtime.Format.formatter -> [%t var_or_any ] -> Ppx_deriving_runtime.unit]) type_decl [%type: Ppx_deriving_runtime.Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit] -let pp_type_of_decl_newtype ?(unusable_param_pos=[]) type_decl = +let pp_type_of_decl_newtype ?(refined_param_pos=[]) type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl_with_newtype type_decl in Ppx_deriving.newtype_arrow_of_type_decl (fun pos lty -> - let lty_or_any = if List.mem pos unusable_param_pos then Typ.any () else lty in + let lty_or_any = if List.mem pos refined_param_pos then Typ.any () else lty in [%type: Ppx_deriving_runtime.Format.formatter -> [%t lty_or_any] -> Ppx_deriving_runtime.unit]) type_decl [%type: Ppx_deriving_runtime.Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit] -let show_type_of_decl ?(unusable_param_pos=[]) type_decl = +let show_type_of_decl ?(refined_param_pos=[]) type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let fresh_type = fresh_type_maker type_decl in Ppx_deriving.poly_arrow_of_type_decl_idx (fun pos var -> - let var_or_any = if List.mem pos unusable_param_pos then fresh_type () else var in + let var_or_any = if List.mem pos refined_param_pos then fresh_type () else var in [%type: Ppx_deriving_runtime.Format.formatter -> [%t var_or_any] -> Ppx_deriving_runtime.unit]) type_decl [%type: [%t typ] -> Ppx_deriving_runtime.string] @@ -206,6 +206,9 @@ let rec expr_of_typ ~effective_variables quoter typ = if List.mem name effective_variables then [%expr [%e evar ("poly_"^name)] fmt] else + (* We assume some 'calling convention' here: for type variables not appear in the declaration, + we supply a 'degenerate' pretty printer which is never called, as we deem them 'refined' to + a concrete type at some point. *) [%expr (fun ()(*never type here*) -> failwith "impossible")] | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> @@ -230,15 +233,37 @@ let refined_param_pos_of_type_decl type_decl = | _ -> [] in let type_variables = Ppx_deriving.type_param_names_of_type_decl type_decl in - constrs |> List.fold_left (fun acc -> function - | {pcd_res = Some {ptyp_desc=Ptyp_constr(_, args); _} } -> - let args = args |> List.mapi (fun idx x -> (idx,x)) in - let refined_idxs = args |> List.filter_map (function - | (_idx, {ptyp_desc=Ptyp_var var}) when List.mem var type_variables -> (*not refined*)None - | (idx, _) -> (*refined*)Some idx) - in - refined_idxs @ acc - | _ -> acc) [] + constrs |> List.filter_map (function + | {pcd_res = Some {ptyp_desc=Ptyp_constr(_, args); _} } -> (* constructor has the return type (pcd_res) *) + let arg_idxs = args |> List.mapi (fun idx x -> (idx,x)) in + (* compute indices for refined type parameters *) + let refined_idxs = arg_idxs |> List.filter_map (function + | (_idx, {ptyp_desc=Ptyp_var var}) when List.mem var type_variables -> + (* The type parameter is a variable. It is likely that the constructor does not refine the variable. + However, there are cases that even if the constructor does not refine the type parameter, + the constructor's argument type does. In that case, the type parameter should be considered refined as well. + To express that the type parameter is refined, the programmer can change the type parameter in the return type + to a type that is not same as the one in the declaration. + For example, + type 'a term = Var : string * 'a typ -> 'a term | ... + Here, when the programmer knows that the parameter 'a in type 'a type is refined, there should be a way to express that. + To express that, the programmer change the return type of the constructor to be different from the declaration, say 'v, + type 'a term = Var : string * 'v typ -> 'v term | ... + So that poly_a is never called to print the type. + + Note that, there are cases that the constructor itself does not refine the paramter but its declaration is GADT-ish: + existential variables. + If one needs existential type variables while a type parameter is not refined, the programmer would keep using + the same variable name as in the declaration, for example: + type 'state transition = Print : 'v term * 'state -> 'state transition | ... + to express that 'state is non-refined type parameter (thus poly_state is actually called) while the constructor + is GADT-ish. + *) + None + | (idx, _) -> (*refined*) Some idx) + in + Some refined_idxs + | _ -> None) |> List.concat let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = @@ -342,20 +367,20 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl)) in 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 unusable_param_pos = refined_param_pos_of_type_decl type_decl in + let refined_param_pos = refined_param_pos_of_type_decl type_decl in let prettyprinter = polymorphize prettyprinter in let prettyprinter = if is_gadt type_decl then Ppx_deriving.newtype_of_type_decl type_decl - @@ Exp.constraint_ prettyprinter (pp_type_of_decl_newtype ~unusable_param_pos type_decl) + @@ Exp.constraint_ prettyprinter (pp_type_of_decl_newtype ~refined_param_pos type_decl) else prettyprinter in let pp_type = - Ppx_deriving.strong_type_of_type @@ pp_type_of_decl ~unusable_param_pos type_decl in + Ppx_deriving.strong_type_of_type @@ pp_type_of_decl ~refined_param_pos type_decl in let show_type = Ppx_deriving.strong_type_of_type @@ - show_type_of_decl ~unusable_param_pos type_decl in + show_type_of_decl ~refined_param_pos type_decl in let pp_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl) in let show_var = From e7edaa40d6c028d5ec726824562a75a8469d11ae Mon Sep 17 00:00:00 2001 From: Keigo Imai Date: Wed, 16 Oct 2024 23:17:33 +0900 Subject: [PATCH 3/5] more docs --- src_plugins/show/ppx_deriving_show.ml | 57 +++++++++++++++++---------- 1 file changed, 37 insertions(+), 20 deletions(-) diff --git a/src_plugins/show/ppx_deriving_show.ml b/src_plugins/show/ppx_deriving_show.ml index 8588b6bd..16107f6a 100644 --- a/src_plugins/show/ppx_deriving_show.ml +++ b/src_plugins/show/ppx_deriving_show.ml @@ -49,6 +49,15 @@ let fresh_type_maker type_decl = bound := newvar :: !bound; Typ.var newvar +(** [pp_type_of_decl decl] returns type for [pp_xxx] where xxx is the type name. + For example, for [type ('a, 'b) map] it produces + [(formatter -> 'a -> unit) -> (formatter -> 'b -> unit) -> formatter -> ('a, 'b) map -> unit]. + For GADTs, the optional parameter [refined_param_pos] specifies the index of refined + parameters i.e., [0] for ['a] in [type ('a, 'b) map] and [1] for ['b]. + If present, the type parameter is rendered as any [type _] type, to mark the type parameter is + actually ignored. For example, for [type ('a, 'b) map] with [refined_param_pos=[1]], it produces + [(formatter -> 'a -> unit) -> (formatter -> _ -> unit) -> formatter -> ('a, 'b) map -> unit] + (see [_] instead of ['b] in the type for the second argument). *) let pp_type_of_decl ?(refined_param_pos=[]) type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in @@ -60,6 +69,8 @@ let pp_type_of_decl ?(refined_param_pos=[]) type_decl = type_decl [%type: Ppx_deriving_runtime.Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit] +(** Same as [pp_type_of_decl] but type parameters are rendered as locally abstract types rather than + type variables. *) let pp_type_of_decl_newtype ?(refined_param_pos=[]) type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl_with_newtype type_decl in @@ -70,6 +81,8 @@ let pp_type_of_decl_newtype ?(refined_param_pos=[]) type_decl = type_decl [%type: Ppx_deriving_runtime.Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit] +(** [show_type_of_decl decl] returns type for [show_xxx] where xxx is the type name. + The optional parameter [refined_param_pos] behaves same as [pp_type_of_decl]. *) let show_type_of_decl ?(refined_param_pos=[]) type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in @@ -87,9 +100,13 @@ let sig_of_type type_decl = Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl)) (show_type_of_decl type_decl))] -let rec expr_of_typ ~effective_variables quoter typ = +(** [expr_of_typ typ] returns an expression that pretty-prints a value of the given type. + For type variables available in [type_params], it puts [poly_N] which pretty-prints + the type parameter [N], assuming that [poly_N] is supplied by the caller. + Otherwise, it is rendered as a 'degenerate' pretty printer which is never called. *) +let rec expr_of_typ ~type_params quoter typ = let loc = typ.ptyp_loc in - let expr_of_typ = expr_of_typ ~effective_variables quoter in + let expr_of_typ = expr_of_typ ~type_params quoter in match Attribute.get ct_attr_printer typ with | Some printer -> [%expr [%e wrap_printer quoter printer] fmt] | None -> @@ -203,13 +220,14 @@ let rec expr_of_typ ~effective_variables quoter typ = in Exp.function_ cases | { ptyp_desc = Ptyp_var name } -> - if List.mem name effective_variables then + if List.mem name type_params then [%expr [%e evar ("poly_"^name)] fmt] else - (* We assume some 'calling convention' here: for type variables not appear in the declaration, - we supply a 'degenerate' pretty printer which is never called, as we deem them 'refined' to - a concrete type at some point. *) - [%expr (fun ()(*never type here*) -> failwith "impossible")] + (* We assume a 'calling convention' here: type variables not in the type parameter list will be refined + by the GADT taking that variable as an argument, and thus pretty printer for that type is never called. + For such a printer, we supply a 'degenerate' one which could not be called in any ways. + If this invariant breaks, type error will be reported. *) + [%expr (fun (_ : [`this_type_is_refined_and_no_pretty_printer_is_supplied]) -> failwith "impossible")] | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" @@ -241,18 +259,17 @@ let refined_param_pos_of_type_decl type_decl = | (_idx, {ptyp_desc=Ptyp_var var}) when List.mem var type_variables -> (* The type parameter is a variable. It is likely that the constructor does not refine the variable. However, there are cases that even if the constructor does not refine the type parameter, - the constructor's argument type does. In that case, the type parameter should be considered refined as well. - To express that the type parameter is refined, the programmer can change the type parameter in the return type - to a type that is not same as the one in the declaration. - For example, + the constructor's argument type does. To express that the type parameter is refined in such cases, + we introduce a convention that the refined type parameter will have different name from the one in the return type of + some constructor. For example type 'a term = Var : string * 'a typ -> 'a term | ... - Here, when the programmer knows that the parameter 'a in type 'a type is refined, there should be a way to express that. - To express that, the programmer change the return type of the constructor to be different from the declaration, say 'v, + Here, if the programmer knows that the parameter 'a in type 'a type is refined, the programmer change the return type + of the constructor to be different from the declaration, say 'v: type 'a term = Var : string * 'v typ -> 'v term | ... So that poly_a is never called to print the type. Note that, there are cases that the constructor itself does not refine the paramter but its declaration is GADT-ish: - existential variables. + use of existential variables. If one needs existential type variables while a type parameter is not refined, the programmer would keep using the same variable name as in the declaration, for example: type 'state transition = Print : 'v term * 'state -> 'state transition | ... @@ -269,11 +286,11 @@ let refined_param_pos_of_type_decl type_decl = 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 type_variables = Ppx_deriving.type_param_names_of_type_decl type_decl in + let type_params = Ppx_deriving.type_param_names_of_type_decl type_decl in let prettyprinter = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> - [%expr fun fmt -> [%e expr_of_typ ~effective_variables:type_variables quoter manifest]] + [%expr fun fmt -> [%e expr_of_typ ~type_params quoter manifest]] | Ptype_variant constrs, _ -> let cases = constrs |> List.map (fun ({ pcd_name = { txt = name' }; pcd_args; pcd_attributes } as constr) -> @@ -304,7 +321,7 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = (app (wrap_printer quoter printer) ([%expr fmt] :: args)) | None, Pcstr_tuple(typs) -> let args = - List.mapi (fun i typ -> app (expr_of_typ ~effective_variables:type_variables quoter typ) [evar (argn i)]) typs in + List.mapi (fun i typ -> app (expr_of_typ ~type_params quoter typ) [evar (argn i)]) typs in let printer = match args with | [] -> [%expr Ppx_deriving_runtime.Format.pp_print_string fmt [%e str constr_name]] @@ -326,7 +343,7 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) -> [%expr Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str n]; - [%e expr_of_label_decl ~effective_variables:type_variables quoter pld] + [%e expr_of_label_decl ~type_params quoter pld] [%e evar (argl n)]; Ppx_deriving_runtime.Format.fprintf fmt "@]" ]) @@ -348,7 +365,7 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = 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 ~effective_variables:type_variables quoter pld] + [%e expr_of_label_decl ~type_params quoter pld] [%e Exp.field (evar "x") (mknoloc (Lident name))]; Ppx_deriving_runtime.Format.fprintf fmt "@]" ]) @@ -434,7 +451,7 @@ let derive_extension = 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 ~effective_variables:[] quoter typ]) x])) + [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" (fun fmt -> [%e expr_of_typ ~type_params:[] quoter typ]) x])) let derive_transformation = Driver.register_transformation deriver From d2ccd5fc983e3fb5f19fa4a2408ae923de8c06a8 Mon Sep 17 00:00:00 2001 From: Keigo Imai Date: Thu, 17 Oct 2024 00:44:18 +0900 Subject: [PATCH 4/5] option refined_params to specify which type params are refined --- src_plugins/show/ppx_deriving_show.ml | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/src_plugins/show/ppx_deriving_show.ml b/src_plugins/show/ppx_deriving_show.ml index 16107f6a..5ed42381 100644 --- a/src_plugins/show/ppx_deriving_show.ml +++ b/src_plugins/show/ppx_deriving_show.ml @@ -94,11 +94,11 @@ let show_type_of_decl ?(refined_param_pos=[]) type_decl = type_decl [%type: [%t typ] -> Ppx_deriving_runtime.string] -let sig_of_type type_decl = +let sig_of_type ~refined_param_pos type_decl = [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl)) - (pp_type_of_decl type_decl)); + (pp_type_of_decl ?refined_param_pos type_decl)); Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl)) - (show_type_of_decl type_decl))] + (show_type_of_decl ?refined_param_pos type_decl))] (** [expr_of_typ typ] returns an expression that pretty-prints a value of the given type. For type variables available in [type_params], it puts [poly_N] which pretty-prints @@ -283,7 +283,7 @@ let refined_param_pos_of_type_decl type_decl = | _ -> None) |> List.concat -let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = +let str_of_type ~with_path ~refined_param_pos ~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 type_params = Ppx_deriving.type_param_names_of_type_decl type_decl in @@ -384,10 +384,15 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl)) in 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 refined_param_pos = refined_param_pos_of_type_decl type_decl in + let refined_param_pos = + match refined_param_pos with + | Some xs -> xs + | None -> refined_param_pos_of_type_decl type_decl + in let prettyprinter = polymorphize prettyprinter in let prettyprinter = if is_gadt type_decl then + (* for GADTs, ascribe with locally abstract types like (fun (type a) -> ... : formatter -> a t -> unit) *) Ppx_deriving.newtype_of_type_decl type_decl @@ Exp.constraint_ prettyprinter (pp_type_of_decl_newtype ~refined_param_pos type_decl) else @@ -407,10 +412,10 @@ let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = (Ppx_deriving.sanitize ~quoter prettyprinter); Vb.mk ~attrs:[no_warn_32] (Pat.constraint_ show_var show_type) (polymorphize stringprinter);] -let impl_args = Deriving.Args.(empty +> arg "with_path" (Ast_pattern.ebool __)) +let impl_args = Deriving.Args.(empty +> arg "with_path" (Ast_pattern.ebool __) +> arg "refined_params" Ast_pattern.(elist (eint __))) (* TODO: add arg_default to ppxlib? *) -let impl_generator = Deriving.Generator.V2.make impl_args (fun ~ctxt (_, type_decls) with_path -> +let impl_generator = Deriving.Generator.V2.make impl_args (fun ~ctxt (_, type_decls) with_path refined_param_pos -> 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. *) @@ -432,12 +437,12 @@ let impl_generator = Deriving.Generator.V2.make impl_args (fun ~ctxt (_, type_de | 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))]) + [Str.value Recursive (List.concat (List.map (str_of_type ~with_path ~refined_param_pos ~path) type_decls))]) -let intf_args = Deriving.Args.(empty +> arg "with_path" (Ast_pattern.ebool __)) +let intf_args = Deriving.Args.(empty +> arg "with_path" (Ast_pattern.ebool __) +> arg "refined_params" Ast_pattern.(elist (eint __))) -let intf_generator = Deriving.Generator.V2.make intf_args (fun ~ctxt:_ (_, type_decls) _with_path -> - List.concat (List.map sig_of_type type_decls)) +let intf_generator = Deriving.Generator.V2.make intf_args (fun ~ctxt:_ (_, type_decls) _with_path refined_param_pos -> + List.concat (List.map (sig_of_type ~refined_param_pos) type_decls)) let deriving: Deriving.t = Deriving.add From e18c11e4e56349d52dcd0acb5e203d6f555ba262 Mon Sep 17 00:00:00 2001 From: keigo-imai Date: Fri, 18 Oct 2024 19:11:24 +0900 Subject: [PATCH 5/5] a few tests --- src_test/show/test_deriving_show.cppo.ml | 53 ++++++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/src_test/show/test_deriving_show.cppo.ml b/src_test/show/test_deriving_show.cppo.ml index 7a2d7558..24e3dc6f 100644 --- a/src_test/show/test_deriving_show.cppo.ml +++ b/src_test/show/test_deriving_show.cppo.ml @@ -244,6 +244,56 @@ let test_paths_printer ctxt = assert_equal ~printer "(Test_deriving_show.WithFull.A 1)" (WithFull.show (WithFull.A 1)); () +type 'a gadt_simple = Int : int -> int gadt_simple | Float : float -> float gadt_simple +[@@deriving show] + +let test_gadt_printer ctxt = + assert_equal ~printer "(Test_deriving_show.Int 1)" (show_gadt_simple (fun _ _ -> ()) (Int 1)); + assert_equal ~printer "(Test_deriving_show.Float 1.)" (show_gadt_simple (fun _ _ -> ()) (Float 1.)) + +type 'a gadt_recursive = + | LitInt : int -> int gadt_recursive + | String : String.t -> String.t gadt_recursive + | Pair : 'a gadt_recursive * 'b gadt_recursive -> ('a * 'b) gadt_recursive +[@@deriving show] + +let test_gadt_printer2 ctxt = + assert_equal ~printer "(Test_deriving_show.LitInt 1)" (show_gadt_recursive (fun _ _ -> ()) (LitInt 1)); + assert_equal ~printer + "(Test_deriving_show.Pair ((Test_deriving_show.LitInt 42),\n (Test_deriving_show.Pair ((Test_deriving_show.String \"foobar\"),\n (Test_deriving_show.LitInt 1)))\n ))" + (show_gadt_recursive (fun _ _ -> ()) (Pair (LitInt 42, Pair (String "foobar", LitInt 1)))) + +type 'a existential = + | Ex : 'a * 'b gadt_recursive -> 'a existential +[@@deriving show] + +let test_gadt_printer3 ctxt = + assert_equal ~printer "(Test_deriving_show.Ex (1, (Test_deriving_show.LitInt 1)))" ([%show: int existential] (Ex (1, LitInt 1))); + assert_equal ~printer + "(Test_deriving_show.Ex ([1; 2; 3], (Test_deriving_show.String \"foobar\")))" + ([%show: int list existential] (Ex ([1;2;3], String "foobar"))) + +type 'a t = Ex : 'v gadt_recursive -> 'v t +[@@deriving show {refined_params = [0]}] + +module Foo : sig + type 'a t + [@@deriving show {refined_params = [0]}] + val make : 'a gadt_recursive -> 'a t + + type 'a s + [@@deriving show {refined_params = [0]}] + val make_s : 'a gadt_recursive -> 'a s +end = struct + type 'a t = Ex : 'v gadt_recursive -> 'v t + [@@deriving show] + let make x = Ex x + + type 'a s = 'a gadt_recursive + [@@deriving show {refined_params = [0]}] + let make_s x = x +end + let suite = "Test deriving(show)" >::: [ "test_alias" >:: test_alias; "test_variant" >:: test_variant; @@ -267,6 +317,9 @@ let suite = "Test deriving(show)" >::: [ "test_paths" >:: test_paths_printer; "test_result" >:: test_result; "test_result_result" >:: test_result_result; + "test_gadt_printer" >:: test_gadt_printer; + "test_gadt_printer2" >:: test_gadt_printer2; + "test_gadt_printer3" >:: test_gadt_printer3; ] let _ = run_test_tt_main suite