Show a functor's parameters on hover

analysis/src/hover.ml

@@ -2,7 +2,7 @@ open Shared_types
 
 module String_set = Set.Make (String)
 
-let show_module_top_level ~docstring ~is_type ~name
+let show_module_top_level ?(functor_params = []) ~docstring ~is_type ~name
     (top_level : Module.item list) =
   let contents =
     top_level
@@ -22,6 +22,9 @@ let show_module_top_level ~docstring ~is_type ~name
     Markdown.code_block
       ("module "
       ^ (if is_type then "type " ^ name ^ " = " else name ^ ": ")
+      ^ (match functor_params with
+        | [] -> ""
+        | params -> "(" ^ String.concat ", " params ^ ") => ")
       ^ "{" ^ "\n" ^ contents ^ "\n}")
   in
   let doc =
@@ -39,13 +42,13 @@ let rec show_module ~state ~docstring ~(file : File.t) ~package ~name
   match declared with
   | None ->
     show_module_top_level ~docstring ~is_type:false ~name file.structure.items
-  | Some {item = Structure {items}; module_path} ->
+  | Some {item = Structure {items; functor_params}; module_path} ->
     let is_type =
       match module_path with
       | ExportedModule {is_type} -> is_type
       | _ -> false
     in
-    show_module_top_level ~docstring ~is_type ~name items
+    show_module_top_level ~functor_params ~docstring ~is_type ~name items
   | Some ({item = Constraint (_moduleItem, module_type_item)} as declared) ->
     (* show the interface *)
     show_module ~state ~docstring ~file ~name ~package

analysis/src/process_cmt.ml

@@ -35,6 +35,35 @@ let map_record_field {Types.ld_id; ld_type; ld_attributes; ld_optional} =
     deprecated = Process_attributes.find_deprecated_attribute ld_attributes;
   }
 
+(* A functor parameter's module type, on one line for hover. *)
+let module_type_to_string (mty : Types.module_type) =
+  match mty with
+  | Mty_ident path | Mty_alias (_, path) -> Printtyp.string_of_path path
+  | Mty_signature signature ->
+    let items =
+      Printtyp.tree_of_signature signature
+      |> List.map (fun item ->
+          Res_outcome_printer.print_out_sig_item_doc item
+          |> Res_doc.to_string ~width:Res_printer.default_print_width)
+    in
+    "{" ^ String.concat "; " items ^ "}"
+  | Mty_functor _ -> "{...}"
+
+(* A functor parameter as hover shows it, such as [O: Ord]; a generative
+   functor's [*] parameter shows as nothing, giving [() => ...]. *)
+let functor_param ~name (mty : Types.module_type option) =
+  match (name, mty) with
+  | "*", _ -> ""
+  | _, None -> name
+  | _, Some mty -> name ^ ": " ^ module_type_to_string mty
+
+let rec add_functor_param param (m : Module.t) : Module.t =
+  match m with
+  | Structure s -> Structure {s with functor_params = param :: s.functor_params}
+  | Constraint (m1, m2) ->
+    Constraint (add_functor_param param m1, add_functor_param param m2)
+  | Ident _ -> m
+
 let rec for_type_signature_item ~(env : Shared_types.Env.t)
     ~(exported : Exported.t) (item : Types.signature_item) =
   match item with
@@ -174,16 +203,24 @@ and for_type_signature ~name ~env signature =
       (fun item items -> for_type_signature_item ~env ~exported item @ items)
       signature []
   in
-  {Module.name; docstring = []; exported; items; deprecated = None}
+  {
+    Module.name;
+    docstring = [];
+    exported;
+    items;
+    deprecated = None;
+    functor_params = [];
+  }
 
 and for_type_module ~name ~env module_type =
   match module_type with
   | Types.Mty_ident path -> Ident path
   | Mty_alias (_ (* 402 *), path) -> Ident path
   | Mty_signature signature ->
     Structure (for_type_signature ~name ~env signature)
-  | Mty_functor (_argIdent, _argType, result_type) ->
+  | Mty_functor (arg_ident, arg_type, result_type) ->
     for_type_module ~name ~env result_type
+    |> add_functor_param (functor_param ~name:(Ident.name arg_ident) arg_type)
 
 (* Stamps given to renamed identifiers start here, far above the stamps
    in a typed tree, so that they never meet one of them. *)
@@ -453,7 +490,7 @@ let for_signature ~name ~env sig_items =
   in
   let docstring = attrs_to_docstring attributes in
   let deprecated = Process_attributes.find_deprecated_attribute attributes in
-  {Module.name; docstring; exported; items; deprecated}
+  {Module.name; docstring; exported; items; deprecated; functor_params = []}
 
 let rec get_module_path mod_desc =
   match mod_desc with
@@ -701,7 +738,11 @@ and for_module ~env (mod_expr : Typedtree.module_expr) module_name =
           ~extent:arg_name.loc ~stamp ~module_path:NotVisible false []
       in
       Stamps.add_module env.stamps stamp declared);
-    for_module ~env result_expr module_name
+    let param =
+      functor_param ~name:arg_name.txt
+        (Option.map (fun (t : Typedtree.module_type) -> t.mty_type) maybe_type)
+    in
+    for_module ~env result_expr module_name |> add_functor_param param
   | Tmod_apply (functor_, _arg, _coercion) ->
     (* The functor's body has the parameter's types; the application's
        signature has the argument's. Its items keep the identifiers of the
@@ -779,7 +820,7 @@ and for_structure ~name ~env str_items =
   in
   let docstring = attrs_to_docstring attributes in
   let deprecated = Process_attributes.find_deprecated_attribute attributes in
-  {Module.name; docstring; exported; items; deprecated}
+  {Module.name; docstring; exported; items; deprecated; functor_params = []}
 
 let file_for_cmt_infos ~module_name ~uri
     ({cmt_modname; cmt_annots} : Cmt_format.cmt_infos) =

analysis/src/shared_types.ml

@@ -148,6 +148,8 @@ module Module = struct
     exported: Exported.t;
     items: item list;
     deprecated: string option;
+    functor_params: string list;
+        (** the parameters, such as [O: Ord], when this is a functor's result *)
   }
 
   and t = Ident of Path.t | Structure of structure | Constraint of t * t
@@ -290,6 +292,7 @@ module File = struct
           exported = Exported.init ();
           items = [];
           deprecated = None;
+          functor_params = [];
         };
     }
 end

