Cleanup completion details docs (#952)

* clean up details and documentation output on completion items

* implement completionResolve LSP request and resolve file module docs async

* changelog

Author: zth

CHANGELOG.md

@@ -15,13 +15,15 @@
 #### :rocket: New Feature
 
 - Extend signature help to work on constructor payloads as well. Can be turned off if wanted through settings. https://github.com/rescript-lang/rescript-vscode/pull/947
+- Show module docs for file modules. https://github.com/rescript-lang/rescript-vscode/pull/952
 
 #### :nail_care: Polish
 
 - Enhance variant constructor payload completion. https://github.com/rescript-lang/rescript-vscode/pull/946
 - Clean occasional dots from "insert missing fields" code action. https://github.com/rescript-lang/rescript-vscode/pull/948
 - Pick up code actions in incremental compilation. https://github.com/rescript-lang/rescript-vscode/pull/948
 - Various improvements to the signature help functionality. https://github.com/rescript-lang/rescript-vscode/pull/950
+- Clean up completion item "details" and "documentation". https://github.com/rescript-lang/rescript-vscode/pull/952
 
 ## 1.48.0
 

analysis/bin/main.ml

@@ -115,6 +115,8 @@ let main () =
     Commands.completion ~debug ~path
       ~pos:(int_of_string line, int_of_string col)
       ~currentFile
+  | [_; "completionResolve"; path; modulePath] ->
+    Commands.completionResolve ~path ~modulePath
   | [_; "definition"; path; line; col] ->
     Commands.definition ~path
       ~pos:(int_of_string line, int_of_string col)

analysis/src/Commands.ml

@@ -4,13 +4,42 @@ let completion ~debug ~path ~pos ~currentFile =
       Completions.getCompletions ~debug ~path ~pos ~currentFile ~forHover:false
     with
     | None -> []
-    | Some (completions, _, _) -> completions
+    | Some (completions, full, _) ->
+      completions
+      |> List.map (CompletionBackEnd.completionToItem ~full)
+      |> List.map Protocol.stringifyCompletionItem
   in
-  print_endline
-    (completions
-    |> List.map CompletionBackEnd.completionToItem
-    |> List.map Protocol.stringifyCompletionItem
-    |> Protocol.array)
+  completions |> Protocol.array |> print_endline
+
+let completionResolve ~path ~modulePath =
+  (* We ignore the internal module path as of now because there's currently
+     no use case for it. But, if we wanted to move resolving documentation
+     for regular modules and not just file modules to the completionResolve
+     hook as well, it'd be easy to implement here. *)
+  let moduleName, _innerModulePath =
+    match modulePath |> String.split_on_char '.' with
+    | [moduleName] -> (moduleName, [])
+    | moduleName :: rest -> (moduleName, rest)
+    | [] -> raise (Failure "Invalid module path.")
+  in
+  let docstring =
+    match Cmt.loadFullCmtFromPath ~path with
+    | None ->
+      if Debug.verbose () then
+        Printf.printf "[completion_resolve] Could not load cmt\n";
+      Protocol.null
+    | Some full -> (
+      match ProcessCmt.fileForModule ~package:full.package moduleName with
+      | None ->
+        if Debug.verbose () then
+          Printf.printf "[completion_resolve] Did not find file for module %s\n"
+            moduleName;
+        Protocol.null
+      | Some file ->
+        file.structure.docstring |> String.concat "\n\n"
+        |> Protocol.wrapInQuotes)
+  in
+  print_endline docstring
 
 let inlayhint ~path ~pos ~maxLength ~debug =
   let result =
@@ -321,6 +350,11 @@ let test ~path =
             let currentFile = createCurrentFile () in
             completion ~debug:true ~path ~pos:(line, col) ~currentFile;
             Sys.remove currentFile
+          | "cre" ->
+            let modulePath = String.sub rest 3 (String.length rest - 3) in
+            let modulePath = String.trim modulePath in
+            print_endline ("Completion resolve: " ^ modulePath);
+            completionResolve ~path ~modulePath
           | "dce" ->
             print_endline ("DCE " ^ path);
             Reanalyze.RunConfig.runConfig.suppress <- ["src"];

analysis/src/CompletionBackEnd.ml

@@ -79,7 +79,7 @@ let completionForExporteds iterExported getDeclared ~prefix ~exact ~env
           res :=
             {
               (Completion.create declared.name.txt ~env
-                 ~kind:(transformContents declared.item))
+                 ~kind:(transformContents declared))
               with
               deprecated = declared.deprecated;
               docstring = declared.docstring;
@@ -90,18 +90,20 @@ let completionForExporteds iterExported getDeclared ~prefix ~exact ~env
 
 let completionForExportedModules ~env ~prefix ~exact ~namesUsed =
   completionForExporteds (Exported.iter env.QueryEnv.exported Exported.Module)
-    (Stamps.findModule env.file.stamps) ~prefix ~exact ~env ~namesUsed (fun m ->
-      Completion.Module m)
+    (Stamps.findModule env.file.stamps) ~prefix ~exact ~env ~namesUsed
+    (fun declared ->
+      Completion.Module
+        {docstring = declared.docstring; module_ = declared.item})
 
 let completionForExportedValues ~env ~prefix ~exact ~namesUsed =
   completionForExporteds (Exported.iter env.QueryEnv.exported Exported.Value)
-    (Stamps.findValue env.file.stamps) ~prefix ~exact ~env ~namesUsed (fun v ->
-      Completion.Value v)
+    (Stamps.findValue env.file.stamps) ~prefix ~exact ~env ~namesUsed
+    (fun declared -> Completion.Value declared.item)
 
 let completionForExportedTypes ~env ~prefix ~exact ~namesUsed =
   completionForExporteds (Exported.iter env.QueryEnv.exported Exported.Type)
-    (Stamps.findType env.file.stamps) ~prefix ~exact ~env ~namesUsed (fun t ->
-      Completion.Type t)
+    (Stamps.findType env.file.stamps) ~prefix ~exact ~env ~namesUsed
+    (fun declared -> Completion.Type declared.item)
 
 let completionsForExportedConstructors ~(env : QueryEnv.t) ~prefix ~exact
     ~namesUsed =
@@ -224,39 +226,109 @@ let getEnvWithOpens ~scope ~(env : QueryEnv.t) ~package
       | None -> None
       | Some env -> ResolvePath.resolvePath ~env ~package ~path))
 
