Print types from applied functors in created interfaces

analysis/src/cli.ml

@@ -176,7 +176,7 @@ let create_interface ~path ~cmi_file =
     match Files.read_file path with
     | None -> ""
     | Some source -> (
-      match Create_interface.command ~source ~cmi_file with
+      match Create_interface.command ~path ~source ~cmi_file with
       | Ok content -> content
       | Error _ -> "")
   in

analysis/src/create_interface.ml

@@ -95,8 +95,38 @@ end = struct
       !res |> List.rev |> String.concat "\n"
 end
 
-let print_signature ~extractor ~signature =
+let loc_within ~(outer : Location.t) (loc : Location.t) =
+  outer.loc_start.pos_cnum <= loc.loc_start.pos_cnum
+  && loc.loc_end.pos_cnum <= outer.loc_end.pos_cnum
+
+(* The locations of the functors in a signature, nested ones included. *)
+let rec functor_locs (signature : Types.signature) =
+  signature
+  |> List.concat_map (function
+    | Types.Sig_module (_, {md_type; md_loc}, _) -> (
+      match md_type with
+      | Mty_functor _ -> [md_loc]
+      | Mty_signature signature -> functor_locs signature
+      | Mty_ident _ | Mty_alias _ -> [])
+    | _ -> [])
+
+(* The source text of a type declaration can be copied when it says what the
+   type is at this point of the interface: when the type is declared in this
+   file, and either inside the module being printed or outside any functor.
+   A type of an applied functor is located in the functor's body, where its
+   definition mentions the functor's parameters, and a type included from
+   another file is located there; both are printed from the signature. *)
+let declared_in ~path ~functors ~(scope : Location.t option) (loc : Location.t)
+    =
+  Filename.basename loc.loc_start.pos_fname = Filename.basename path
+  &&
+  match scope with
+  | Some scope when loc_within ~outer:scope loc -> true
+  | _ -> not (List.exists (fun outer -> loc_within ~outer loc) functors)
+
+let print_signature ~path ~extractor ~signature =
   Printtyp.reset_names ();
+  let functors = functor_locs signature in
   let sig_item_to_string (item : Outcometree.out_sig_item) =
     item |> Res_outcome_printer.print_out_sig_item_doc
     |> Res_doc.to_string ~width:Res_printer.default_print_width
@@ -140,7 +170,8 @@ let print_signature ~extractor ~signature =
     | _ -> None
   in
 
-  let rec process_signature ~indent (signature : Types.signature) : unit =
+  let rec process_signature ~scope ~indent (signature : Types.signature) : unit
+      =
     match signature with
     | Sig_type
         (props_id, {type_params; type_kind = Type_record (label_decls, _)}, _)
@@ -193,7 +224,7 @@ let print_signature ~extractor ~signature =
       in
       Buffer.add_string buf (indent ^ "@react.component\n");
       Buffer.add_string buf (indent ^ new_item_str ^ "\n");
-      process_signature ~indent rest
+      process_signature ~scope ~indent rest
     | Sig_module (id, mod_decl, rec_status) :: rest ->
       let colon_or_equals =
         match mod_decl.md_type with
@@ -207,20 +238,20 @@ let print_signature ~extractor ~signature =
           | Trec_first -> "module rec "
           | Trec_next -> "and ")
         ^ Ident.name id ^ colon_or_equals);
-      process_module_type ~indent mod_decl.md_type;
+      process_module_type ~scope:(Some mod_decl.md_loc) ~indent mod_decl.md_type;
       Buffer.add_string buf "\n";
-      process_signature ~indent rest
+      process_signature ~scope ~indent rest
     | Sig_modtype (id, mtd) :: rest ->
       let () =
         match mtd.mtd_type with
         | None ->
           Buffer.add_string buf (indent ^ "module type " ^ Ident.name id ^ "\n")
         | Some mt ->
           Buffer.add_string buf (indent ^ "module type " ^ Ident.name id ^ " = ");
-          process_module_type ~indent mt;
+          process_module_type ~scope:(Some mtd.mtd_loc) ~indent mt;
           Buffer.add_string buf "\n"
       in
-      process_signature ~indent rest
+      process_signature ~scope ~indent rest
     | Sig_value (id, ({val_kind = Val_prim prim; val_loc} as vd)) :: items
       when prim.prim_kind <> Primitive.Kind_intrinsic ->
       (* Rescript primitive name, e.g. @val external ... *)