changes/functor-hover-params.fix.md

@@ -0,0 +1 @@
+- Hover on a functor shows its parameters, such as `module MakeSet: (O: Ord) => {...}`, instead of only its body.

tests/analysis_tests/tests/src/HoverFunctor.res

@@ -0,0 +1,40 @@
+module type Ord = {
+  type t
+  let compare: (t, t) => int
+}
+
+module MakeSet = (O: Ord) => {
+  //     ^hov
+  type t = array<O.t>
+  let add = (s: t, x: O.t) => s->Array.concat([x])
+}
+
+module Pair = (A: Ord, B: Ord) => {
+  //   ^hov
+  type t = (A.t, B.t)
+}
+
+module Inline = (X: {
+  //     ^hov
+  let x: int
+}) => {
+  let y = X.x
+}
+
+module IntOrd = {
+  type t = int
+  let compare = (a: int, b) => a - b
+}
+
+// An applied functor is a plain module
+module IntSet = MakeSet(IntOrd)
+//      ^hov
+
+// A partially applied functor keeps its remaining parameter
+module PairInt = Pair(IntOrd)
+//      ^hov
+
+module Counter = () => {
+  //     ^hov
+  let count = ref(0)
+}

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

@@ -0,0 +1,48 @@
+Hover src/HoverFunctor.res 5:9
+{
+  "contents": {
+    "kind": "markdown",
+    "value": "```rescript\nmodule MakeSet: (O: Ord) => {\n  type t = array<O.t>\n  let add: (t, O.t) => array<O.t>\n}\n```"
+  }
+}
+
+Hover src/HoverFunctor.res 11:7
+{
+  "contents": {
+    "kind": "markdown",
+    "value": "```rescript\nmodule Pair: (A: Ord, B: Ord) => {\n  type t = (A.t, B.t)\n}\n```"
+  }
+}
+
+Hover src/HoverFunctor.res 16:9
+{
+  "contents": {
+    "kind": "markdown",
+    "value": "```rescript\nmodule Inline: (X: {let x: int}) => {\n  let y: int\n}\n```"
+  }
+}
+
+Hover src/HoverFunctor.res 29:8
+{
+  "contents": {
+    "kind": "markdown",
+    "value": "```rescript\nmodule IntSet: {\n  type t = array<IntOrd.t>\n  let add: (t, IntOrd.t) => array<IntOrd.t>\n}\n```"
+  }
+}
+
+Hover src/HoverFunctor.res 33:8
+{
+  "contents": {
+    "kind": "markdown",
+    "value": "```rescript\nmodule PairInt: (B: Ord) => {\n  type t = (IntOrd.t, B.t)\n}\n```"
+  }
+}
+
+Hover src/HoverFunctor.res 36:9
+{
+  "contents": {
+    "kind": "markdown",
+    "value": "```rescript\nmodule Counter: () => {\n  let count: ref<int>\n}\n```"
+  }
+}
+