+let rec expandTypeExpr ~env ~package typeExpr =
+  match typeExpr |> Shared.digConstructor with
+  | Some path -> (
+    match References.digConstructor ~env ~package path with
+    | None -> None
+    | Some (env, {item = {decl = {type_manifest = Some t}}}) ->
+      expandTypeExpr ~env ~package t
+    | Some (_, {docstring; item}) -> Some (docstring, item))
+  | None -> None
+
+let kindToDocumentation ~env ~full ~currentDocstring name
+    (kind : Completion.kind) =
+  let docsFromKind =
+    match kind with
+    | ObjLabel _ | Label _ | FileModule _ | Snippet _ | FollowContextPath _ ->
+      []
+    | Module {docstring} -> docstring
+    | Type {decl; name} ->
+      [decl |> Shared.declToString name |> Markdown.codeBlock]
+    | Value typ -> (
+      match expandTypeExpr ~env ~package:full.package typ with
+      | None -> []
+      | Some (docstrings, {decl; name; kind}) ->
+        docstrings
+        @ [
+            (match kind with
+            | Record _ | Tuple _ | Variant _ ->
+              Markdown.codeBlock (Shared.declToString name decl)
+            | _ -> "");
+          ])
+    | Field ({typ; optional; docstring}, s) ->
+      (* Handle optional fields. Checking for "?" is because sometimes optional
+         fields are prefixed with "?" when completing, and at that point we don't
+         need to _also_ add a "?" after the field name, as that looks weird. *)
+      docstring
+      @ [
+          Markdown.codeBlock
+            (if optional && Utils.startsWith name "?" = false then
+               name ^ "?: "
+               ^ (typ |> Utils.unwrapIfOption |> Shared.typeToString)
+             else name ^ ": " ^ (typ |> Shared.typeToString));
+          Markdown.codeBlock s;
+        ]
+    | Constructor (c, s) ->
+      [Markdown.codeBlock (showConstructor c); Markdown.codeBlock s]
+    | PolyvariantConstructor ({displayName; args}, s) ->
+      [
+        Markdown.codeBlock
+          ("#" ^ displayName
+          ^
+          match args with
+          | [] -> ""
+          | typeExprs ->
+            "("
+            ^ (typeExprs
+              |> List.map (fun typeExpr -> typeExpr |> Shared.typeToString)
+              |> String.concat ", ")
+            ^ ")");
+        Markdown.codeBlock s;
+      ]
+    | ExtractedType (extractedType, _) ->
+      [Markdown.codeBlock (TypeUtils.extractedTypeToString extractedType)]
+  in
+  currentDocstring @ docsFromKind
+  |> List.filter (fun s -> s <> "")
+  |> String.concat "\n\n"
+
 let kindToDetail name (kind : Completion.kind) =
   match kind with