@@ -238,34 +269,41 @@ let print_signature ~extractor ~signature =
         (* Copy the external declaration verbatim from the implementation file *)
         Buffer.add_string buf ((lines |> String.concat "\n") ^ "\n");
 
-      process_signature ~indent items
+      process_signature ~scope ~indent items
     | Sig_value (id, vd) :: items ->
       let new_item_str =
         sig_item_to_string (Printtyp.tree_of_value_description id vd)
       in
       Buffer.add_string buf (indent ^ new_item_str ^ "\n");
-      process_signature ~indent items
-    | Sig_type (_id, type_decl, _recStatus) :: items ->
-      let lines =
-        let pos_start, pos_end = Loc.range type_decl.type_loc in
-        extractor |> Source_file_extractor.extract ~pos_start ~pos_end
-      in
-      (* Copy the type declaration verbatim to preserve attributes *)
-      Buffer.add_string buf ((lines |> String.concat "\n") ^ "\n");
-      process_signature ~indent items
+      process_signature ~scope ~indent items
+    | Sig_type (id, type_decl, rec_status) :: items ->
+      (if declared_in ~path ~functors ~scope type_decl.type_loc then
+         let lines =
+           let pos_start, pos_end = Loc.range type_decl.type_loc in
+           extractor |> Source_file_extractor.extract ~pos_start ~pos_end
+         in
+         (* Copy the type declaration verbatim to preserve attributes *)
+         Buffer.add_string buf ((lines |> String.concat "\n") ^ "\n")
+       else
+         let new_item_str =
+           sig_item_to_string
+             (Printtyp.tree_of_type_declaration id type_decl rec_status)
+         in
+         Buffer.add_string buf (indent ^ new_item_str ^ "\n"));
+      process_signature ~scope ~indent items
     | Sig_typext (id, ext_constr, ext_status) :: items ->
       let new_item_str =
         sig_item_to_string
           (Printtyp.tree_of_extension_constructor id ext_constr ext_status)
       in
       Buffer.add_string buf (indent ^ new_item_str ^ "\n");
-      process_signature ~indent items
+      process_signature ~scope ~indent items
     | [] -> ()
-  and process_module_type ~indent (mt : Types.module_type) =
+  and process_module_type ~scope ~indent (mt : Types.module_type) =
     match mt with
     | Mty_signature signature ->
       Buffer.add_string buf "{\n";
-      process_signature ~indent:(indent ^ "  ") signature;
+      process_signature ~scope ~indent:(indent ^ "  ") signature;
       Buffer.add_string buf (indent ^ "}")
     | Mty_functor _ ->
       let rec collect_functor_args ~args (mt : Types.module_type) =
@@ -286,11 +324,11 @@ let print_signature ~extractor ~signature =
           | None -> Buffer.add_string buf (Ident.name id)
           | Some mt ->
             Buffer.add_string buf (Ident.name id ^ ": ");
-            process_module_type ~indent:(indent ^ "  ") mt);
+            process_module_type ~scope ~indent:(indent ^ "  ") mt);
           Buffer.add_string buf ",");
       if args <> [] then Buffer.add_string buf ("\n" ^ indent);
       Buffer.add_string buf (") =>\n" ^ indent);
-      process_module_type ~indent ret_mt
+      process_module_type ~scope ~indent ret_mt
     | Mty_ident path | Mty_alias (_, path) ->
       let rec out_ident_to_string (ident : Outcometree.out_ident) =
         match ident with
@@ -302,12 +340,12 @@ let print_signature ~extractor ~signature =
       Buffer.add_string buf (out_ident_to_string (Printtyp.tree_of_path path))
   in
 
-  process_signature ~indent:"" signature;
+  process_signature ~scope:None ~indent:"" signature;
   Buffer.contents buf
 
-let command ~source ~cmi_file =
+let command ~path ~source ~cmi_file =
   match Shared.try_read_cmi cmi_file with
   | Some cmi_info ->
     let extractor = source |> String.split_on_char '\n' |> Array.of_list in
-    Ok (print_signature ~extractor ~signature:cmi_info.cmi_sign)
+    Ok (print_signature ~path ~extractor ~signature:cmi_info.cmi_sign)
   | None -> Error ("Failed to read cmi file " ^ cmi_file)

changes/create-interface-functor-types.fix.md

@@ -0,0 +1 @@
+- Editor "create interface" prints the types of applied functors and included modules instead of copying unrelated source lines.

