diff --git a/src/api/ppx_deriving.cppo.ml b/src/api/ppx_deriving.cppo.ml index b14785b3..16e0e1de 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,24 @@ 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 idx (Typ.var name)) typ)) + type_decl + (len - 1, typ) + |> snd + let poly_arrow_of_type_ext fn type_ext typ = fold_right_type_ext (fun name typ -> let var = @@ -530,6 +551,25 @@ 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 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..4960fc27 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]]. @@ -273,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]. @@ -292,6 +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 @@ -303,6 +324,10 @@ 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 +(** [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..5ed42381 100644 --- a/src_plugins/show/ppx_deriving_show.ml +++ b/src_plugins/show/ppx_deriving_show.ml @@ -42,31 +42,71 @@ 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 + +(** [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 - 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 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 show_type_of_decl type_decl = +(** 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 + Ppx_deriving.newtype_arrow_of_type_decl + (fun pos lty -> + 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] + +(** [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 - 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 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] -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))] -let rec expr_of_typ 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 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 -> @@ -179,7 +219,15 @@ 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 type_params then + [%expr [%e evar ("poly_"^name)] fmt] + else + (* 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" @@ -189,13 +237,60 @@ 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 ~with_path ~path ({ ptype_loc = loc } as type_decl) = +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.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. 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, 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: + 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 | ... + 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 ~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 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 ~type_params quoter manifest]] | Ptype_variant constrs, _ -> let cases = constrs |> List.map (fun ({ pcd_name = { txt = name' }; pcd_args; pcd_attributes } as constr) -> @@ -226,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 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]] @@ -248,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 quoter pld] + [%e expr_of_label_decl ~type_params quoter pld] [%e evar (argl n)]; Ppx_deriving_runtime.Format.fprintf fmt "@]" ]) @@ -270,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 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 "@]" ]) @@ -289,24 +384,38 @@ 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 = + 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 + 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 ~refined_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 ~refined_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 __)) +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. *) @@ -328,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 @@ -347,7 +456,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 ~type_params:[] quoter typ]) x])) let derive_transformation = Driver.register_transformation deriver 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