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,8 +106,9 @@ 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 {name = txt; env; loc = extent_loc; decl; path}
+    | Some (env, {name = {txt}; extent_loc; item = {decl}; module_path}) ->
+      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)
@@ -141,12 +145,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

@@ -148,7 +148,7 @@ let rec for_type_signature_item ~(env : Shared_types.Env.t)
     let name = Ident.name ident in
     let declared =
       add_declared ~extent:md_loc
-        ~item:(for_type_module ~name ~env md_type)
+        ~item:(for_type_module ~name ~env:(env |> Env.add_module ~name) md_type)
         ~name:(Location.mkloc name md_loc)
         ~stamp:(Ident.binding_time ident) ~env md_attributes
         (Exported.add exported Exported.Module)
@@ -165,6 +165,28 @@ let rec for_type_signature_item ~(env : Shared_types.Env.t)
         loc = declared.extent_loc;
       };
     ]
+  | Sig_modtype (ident, {mtd_type = Some mod_type; mtd_attributes; mtd_loc}) ->
+    let name = Ident.name ident in
+    let env = env |> Env.add_module_type ~name in
+    let declared =
+      add_declared ~extent:mtd_loc
+        ~item:(for_type_module ~name ~env mod_type)
+        ~name:(Location.mkloc name mtd_loc)
+        ~stamp:(Ident.binding_time ident) ~env mtd_attributes
+        (Exported.add exported Exported.Module)
+        Stamps.add_module
+    in
+    [
+      {
+        Module.kind =
+          Module
+            {type_ = declared.item; is_module_type = is_module_type declared};
+        name = declared.name.txt;
+        docstring = declared.docstring;
+        deprecated = declared.deprecated;
+        loc = declared.extent_loc;
+      };
+    ]
   | _ -> []
 
 and for_type_signature ~name ~env signature =