-  | Type {decl} -> decl |> Shared.declToString name
+  | Type {name} -> "type " ^ name
   | Value typ -> typ |> Shared.typeToString
   | ObjLabel typ -> typ |> Shared.typeToString
   | Label typString -> typString
-  | Module _ -> "module"
-  | FileModule _ -> "file module"
-  | Field ({typ; optional}, s) ->
+  | Module _ -> "module " ^ name
+  | FileModule f -> "module " ^ f
+  | Field ({typ; optional}, _) ->
     (* Handle optional fields. Checking for "?" is because sometimes optional
        fields are prefixed with "?" when completing, and at that point we don't
        need to _also_ add a "?" after the field name, as that looks weird. *)
     if optional && Utils.startsWith name "?" = false then
-      name ^ "?: "
-      ^ (typ |> Utils.unwrapIfOption |> Shared.typeToString)
-      ^ "\n\n" ^ s
-    else name ^ ": " ^ (typ |> Shared.typeToString) ^ "\n\n" ^ s
-  | Constructor (c, s) -> showConstructor c ^ "\n\n" ^ s
-  | PolyvariantConstructor ({displayName; args}, s) ->
+      typ |> Utils.unwrapIfOption |> Shared.typeToString
+    else typ |> Shared.typeToString
+  | Constructor (c, _) -> showConstructor c
+  | PolyvariantConstructor ({displayName; args}, _) -> (
     "#" ^ displayName
-    ^ (match args with
-      | [] -> ""
-      | typeExprs ->
-        "("
-        ^ (typeExprs
-          |> List.map (fun typeExpr -> typeExpr |> Shared.typeToString)
-          |> String.concat ", ")
-        ^ ")")
-    ^ "\n\n" ^ s
+    ^
+    match args with
+    | [] -> ""
+    | typeExprs ->
+      "("
+      ^ (typeExprs
+        |> List.map (fun typeExpr -> typeExpr |> Shared.typeToString)
+        |> String.concat ", ")
+      ^ ")")
   | Snippet s -> s
   | FollowContextPath _ -> ""
   | ExtractedType (extractedType, _) ->
-    TypeUtils.extractedTypeToString extractedType
+    TypeUtils.extractedTypeToString ~nameOnly:true extractedType
+
+let kindToData filePath (kind : Completion.kind) =
+  match kind with
+  | FileModule f -> Some [("modulePath", f); ("filePath", filePath)]
+  | _ -> None
 
 let findAllCompletions ~(env : QueryEnv.t) ~prefix ~exact ~namesUsed
     ~(completionContext : Completable.completionContext) =