compiler/ml/outcometree.ml

@@ -37,7 +37,8 @@ type out_type =
   | Otyp_manifest of out_type * out_type
   | Otyp_object of (string * bool * out_type) list * bool option
     (* fields are (name, mutable, type) *)
-  | Otyp_record of (string * bool * bool * out_type) list
+  | Otyp_record of (string * string option * bool * bool * out_type) list
+      (** name, runtime name given with [@as], mutable, optional, type *)
   | Otyp_stuff of string
   | Otyp_sum of (string * out_type list * out_type option * string option) list
   | Otyp_tuple of out_type list

compiler/ml/printtyp.ml

@@ -951,6 +951,7 @@ and tree_of_label ?printing_context l =
     | _ -> l.ld_type
   in
   ( Ident.name l.ld_id,
+    l.ld_runtime_name,
     l.ld_mutable = Mutable,
     opt,
     tree_of_typexp ?printing_context false typ )

compiler/syntax/src/res_outcome_printer.ml

@@ -392,10 +392,14 @@ and print_out_constructor_doc (name, args, gadt, repr) =
   in
   Doc.group (Doc.concat [repr_doc; Doc.text name; args_doc; gadt_doc])
 
-and print_record_decl_row_doc (name, mut, opt, arg) =
+and print_record_decl_row_doc (name, runtime_name, mut, opt, arg) =
   Doc.group
     (Doc.concat
        [
+         (match runtime_name with
+         | Some runtime_name ->
+           Doc.text ("@as(\"" ^ String.escaped runtime_name ^ "\") ")
+         | None -> Doc.nil);
          (if mut then Doc.text "mutable " else Doc.nil);
          Printer.print_ident_like ~allow_uident:false name;
          (if opt then Doc.text "?" else Doc.nil);

tests/analysis_tests/tests/src/CreateInterfaceFunctor.res

@@ -0,0 +1,34 @@
+// ^int
+
+module type Ord = {
+  type t
+  let compare: (t, t) => int
+}
+
+module MakeSet = (O: Ord) => {
+  type t = array<O.t>
+  let add = (s: t, x: O.t) => s->Array.concat([x])
+}
+
+module IntSet = MakeSet({
+  type t = int
+  let compare = (a: int, b) => a - b
+})
+
+// Types of the same file outside a functor keep their attributes
+module M = {
+  type t = {@as("wire") field: int}
+}
+
+module type S = module type of M
+
+module N = {
+  include M
+}
+
+// Types of an applied functor keep the runtime names of their fields
+module WithWire = (X: {}) => {
+  type t = {@as("wire") field: int}
+}
+
+module Applied = WithWire({})

tests/analysis_tests/tests/src/CreateInterfaceFunctorUse.res

@@ -0,0 +1,11 @@
+// ^int
+
+module StrSet = CreateInterfaceFunctor.MakeSet({
+  type t = string
+  let compare = (a: string, b) => a < b ? -1 : a > b ? 1 : 0
+})
+
+include CreateInterfaceFunctor.MakeSet({
+  type t = float
+  let compare = (a: float, b) => a < b ? -1 : a > b ? 1 : 0
+})

tests/analysis_tests/tests/src/expected/CreateInterfaceFunctor.res.txt

@@ -0,0 +1,36 @@
+Create Interface src/CreateInterfaceFunctor.res
+module type Ord = {
+  type t
+  let compare: (t, t) => int
+}
+module MakeSet: (
+  O: Ord,
+) =>
+{
+  type t = array<O.t>
+  let add: (t, O.t) => array<O.t>
+}
+module IntSet: {
+  type t = array<int>
+  let add: (t, int) => array<int>
+}
+module M: {
+  type t = {@as("wire") field: int}
+}
+module type S = {
+  type t = {@as("wire") field: int}
+}
+module N: {
+  type t = {@as("wire") field: int}
+}
+module WithWire: (
+  X: {
+  },
+) =>
+{
+  type t = {@as("wire") field: int}
+}
+module Applied: {
+  type t = {@as("wire") field: int}
+}
+

tests/analysis_tests/tests/src/expected/CreateInterfaceFunctorUse.res.txt

@@ -0,0 +1,8 @@
+Create Interface src/CreateInterfaceFunctorUse.res
+module StrSet: {
+  type t = array<string>
+  let add: (t, string) => array<string>
+}
+type t = array<float>
+let add: (t, float) => array<float>
+