@@ -185,6 +207,85 @@ 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. A stamp that
+   is not renamed is not recorded, so that chains of renamings end. *)
+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', _, _) ->
+            Some (id, id')
+          | Sig_module (id, md, _), Sig_module (id', md', _) ->
+            record_renamed_stamps table md.md_type md'.md_type;
+            Some (id, id')
+          | Sig_modtype (id, mtd), Sig_modtype (id', mtd') ->
+            (match (mtd.mtd_type, mtd'.mtd_type) with
+            | Some mty, Some mty' -> record_renamed_stamps table mty mty'
+            | _ -> ());
+            Some (id, id')
+          | _ -> None
+        in
+        match ids with
+        | Some (id, id') when Ident.binding_time id' <> Ident.binding_time id ->
+          Hashtbl.replace table (Ident.binding_time id') (Ident.binding_time id)
+        | Some _ | None -> ())
+      items renamed_items
+  | Mty_functor (_, _, result), Mty_functor (_, _, renamed_result) ->
+    record_renamed_stamps table result renamed_result
+  | _ -> ()
+
+(* The compiler's type of a module of this file, by its path, with
+   aliases followed. *)
+let rec module_type_of_path ~(env : Env.t) (path : Path.t) =
+  let mty =
+    match path with
+    | Pident id -> Hashtbl.find_opt env.module_types (Ident.binding_time id)
+    | Pdot (parent, name, _) -> (
+      match module_type_of_path ~env parent with
+      | Some (Types.Mty_signature items) ->
+        items
+        |> List.find_map (fun (item : Types.signature_item) ->
+            match item with
+            | Sig_module (id, md, _) when Ident.name id = name ->
+              Some md.md_type
+            | _ -> None)
+      | _ -> None)
+    | Papply _ -> None
+  in
+  match mty with
+  | Some (Types.Mty_alias (_, path)) -> module_type_of_path ~env path
+  | Some (Mty_signature _ | Mty_functor _ | Mty_ident _) | None -> mty
+
+(* Each application records its renaming steps, and a module bound to a
+   partial application and applied later continues a chain started by the
+   first application. Once the whole file is read, as its modules are read
+   from last to first, each renamed stamp is mapped to the end of its
+   chain, the declaration in the functor body. *)
+let resolve_renamed_stamps ~(env : Env.t) =
+  let table = env.renamed_stamps in
+  let rec original stamp =
+    match Hashtbl.find_opt table stamp with
+    | Some stamp -> original stamp
+    | None -> stamp
+  in
+  Hashtbl.filter_map_inplace (fun _ stamp -> Some (original stamp)) table;
+  table
+
 let get_module_type_path mod_desc =
   match mod_desc with
   | Typedtree.Tmty_ident (path, _) | Tmty_alias (path, _) -> Some path
@@ -425,6 +526,10 @@ let rec get_module_path mod_desc =
   | Tmod_functor (_ident, _argName, _maybeType, _resultExpr) -> None
   | Tmod_apply (functor_, _arg, _coercion) -> get_module_path functor_.mod_desc
   | Tmod_unpack (_expr, _moduleType) -> None
+  (* A module alias used as a functor or included is wrapped with the path
+     the compiler resolved its chain of aliases to: the module's own file. *)
+  | Tmod_constraint (_expr, _typ, _constraint, Tcoerce_alias (path, _)) ->
+    Some path
   | Tmod_constraint (expr, _typ, _constraint, _coercion) ->
     get_module_path expr.mod_desc
 
@@ -546,13 +651,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 +751,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 +769,50 @@ 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. When the argument
+       or the functor is a path, the compiler has renamed them already, so
+       each step is recorded: this renaming, the compiler's for this
+       application, and the copy a path to the functor made. 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.
+       An inline functor's parameters and declarations are registered
+       first, for uses inside its body to resolve. *)
+    ignore (for_module ~env functor_ module_name);
+    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
+    let table = env.renamed_stamps in
+    record_renamed_stamps table mod_expr.mod_type renamed;
+    (match functor_.mod_type with
+    | Mty_functor (_, _, result) ->
+      record_renamed_stamps table result mod_expr.mod_type
+    | _ -> ());
+    (match functor_.mod_desc with
+    | Tmod_ident (path, _) | Tmod_constraint (_, _, _, Tcoerce_alias (path, _))
+      -> (
+      match module_type_of_path ~env path with
+      | Some original -> record_renamed_stamps table original functor_.mod_type
+      | None -> ())
+    | _ -> ());
+    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 +829,8 @@ 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
+      Hashtbl.replace env.module_types stamp mexpr.mod_type;
+      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 []
@@ -703,6 +843,15 @@ and scan_let_modules ~env (e : Typedtree.expression) =
   iterator.expr iterator e
 
 and for_structure ~name ~env str_items =
+  (* The types of the modules, for paths to them in applications read
+     before their declarations. *)
+  str_items
+  |> List.iter (fun (item : Typedtree.structure_item) ->
+      match item.str_desc with
+      | Tstr_module {mb_id; mb_expr} ->
+        Hashtbl.replace env.module_types (Ident.binding_time mb_id)
+          mb_expr.mod_type
+      | _ -> ());
   let exported = Exported.init () in
   let items =
     List.fold_right
@@ -723,7 +872,12 @@ 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;
+      module_types = Hashtbl.create 1;
+    }
   in
   match cmt_annots with
   | Partial_implementation parts ->
@@ -737,7 +891,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 = resolve_renamed_stamps ~env;
+    }
   | Partial_interface parts ->
     let items =
       parts |> Array.to_list
@@ -749,13 +909,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 = resolve_renamed_stamps ~env;
+    }
   | 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 = resolve_renamed_stamps ~env;
+    }
   | 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 = resolve_renamed_stamps ~env;
+    }
 
 let file_for_cmt ~state ~module_name ~cmt ~uri =
   match Hashtbl.find_opt state.cmt_cache cmt with