@@ -366,7 +438,9 @@ let processLocalModule name loc ~prefix ~exact ~env
         localTables.resultRev <-
           {
             (Completion.create declared.name.txt ~env
-               ~kind:(Module declared.item))
+               ~kind:
+                 (Module
+                    {docstring = declared.docstring; module_ = declared.item}))
             with
             deprecated = declared.deprecated;
             docstring = declared.docstring;
@@ -579,7 +653,7 @@ let rec digToRecordFieldsForCompletion ~debug ~package ~opens ~full ~pos ~env
   | {kind = Type {kind = Record fields}} :: _ -> Some fields
   | _ -> None
 
-let mkItem ~name ~kind ~detail ~deprecated ~docstring =
+let mkItem ?data name ~kind ~detail ~deprecated ~docstring =
   let docContent =
     (match deprecated with
     | None -> ""
@@ -607,6 +681,7 @@ let mkItem ~name ~kind ~detail ~deprecated ~docstring =
       insertText = None;
       insertTextFormat = None;
       filterText = None;
+      data;
     }
 
 let completionToItem
@@ -620,16 +695,23 @@ let completionToItem
       insertTextFormat;
       filterText;
       detail;
-    } =
+      env;
+    } ~full =
   let item =
-    mkItem ~name
+    mkItem name
+      ?data:(kindToData (full.file.uri |> Uri.toPath) kind)
       ~kind:(Completion.kindToInt kind)
       ~deprecated
       ~detail:
         (match detail with
         | None -> kindToDetail name kind
         | Some detail -> detail)
-      ~docstring
+      ~docstring:
+        (match
+           kindToDocumentation ~currentDocstring:docstring ~full ~env name kind
+         with
+        | "" -> []
+        | docstring -> [docstring])
   in
   {item with sortText; insertText; insertTextFormat; filterText}
 

analysis/src/Protocol.ml

@@ -50,6 +50,7 @@ type completionItem = {
   insertTextFormat: insertTextFormat option;
   insertText: string option;
   documentation: markupContent option;
+  data: (string * string) list option;
 }
 
 type location = {uri: string; range: range}
@@ -139,6 +140,14 @@ let stringifyCompletionItem c =
         | None -> None
         | Some insertTextFormat ->
           Some (Printf.sprintf "%i" (insertTextFormatToInt insertTextFormat)) );
+      ( "data",
+        match c.data with
+        | None -> None
+        | Some fields ->
+          Some
+            (fields
+            |> List.map (fun (key, value) -> (key, Some (wrapInQuotes value)))
+            |> stringifyObject ~indentation:2) );
     ]
 
 let stringifyHover value =

analysis/src/SharedTypes.ml

@@ -775,7 +775,7 @@ end
 
 module Completion = struct
   type kind =
-    | Module of Module.t
+    | Module of {docstring: string list; module_: Module.t}
     | Value of Types.type_expr
     | ObjLabel of Types.type_expr
     | Label of string
@@ -800,10 +800,11 @@ module Completion = struct
     kind: kind;
     detail: string option;
     typeArgContext: typeArgContext option;
+    data: (string * string) list option;
   }
 
-  let create ?typeArgContext ?(includesSnippets = false) ?insertText ~kind ~env
-      ?sortText ?deprecated ?filterText ?detail ?(docstring = []) name =
+  let create ?data ?typeArgContext ?(includesSnippets = false) ?insertText ~kind
+      ~env ?sortText ?deprecated ?filterText ?detail ?(docstring = []) name =
     {
       name;
       env;
@@ -817,6 +818,7 @@ module Completion = struct
       filterText;
       detail;
       typeArgContext;
+      data;
     }
 
   (* https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_completion *)