Use the applied signature for modules created by functor application

analysis/src/hover.ml

@@ -64,6 +64,9 @@ type extracted_type = {
   decl: Types.type_declaration;
   env: Shared_types.Query_env.t;
   loc: Warnings.loc;
+  uri: Uri.t;
+      (** the file of [loc], which differs from [env]'s for a type
+                   of an applied or included module of another file *)
 }
 
 let find_relevant_types_from_type ~state ~file ~package typ =
@@ -103,9 +106,13 @@ let find_relevant_types_from_type ~state ~file ~package typ =
   let from_constructor_path ~env path =
     match References.dig_constructor ~state ~env ~package path with
     | None -> None
-    | Some (env, {name = {txt}; extent_loc; item = {decl}}) ->
+    | Some (env, {name = {txt}; extent_loc; item = {decl}; module_path}) ->
       if Utils.is_uncurried_internal path then None
-      else Some {name = txt; env; loc = extent_loc; decl; path}
+      else
+        let uri =
+          Resolve_path.get_source_uri ~state ~env ~package module_path
+        in
+        Some {name = txt; env; loc = extent_loc; decl; path; uri}
   in
   let constructors = Shared.find_type_constructors types_to_search in
   constructors |> List.filter_map (from_constructor_path ~env:env_to_search)
@@ -142,12 +149,12 @@ let expand_types ~state ~file ~package ~supports_markdown_links typ =
           else (
             types_seen := String_set.add type_id !types_seen;
             true))
