Deriving show for GADTs

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

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]. *)

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))

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)))
+         ))
+*)