Show docstrings before type expansions in hover popups

analysis/src/Hover.ml

@@ -107,7 +107,7 @@ let expandTypes ~file ~package ~supportsMarkdownLinks typ =
   | {decl; path} :: _
     when Res_parsetree_viewer.has_inline_record_definition_attribute
            decl.type_attributes ->
-    (* We print inline record types just with their definition, not the constr pointing 
+    (* We print inline record types just with their definition, not the constr pointing
     to them, since that doesn't make sense to show the user. *)
     ( [
         Markdown.codeBlock
@@ -118,13 +118,12 @@ let expandTypes ~file ~package ~supportsMarkdownLinks typ =
       `InlineType )
   | all ->
     let typesSeen = ref StringSet.empty in
-    let typeId ~(env : QueryEnv.t) ~name =
-      env.file.moduleName :: List.rev (name :: env.pathRev) |> String.concat "."
-    in
     ( all
       (* Don't produce duplicate type definitions for recursive types *)
-      |> List.filter (fun {env; name} ->
-             let typeId = typeId ~env ~name in
+      |> List.filter (fun {env; name; loc} ->
+             let typeId =
+               TypeUtils.typeId ~env ~name:(Location.mkloc name loc)
+             in
              if StringSet.mem typeId !typesSeen then false
              else (
                typesSeen := StringSet.add typeId !typesSeen;
@@ -150,22 +149,54 @@ let expandTypes ~file ~package ~supportsMarkdownLinks typ =
       `Default )
 
 (* Produces a hover with relevant types expanded in the main type being hovered. *)
-let hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks ?constructor
-    typ =
-  let expandedTypes, expansionType =
-    expandTypes ~file ~package ~supportsMarkdownLinks typ
+let hoverWithExpandedTypes ~(full : SharedTypes.full) ~file ~package ?docstring
+    ~supportsMarkdownLinks ?constructor typ =
+  (* TODO: figure out why this is not returning expanded types *)
+  let {TypeUtils.ExpandType.mainTypes; relatedTypes} =
+    TypeUtils.ExpandType.expandTypes ~full
+      (TypeUtils.ExpandType.TypeExpr
+         {typeExpr = typ; (* TODO *) name = None; env = QueryEnv.fromFile file})
+  in
+
+  (* TODO: wrap in markdown code blocks and render links if `supportsMarkdownLinks` (but not for inline records) *)
+  let expandedTypesToString
+      (expandedTypes : TypeUtils.ExpandType.expandTypeInput list) =
+    expandedTypes
+    |> List.map (fun input ->
+           match input with
+           | TypeUtils.ExpandType.TypeExpr {typeExpr} ->
+             Shared.typeToString typeExpr
+           | TypeUtils.ExpandType.TypeDecl {name; typeDecl} ->
+             Shared.declToString name.txt typeDecl)
+    |> List.map Markdown.codeBlock
   in
-  match expansionType with
-  | `Default ->
-    let typeString = Shared.typeToString typ in
-    let typeString =
-      match constructor with
-      | Some constructor ->
-        typeString ^ "\n" ^ CompletionBackEnd.showConstructor constructor
-      | None -> typeString
+
+  let mainTypes =
+    let insert_constructor constructor mainTypes =
+      match mainTypes with
+      | [] -> [constructor]
+      | h :: t -> h :: constructor :: t
     in
-    Markdown.codeBlock typeString :: expandedTypes |> String.concat "\n"
-  | `InlineType -> expandedTypes |> String.concat "\n"
+    match constructor with
+    | Some constructor ->
+      let constructor =
+        (CompletionBackEnd.showConstructor constructor |> Markdown.codeBlock)
+        ^ Markdown.divider
+      in
+      insert_constructor constructor (expandedTypesToString mainTypes)
+    | None -> expandedTypesToString mainTypes
+  in
+
+  let hoverMarkdown = mainTypes |> String.concat "\n" in
+  let hoverMarkdown =
+    match docstring with
+    | Some docstring -> hoverMarkdown ^ "\n" ^ (docstring |> String.concat "\n")
+    | None -> hoverMarkdown
+  in
+  if List.is_empty relatedTypes then hoverMarkdown
+  else
+    hoverMarkdown ^ "\n"
+    ^ (expandedTypesToString relatedTypes |> String.concat Markdown.divider)
 
 (* Leverages autocomplete functionality to produce a hover for a position. This
    makes it (most often) work with unsaved content. *)
@@ -191,10 +222,10 @@ let getHoverViaCompletions ~debug ~path ~pos ~currentFile ~forHover
       with
       | Some (typ, _env) ->
         let typeString =
-          hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks typ
+          hoverWithExpandedTypes ~full ~file ~package ~docstring
+            ~supportsMarkdownLinks typ
         in
-        let parts = docstring @ [typeString] in
-        Some (Protocol.stringifyHover (String.concat "\n\n" parts))
+        Some (Protocol.stringifyHover typeString)
       | None -> None)
     | {env} :: _ -> (
       let opens = CompletionBackEnd.getOpens ~debug ~rawOpens ~package ~env in
@@ -204,13 +235,14 @@ let getHoverViaCompletions ~debug ~path ~pos ~currentFile ~forHover
       with
       | Some (typ, _env) ->
         let typeString =
-          hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks typ
+          hoverWithExpandedTypes ~full ~file ~package ~supportsMarkdownLinks typ
         in
         Some (Protocol.stringifyHover typeString)
       | None -> None)
     | _ -> None)
 
-let newHover ~full:{file; package} ~supportsMarkdownLinks locItem =
+let newHover ~full ~supportsMarkdownLinks locItem =
+  let {file; package} = full in
   match locItem.locType with
   | TypeDefinition (name, decl, _stamp) -> (
     let typeDef = Markdown.codeBlock (Shared.declToString name decl) in
@@ -277,22 +309,16 @@ let newHover ~full:{file; package} ~supportsMarkdownLinks locItem =
          | Const_int64 _ -> "int64"
          | Const_bigint _ -> "bigint"))
   | Typed (_, t, locKind) ->
-    let fromType ?constructor typ =
-      hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks ?constructor
-        typ
-    in
-    let parts =
-      match References.definedForLoc ~file ~package locKind with
+    Some
+      (match References.definedForLoc ~file ~package locKind with
       | None ->
-        let typeString = t |> fromType in
-        [typeString]
+        hoverWithExpandedTypes ~full ~file ~package ~supportsMarkdownLinks t
       | Some (docstring, res) -> (
+        let fromType ?docstring ?constructor typ =
+          hoverWithExpandedTypes ~full ~file ~package ~supportsMarkdownLinks
+            ?docstring ?constructor typ
+        in
         match res with
-        | `Declared | `Field ->
-          let typeString = t |> fromType in
-          typeString :: docstring
+        | `Declared | `Field -> t |> fromType ~docstring
         | `Constructor constructor ->
-          let typeString = t |> fromType ~constructor in
-          typeString :: constructor.docstring)
-    in
-    Some (String.concat Markdown.divider parts)
+          t |> fromType ~docstring:constructor.docstring ~constructor))