-      |> List.map (fun {decl; env; loc; path} ->
+      |> List.map (fun {decl; loc; path; uri} ->
           let link_to_type_definition_str =
             if
               supports_markdown_links
               && not (is_inline_record_definition decl path)
-            then Markdown.go_to_definition_text ~env ~pos:loc.Warnings.loc_start
+            then Markdown.go_to_definition_text ~uri ~pos:loc.Warnings.loc_start
             else ""
           in
           Markdown.divider

analysis/src/markdown.ml

@@ -8,12 +8,12 @@ let make_goto_command link =
   Printf.sprintf "[%s](%s#L%d,%d)" link.label link.file (link.start_pos.line + 1)
     (link.start_pos.character + 1)
 
-let go_to_definition_text ~env ~pos =
+let go_to_definition_text ~uri ~pos =
   let start_line, start_col = Pos.of_lexing pos in
   "\nGo to: "
   ^ make_goto_command
       {
         label = "Type definition";
-        file = Uri.to_string env.Shared_types.Query_env.file.uri;
+        file = Uri.to_string uri;
         start_pos = {line = start_line; character = start_col};
       }

analysis/src/process_cmt.ml

@@ -185,6 +185,43 @@ and for_type_module ~name ~env module_type =
   | Mty_functor (_argIdent, _argType, result_type) ->
     for_type_module ~name ~env result_type
 
+(* Stamps given to renamed identifiers start here, far above the stamps
+   in a typed tree, so that they never meet one of them. *)
+let renamed_stamp_floor = 1 lsl 40
+
+(* [Subst] renames the items of a signature in place, so the original and
+   the renamed signature list the same items in the same order. Records
+   each renamed stamp's original, nested signatures included, for
+   references to find the declarations in the functor body. *)
+let rec record_renamed_stamps table (original : Types.module_type)
+    (renamed : Types.module_type) =
+  match (original, renamed) with
+  | Mty_signature items, Mty_signature renamed_items
+    when List.length items = List.length renamed_items ->
+    List.iter2
+      (fun (item : Types.signature_item) (renamed_item : Types.signature_item)
+         ->
+        let ids =
+          match (item, renamed_item) with
+          | Sig_value (id, _), Sig_value (id', _)
+          | Sig_type (id, _, _), Sig_type (id', _, _)
+          | Sig_typext (id, _, _), Sig_typext (id', _, _)
+          | Sig_modtype (id, _), Sig_modtype (id', _) ->
+            Some (id, id')
+          | Sig_module (id, md, _), Sig_module (id', md', _) ->
+            record_renamed_stamps table md.md_type md'.md_type;
+            Some (id, id')
+          | _ -> None
+        in
+        match ids with
+        | Some (id, id') ->
+          Hashtbl.replace table (Ident.binding_time id') (Ident.binding_time id)
+        | None -> ())
+      items renamed_items
+  | Mty_functor (_, _, result), Mty_functor (_, _, renamed_result) ->
+    record_renamed_stamps table result renamed_result
+  | _ -> ()
+
 let get_module_type_path mod_desc =
   match mod_desc with
   | Typedtree.Tmty_ident (path, _) | Tmty_alias (path, _) -> Some path
@@ -546,13 +583,12 @@ let rec for_structure_item ~(env : Shared_types.Env.t) ~(exported : Exported.t)
     bindings
     |> List.iter (fun {Typedtree.vb_expr} -> scan_let_modules ~env vb_expr);
     !items
-  | Tstr_module
-      {mb_id; mb_attributes; mb_loc; mb_name = name; mb_expr = {mod_desc}}
+  | Tstr_module {mb_id; mb_attributes; mb_loc; mb_name = name; mb_expr}
     when not
            (String.length name.txt >= 6
            && (String.sub name.txt 0 6 = "local_") [@doesNotRaise])
          (* %%private generates a dummy module called local_... *) ->
-    let item = for_module ~env mod_desc name.txt in
+    let item = for_module ~env mb_expr name.txt in
     let declared =
       add_declared ~item ~name ~extent:mb_loc ~stamp:(Ident.binding_time mb_id)
         ~env mb_attributes
@@ -647,8 +683,8 @@ let rec for_structure_item ~(env : Shared_types.Env.t) ~(exported : Exported.t)
         decl |> for_type_declaration ~env ~exported ~rec_status)
   | _ -> []
 
-and for_module ~env mod_desc module_name =
-  match mod_desc with
+and for_module ~env (mod_expr : Typedtree.module_expr) module_name =
+  match mod_expr.mod_desc with
   | Tmod_ident (path, _lident) -> Ident path
   | Tmod_structure structure ->
     let env = env |> Env.add_module ~name:module_name in
@@ -665,15 +701,40 @@ and for_module ~env mod_desc module_name =
           ~extent:arg_name.loc ~stamp ~module_path:NotVisible false []
       in
       Stamps.add_module env.stamps stamp declared);
-    for_module ~env result_expr.mod_desc module_name
+    for_module ~env result_expr module_name
   | Tmod_apply (functor_, _arg, _coercion) ->
-    for_module ~env functor_.mod_desc module_name
+    (* The functor's body has the parameter's types; the application's
+       signature has the argument's. Its items keep the identifiers of the
+       body, whose stamps are already taken, so they are renamed first,
+       with stamps above any that a compilation hands out. Their locations
+       are in the functor's body, so they are marked as coming from the
+       functor, like included items, for definitions to find its file. *)
+    let env = env |> Env.add_module ~name:module_name in
+    let env =
+      match get_module_path functor_.mod_desc with
+      | Some path ->
+        {env with module_path = IncludedModule (path, env.module_path)}
+      | None -> env
+    in
+    if Ident.current_time () < renamed_stamp_floor then
+      Ident.set_current_time renamed_stamp_floor;
+    let renamed = Subst.modtype Subst.identity mod_expr.mod_type in
+    (* The functor's result signature has the identifiers of the body's
+       declarations; the application's has them only when the argument is
+       not a path, else the compiler already renamed them. *)
+    let functor_result =
+      match functor_.mod_type with
+      | Mty_functor (_, _, result) -> result
+      | mty -> mty
+    in
+    record_renamed_stamps env.renamed_stamps functor_result renamed;
+    for_type_module ~name:module_name ~env renamed
   | Tmod_unpack (_expr, module_type) ->
     let env = env |> Env.add_module ~name:module_name in
     for_type_module ~name:module_name ~env module_type
   | Tmod_constraint (expr, typ, _constraint, _coercion) ->
     (* TODO do this better I think *)
-    let mod_kind = for_module ~env expr.mod_desc module_name in
+    let mod_kind = for_module ~env expr module_name in
     let env = env |> Env.add_module ~name:module_name in
     let mod_type_kind = for_type_module ~name:module_name ~env typ in
     Constraint (mod_kind, mod_type_kind)
@@ -690,7 +751,7 @@ and scan_let_modules ~env (e : Typedtree.expression) =
     (match expression.exp_desc with
     | Texp_letmodule (id, name, mexpr, _body) ->
       let stamp = Ident.binding_time id in
-      let item = for_module ~env mexpr.mod_desc name.txt in
+      let item = for_module ~env mexpr name.txt in
       let declared =
         Process_attributes.new_declared ~item ~extent:name.loc ~name ~stamp
           ~module_path:NotVisible false []
@@ -723,7 +784,11 @@ and for_structure ~name ~env str_items =
 let file_for_cmt_infos ~module_name ~uri
     ({cmt_modname; cmt_annots} : Cmt_format.cmt_infos) =
   let env =
-    {Env.stamps = Stamps.init (); module_path = File (uri, module_name)}
+    {
+      Env.stamps = Stamps.init ();
+      module_path = File (uri, module_name);
+      renamed_stamps = Hashtbl.create 1;
+    }
   in
   match cmt_annots with
   | Partial_implementation parts ->
@@ -737,7 +802,13 @@ let file_for_cmt_infos ~module_name ~uri
       |> List.concat
     in
     let structure = for_structure ~name:module_name ~env items in
-    {File.uri; module_name = cmt_modname; stamps = env.stamps; structure}
+    {
+      File.uri;
+      module_name = cmt_modname;
+      stamps = env.stamps;
+      structure;
+      renamed_stamps = env.renamed_stamps;
+    }
   | Partial_interface parts ->
     let items =
       parts |> Array.to_list
@@ -749,13 +820,31 @@ let file_for_cmt_infos ~module_name ~uri
       |> List.concat
     in
     let structure = for_signature ~name:module_name ~env items in
-    {uri; module_name = cmt_modname; stamps = env.stamps; structure}
+    {
+      uri;
+      module_name = cmt_modname;
+      stamps = env.stamps;
+      structure;
+      renamed_stamps = env.renamed_stamps;
+    }
   | Implementation structure ->
     let structure = for_structure ~name:module_name ~env structure.str_items in
-    {uri; module_name = cmt_modname; stamps = env.stamps; structure}
+    {
+      uri;
+      module_name = cmt_modname;
+      stamps = env.stamps;
+      structure;
+      renamed_stamps = env.renamed_stamps;
+    }
   | Interface signature ->
     let structure = for_signature ~name:module_name ~env signature.sig_items in
-    {uri; module_name = cmt_modname; stamps = env.stamps; structure}
+    {
+      uri;
+      module_name = cmt_modname;
+      stamps = env.stamps;
+      structure;
+      renamed_stamps = env.renamed_stamps;
+    }
 
 let file_for_cmt ~state ~module_name ~cmt ~uri =
   match Hashtbl.find_opt state.cmt_cache cmt with

analysis/src/process_extra.ml

@@ -29,14 +29,19 @@ let extra_for_file ~(file : File.t) =
         (TypeDefinition (d.name.txt, d.item.Type.decl, stamp));
       add_reference ~extra stamp d.name.loc;
       match d.item.Type.kind with
+      (* Fields and constructors of a type read from a signature, such as
+         an applied functor's, have no location of their own; references
+         to them are those of the declarations they come from. *)
       | Record labels ->
         labels
+        |> List.filter (fun {fname} -> not fname.loc.loc_ghost)
         |> List.iter (fun {stamp; fname; typ} ->
             add_reference ~extra stamp fname.loc;
             add_loc_item extra fname.loc
               (Typed (d.name.txt, typ, Definition (d.stamp, Field fname.txt))))
       | Variant constructors ->
         constructors
+        |> List.filter (fun {Constructor.cname} -> not cname.loc.loc_ghost)
         |> List.iter (fun {Constructor.stamp; cname} ->
             add_reference ~extra stamp cname.loc;
             let t =
@@ -135,13 +140,21 @@ let extra_for_cmt ~(iterator : Tast_iterator.iterator)
     extra_for_signature_items ~iterator items;
     extra_for_parts parts
 
+(* A use of an applied functor's member is also a use of the declaration
+   in the functor's body that it was renamed from. *)
+let add_reference_with_original ~(env : Query_env.t) ~extra stamp loc =
+  add_reference ~extra stamp loc;
+  match Hashtbl.find_opt env.file.renamed_stamps stamp with
+  | Some original -> add_reference ~extra original loc
+  | None -> ()
+
 let add_for_path ~env ~extra path lident loc typ tip =
   let ident_name = Longident.last lident in
   let ident_loc = Utils.end_of_location loc (String.length ident_name) in
   let loc_type =
     match Resolve_path.from_compiler_path ~env path with
     | Stamp stamp ->
-      add_reference ~extra stamp ident_loc;
+      add_reference_with_original ~env ~extra stamp ident_loc;
       LocalReference (stamp, tip)
     | NotFound -> NotFound
     | Global (module_name, path) ->
@@ -154,7 +167,7 @@ let add_for_path ~env ~extra path lident loc typ tip =
         | _ -> Exported.find env.exported Exported.Value name
       with
       | Some stamp ->
-        add_reference ~extra stamp ident_loc;
+        add_reference_with_original ~env ~extra stamp ident_loc;
         LocalReference (stamp, tip)
       | None -> NotFound)
     | GlobalMod _ -> NotFound
@@ -168,7 +181,7 @@ let add_for_path_parent ~env ~extra path loc =
       add_file_reference ~extra module_name loc;
       TopLevelModule module_name
     | Stamp stamp ->
-      add_reference ~extra stamp loc;
+      add_reference_with_original ~env ~extra stamp loc;
       LModule (LocalReference (stamp, Module))
     | NotFound -> LModule NotFound
     | Global (module_name, path) ->
@@ -177,7 +190,7 @@ let add_for_path_parent ~env ~extra path loc =
     | Exported (env, name) -> (
       match Exported.find env.exported Exported.Module name with
       | Some stamp ->
-        add_reference ~extra stamp loc;
+        add_reference_with_original ~env ~extra stamp loc;
         LModule (LocalReference (stamp, Module))
       | None -> LModule NotFound)
   in

analysis/src/references.ml

@@ -124,16 +124,23 @@ let declared_for_tip ~(stamps : Stamps.t) stamp (tip : Tip.t) =
     Stamps.find_module stamps stamp
     |> Option.map (fun x -> {x with Declared.item = ()})
 
+(* The type a renamed type of an applied functor comes from, whose fields
+   and constructors have source locations. *)
+let original_type_stamp (file : File.t) stamp =
+  match Hashtbl.find_opt file.renamed_stamps stamp with
+  | Some original -> original
+  | None -> stamp
+
 let get_field (file : File.t) stamp name =
-  match Stamps.find_type file.stamps stamp with
+  match Stamps.find_type file.stamps (original_type_stamp file stamp) with
   | None -> None
   | Some {item = {kind}} -> (
     match kind with
     | Record fields -> fields |> List.find_opt (fun f -> f.fname.txt = name)
     | _ -> None)
 
 let get_constructor (file : File.t) stamp name =
-  match Stamps.find_type file.stamps stamp with
+  match Stamps.find_type file.stamps (original_type_stamp file stamp) with
   | None -> None
   | Some {item = {kind}} -> (
     match kind with
@@ -440,6 +447,11 @@ type references = {
 
 let for_local_stamp ~state ~full:{file; extra; package} stamp (tip : Tip.t) =
   let env = Query_env.from_file file in
+  let stamp =
+    match Hashtbl.find_opt file.renamed_stamps stamp with
+    | Some original -> original
+    | None -> stamp
+  in
   match
     match tip with
     | Constructor name ->

analysis/src/shared_types.ml

@@ -274,13 +274,15 @@ module File = struct
     stamps: Stamps.t;
     module_name: string;
     structure: Module.structure;
+    renamed_stamps: (int, int) Hashtbl.t;
   }
 
   let create module_name uri =
     {
       uri;
       stamps = Stamps.init ();
       module_name;
+      renamed_stamps = Hashtbl.create 1;
       structure =
         {
           name = module_name;
@@ -404,7 +406,13 @@ and completion_type =
     }
 
 module Env = struct
-  type t = {stamps: Stamps.t; module_path: Module_path.t}
+  type t = {
+    stamps: Stamps.t;
+    module_path: Module_path.t;
+    renamed_stamps: (int, int) Hashtbl.t;
+        (** the stamps of an applied functor's renamed members, mapped to
+            those of the functor body's declarations they come from *)
+  }
   let add_exported_module ~name ~is_type env =
     {
       env with

analysis/src/signature_help.ml

@@ -9,10 +9,10 @@ let docs_for_label type_expr ~file ~state ~package ~supports_markdown_links =
   let type_names = types |> List.map (fun {Hover.name} -> name) in
   let type_definitions =
     types
-    |> List.map (fun {Hover.decl; name; env; loc; path} ->
+    |> List.map (fun {Hover.decl; name; loc; path; uri} ->
         let link_to_type_definition_str =
           if supports_markdown_links then
-            Markdown.go_to_definition_text ~env ~pos:loc.Warnings.loc_start
+            Markdown.go_to_definition_text ~uri ~pos:loc.Warnings.loc_start
           else ""
         in
         (* Since printing the whole name via its path can get quite long, and

changes/applied-functor-analysis-types.fix.md

@@ -0,0 +1 @@
+- Hover and completion on a module created by applying a functor show the applied types, such as `array<int>`, instead of the functor body's `array<O.t>`.