Simplify generation of named interfaces (#57)

Signed-off-by: Thomas Refis <trefis@janestreet.com>

src/common.ml

@@ -149,3 +149,51 @@ end
 let attribute_of_warning loc s =
   ({ loc; txt = "ocaml.ppwarning" },
    PStr ([pstr_eval ~loc (estring ~loc s) []]))
+
+let is_polymorphic_variant =
+  let rec check = function
+    | { ptyp_desc = Ptyp_variant _; _ } -> `Definitely
+    | { ptyp_desc = Ptyp_alias (typ,_); _ } -> check typ
+    | { ptyp_desc = Ptyp_constr _; _ } -> `Maybe
+    | _ -> `Surely_not (* Type vars go here even though they could be polymorphic
+                          variants, however we don't handle it if they get substituted
+                          by a polymorphic variant that is then included. *)
+  in
+  fun td ~sig_ ->
+    match td.ptype_kind with
+    | Ptype_variant _ | Ptype_record _ | Ptype_open -> `Surely_not
+    | Ptype_abstract ->
+      match td.ptype_manifest with
+      | None -> if sig_ then `Maybe else `Surely_not
+      | Some typ -> check typ
+
+let mk_named_sig ~loc ~sg_name ~handle_polymorphic_variant = function
+  | [ td ] when String.equal td.ptype_name.txt "t" && List.is_empty td.ptype_cstrs ->
+    if not handle_polymorphic_variant &&
+       Poly.(=) (is_polymorphic_variant td ~sig_:true) `Definitely
+    then
+      None
+    else
+      let arity = List.length td.ptype_params in
+      if arity >= 4 then
+        None
+      else
+        let mty =
+          if arity = 0
+          then sg_name
+          else Printf.sprintf "%s%d" sg_name arity
+        in
+        let td = name_type_params_in_td td in
+        let for_subst =
+          Ast_helper.Type.mk ~loc td.ptype_name ~params:td.ptype_params
+            ~manifest:(
+              ptyp_constr ~loc (Located.map_lident td.ptype_name)
+                (List.map ~f:fst td.ptype_params)
+            )
+        in
+        Some (
+          include_infos ~loc
+            (pmty_with ~loc (pmty_ident ~loc (Located.lident mty ~loc))
+               [Pwith_typesubst (Located.lident ~loc "t", for_subst)])
+        )
+  | _ -> None

src/common.mli

@@ -51,3 +51,27 @@ val curry_applications : expression -> expression
 (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be inserted in
     a generated Parsetree.  The compiler will be responsible for reporting the warning. *)
 val attribute_of_warning : Location.t -> string -> attribute
+
+val is_polymorphic_variant
+  : type_declaration -> sig_:bool -> [> `Definitely | `Maybe | `Surely_not ]
+
+(** [mk_named_sig ~loc ~sg_name:"Foo" ~handle_polymorphic_variant tds] will
+    generate
+    {[
+      include Foo (* or Foo1, Foo2, Foo3 *)
+        with type (* ('a, 'b, 'c) *) t := (* ('a, 'b, 'c) *) t
+    ]}
+    when:
+    - there is only one type declaration
+    - the type is named t
+    - there are less than 4 type parameters
+    - there are no constraints on the type parameters
+
+    It will take care of giving fresh names to unnamed type parameters.
+*)
+val mk_named_sig
+  : loc:Location.t
+  -> sg_name:string
+  -> handle_polymorphic_variant:bool
+  -> type_declaration list
+  -> include_description option