OCaml: Add type enclosing (#4741)

* OCaml: Add type enclosing and documentation

This also creates a transient keymap allowing to:

- increase/decrease the verbosity of the displayed type
- copy the computed type
- Increase/Decrease index
- Show the region that is currently being typed

* OCaml: Remove previous function that allowed to retrieve only the signature

This function was useful because textDocument/hover returned the type and
documentation of the identifier at point making it hard to kill the type only

Now that ocamllsp/typeEnclosing is used instead there is no reason to keep this
poorly written function (I was young and innocent)

* OCaml: Add information in the manual language docs for OCaml

CHANGELOG updated

Author: mattiasdrp

CHANGELOG.org

@@ -35,6 +35,7 @@
   * Add support for [[https://github.com/c3lang/c3c][c3 language]] (requires [[https://github.com/c3lang/c3-ts-mode][c3-ts-mode]] and [[https://github.com/pherrymason/c3-lsp][c3lsp]]).    
   * Drop support for emacs 27.1 and 27.2
   * Add ~lsp-nix-nixd-server-arguments~ to allow passing arguments to the ~nixd~ LSP.
+  * Improve the lsp-ocaml client (see [[https://github.com/emacs-lsp/lsp-mode/issues/4731][#4731]] for the follow-up issue. MRs: [[https://github.com/emacs-lsp/lsp-mode/pull/4741][#4741]], [[https://github.com/emacs-lsp/lsp-mode/pull/4732][#4732]])
 
 ** 9.0.0
   * Add language server config for QML (Qt Modeling Language) using qmlls.

clients/lsp-ocaml.el

@@ -88,51 +88,28 @@
   :type '(choice (symbol :tag "Default behaviour" 'cut)
                  (symbol :tag "Display all the lines with spaces" 'space)))
 
-(cl-defmethod lsp-clients-extract-signature-on-hover (contents (_server-id (eql ocaml-lsp-server)) &optional storable)
-  "Extract a representative line from OCaml's CONTENTS, to show in the echo area.
-This function splits the content between the signature
-and the documentation to display the signature
-and truncate it if it's too wide.
-The STORABLE argument is used if you want to use this
-function to get the type and, for example, kill and yank it.
-
-An example of function using STORABLE is:
-
-  (defun mdrp/lsp-get-type-and-kill ()
-    (interactive)
-    (let ((contents (-some->> (lsp--text-document-position-params)
-                    (lsp--make-request \"textDocument/hover\")
-                    (lsp--send-request)
-                    (lsp:hover-contents))))
-      (let ((contents (and contents
-                    (lsp--render-on-hover-content
-                     contents
-                     t))))
-        (let ((contents
-               (pcase (lsp-workspaces)
-                 (`(,workspace)
-                  (lsp-clients-extract-signature-on-hover
-                   contents
-                   (lsp--workspace-server-id workspace)
-                   t))
-                 (lsp-clients-extract-signature-on-hover
-                   contents
-                   nil)
-                 )))
-          (message \"Copied %s to kill-ring\" contents)
-          (kill-new contents)))))"
-  (let ((type (s-trim (lsp--render-element (lsp-make-marked-string
-                                            :language "ocaml"
-                                            :value (car (s-split "---" (lsp--render-element contents))))))))
-    (if (equal nil storable)
-        (if (eq lsp-cut-signature 'cut)
-            (car (s-lines type))
-          ;; else lsp-cut-signature is 'space
-          (let ((ntype (s-replace "\n" " " type)))
-            (if (>= (length ntype) (frame-width))
-                (concat (substring ntype 0 (- (frame-width) 4)) "...")
-              ntype)))
-      type)))
+(defcustom lsp-ocaml-markupkind 'markdown
+  "Preferred markup format."
+  :group 'lsp-ocaml-lsp-server
+  :type '(choice (symbol :tag "Markdown" 'markdown)
+                 (symbol :tag "Plain text" 'plaintext)))
+
+(defcustom lsp-ocaml-enclosing-type-verbosity 1
+  "Number of expansions of aliases in answers."
+  :group 'lsp-ocaml-lsp-server
+  :type 'int)
+
+(defcustom lsp-ocaml-enclosing-type-cycle nil
+  "When growing up or down the enclosings of a type, cycle when reaching one bound."
+  :group 'lsp-ocaml-server
+  :type 'boolean)
+
+;;; -------------------
+;;; OCaml-lsp faces
+;;; -------------------
+
+(defface lsp-ocaml-highlight-region-face '((t (:inherit region)))
+  "Face used to highlight a region.")
 
 ;;; -------------------
 ;;; OCaml-lsp extensions interface
@@ -151,12 +128,42 @@ https://github.com/ocaml/ocaml-lsp/blob/master/ocaml-lsp-server/docs/ocamllsp/sw
       uris
     (lsp--warn "Your version of ocaml-lsp doesn't support the switchImplIntf extension")))
 
+(defun lsp-ocaml--type-enclosing (verbosity index)
+  "Get the type of the identifier at point.
+
+VERBOSITY and INDEX use is described in the OCaml-lsp protocol documented here
+https://github.com/ocaml/ocaml-lsp/blob/master/ocaml-lsp-server/docs/ocamllsp/typeEnclosing-spec.md"
+  (-if-let* ((params (lsp-make-ocaml-lsp-type-enclosing-params
+                      :uri (lsp--buffer-uri)
+                      :at (lsp--cur-position)
+                      :index index
+                      :verbosity verbosity))
+             (result (lsp-request "ocamllsp/typeEnclosing" params)))
+      result
+    (lsp--warn "Your version of ocaml-lsp doesn't support the typeEnclosing extension")))
+
+(defun lsp-ocaml--get-documentation (identifier content-format)
+  "Get the documentation of IDENTIFIER or the identifier at point if IDENTIFIER is nil.
+
+CONTENT-FORMAT is `Markdown' or `Plaintext'.
+OCaml-lsp protocol documented here
+https://github.com/ocaml/ocaml-lsp/blob/master/ocaml-lsp-server/docs/ocamllsp/getDocumentation-spec.md"
+  (-if-let* ((position (if identifier nil (lsp--cur-position)))
+             ((&TextDocumentPositionParams :text-document :position) (lsp--text-document-position-params identifier position))
+             (params (lsp-make-ocaml-lsp-get-documentation-params
+                      :textDocument text-document
+                      :position position
+                      :contentFormat content-format)))
+      ;; Don't exit if the request returns nil, an identifier can have no documentation
+      (lsp-request "ocamllsp/getDocumentation" params)
+    (lsp--warn "Your version of ocaml-lsp doesn't support the getDocumentation extension")))
+
 ;;; -------------------
 ;;; OCaml-lsp general utilities
 ;;; -------------------
 
 (defun lsp-ocaml--has-one-element-p (lst)
-  "Returns t if LST contains only one element."
+  "Return t if LST is a singleton."
   (and lst (= (length lst) 1)))
 
 ;;; -------------------
@@ -193,6 +200,128 @@ If OTHER-WINDOW is not nil, open the buffer in an other window."
              (selected-file (completing-read "Choose an alternate file " filenames)))
         (nth (cl-position selected-file filenames :test #'string=) uris)))))
 
+;;; -------------------
+;;; OCaml-lsp type enclosing utilities
+;;; ------------------
+
+(defvar-local lsp-ocaml--type-enclosing-verbosity lsp-ocaml-enclosing-type-verbosity)
+(defvar-local lsp-ocaml--type-enclosing-index 0)
+(defvar-local lsp-ocaml--type-enclosing-saved-type nil)
+(defvar-local lsp-ocaml--type-enclosing-type-enclosings nil)
+
+(defun lsp-ocaml--init-type-enclosing-config ()
+  "Create a new config for the type enclosing requests."
+  (setq lsp-ocaml--type-enclosing-verbosity lsp-ocaml-enclosing-type-verbosity)
+  (setq lsp-ocaml--type-enclosing-index 0)
+  (setq lsp-ocaml--type-enclosing-saved-type nil)
+  (setq lsp-ocaml--type-enclosing-type-enclosings nil))
+
+(defun lsp-ocaml--highlight-current-type (range)
+  "Highlight RANGE.
+
+RANGE is (:start (:character .. :line ..)) :end (:character .. :line ..)"
+  (remove-overlays nil nil 'face 'lsp-ocaml-highlight-region-face)
+  (let* ((point-min (lsp--position-to-point (cl-getf range :start)))
+         (point-max (lsp--position-to-point (cl-getf range :end)))
+         (overlay (make-overlay point-min point-max)))
+    (overlay-put overlay 'face 'lsp-ocaml-highlight-region-face)
+    (unwind-protect (sit-for 10) (delete-overlay overlay))))
+
+(defun lsp-ocaml--display-type (markupkind type doc)
+  "Display TYPE in MARKUPKIND with its DOC attached.
+
+If TYPE is a single-line that represents a module type, reformat it."
+  (let* (;; Regroup the type and documentation at point
+         (single-linep (not (string-match-p "\n" type)))
+         (new-type (if single-linep (string-replace " val " "\n  val " type) type))
+         (new-type (if single-linep (string-replace " end" "\nend" new-type) type))
+         (contents `(:kind ,markupkind
+                           :value ,(mapconcat #'identity `("```ocaml" ,new-type "```" "***" ,doc) "\n"))))
+    (lsp--display-contents contents)))
+
+;;; -------------------
+;;; OCaml-lsp type enclosing transient map
+;;; -------------------
+
+(defvar lsp-ocaml-type-enclosing-map
+  (let ((keymap (make-sparse-keymap)))
+    (define-key keymap (kbd "C-<up>") #'lsp-ocaml-type-enclosing-go-up)
+    (define-key keymap (kbd "C-<down>") #'lsp-ocaml-type-enclosing-go-down)
+    (define-key keymap (kbd "C-w") #'lsp-ocaml-type-enclosing-copy)
+    (define-key keymap (kbd "C-t") #'lsp-ocaml-type-enclosing-increase-verbosity)
+    (define-key keymap (kbd "C-<right>") #'lsp-ocaml-type-enclosing-increase-verbosity)
+    (define-key keymap (kbd "C-<left>") #'lsp-ocaml-type-enclosing-decrease-verbosity)
+    keymap)
+  "Keymap for OCaml-lsp type enclosing transient mode.")
+
+(defun lsp-ocaml-type-enclosing-go-up ()
+  "Go up the type's enclosing."
+  (interactive)
+  (when lsp-ocaml--type-enclosing-type-enclosings
+    (setq lsp-ocaml--type-enclosing-index
+          (if lsp-ocaml-enclosing-type-cycle
+              (mod (1+ lsp-ocaml--type-enclosing-index)
+                   (length lsp-ocaml--type-enclosing-type-enclosings))
+            (min (1+ lsp-ocaml--type-enclosing-index)
+                 (1- (length lsp-ocaml--type-enclosing-type-enclosings))))))
+  (lsp-ocaml--get-and-display-type-enclosing))
+
+(defun lsp-ocaml-type-enclosing-go-down ()
+  "Go down the type's enclosing."
+  (interactive)
+  (when lsp-ocaml--type-enclosing-type-enclosings
+    (setq lsp-ocaml--type-enclosing-index
+          (if lsp-ocaml-enclosing-type-cycle
+              (mod (1- lsp-ocaml--type-enclosing-index)
+                   (length lsp-ocaml--type-enclosing-type-enclosings))
+            (max (1- lsp-ocaml--type-enclosing-index) 0))))
+  (lsp-ocaml--get-and-display-type-enclosing))
+
+(defun lsp-ocaml-type-enclosing-decrease-verbosity ()
+  "Decreases the number of expansions of aliases in answer."
+  (interactive)
+  (let ((verbosity (max 0 (1- lsp-ocaml--type-enclosing-verbosity))))
+    (setq lsp-ocaml--type-enclosing-verbosity verbosity))
+  (lsp-ocaml--get-and-display-type-enclosing))
+
+(defun lsp-ocaml-type-enclosing-increase-verbosity ()
+  "Increases the number of expansions of aliases in answer."
+  (interactive)
+  (let ((verbosity (1+ lsp-ocaml--type-enclosing-verbosity)))
+    (setq lsp-ocaml--type-enclosing-verbosity verbosity))
+  (lsp-ocaml--get-and-display-type-enclosing t))
+
+(defun lsp-ocaml-type-enclosing-copy ()
+  "Copy the type of the saved enclosing type to the `kill-ring'."
+  (interactive)
+  (when lsp-ocaml--type-enclosing-saved-type
+    (message "Copied `%s' to kill-ring"
+             lsp-ocaml--type-enclosing-saved-type)
+    (kill-new lsp-ocaml--type-enclosing-saved-type)))
+
+(defun lsp-ocaml--get-and-display-type-enclosing (&optional increased-verbosity)
+  "Compute the type enclosing request.
+
+  If INCREASED-VERBOSITY is t, if the computed type is the same as the previous
+  one, decrease the verbosity.
+  This allows to make sure that we don't increase infinitely the verbosity."
+  (-let* ((verbosity lsp-ocaml--type-enclosing-verbosity)
+          (index lsp-ocaml--type-enclosing-index)
+          (type_result (lsp-ocaml--type-enclosing verbosity index))
+          ((&ocaml-lsp:TypeEnclosingResult :index :type :enclosings) type_result)
+          ;; Get documentation informations
+          (markupkind (symbol-name lsp-ocaml-markupkind))
+          (doc_result (lsp-ocaml--get-documentation nil markupkind))
+          (doc (cl-getf (cl-getf doc_result :doc) :value)))
+    (when (and increased-verbosity
+               (string= type lsp-ocaml--type-enclosing-saved-type))
+      (setq lsp-ocaml--type-enclosing-verbosity (1- verbosity)))
+    (setq lsp-ocaml--type-enclosing-saved-type type)
+    (setq lsp-ocaml--type-enclosing-type-enclosings enclosings)
+    (lsp-ocaml--display-type markupkind type doc)
+    (lsp-ocaml--highlight-current-type (aref enclosings index))
+    type))
+
 ;;; -------------------
 ;;; OCaml-lsp extensions
 ;;; -------------------
@@ -206,6 +335,13 @@ If OTHER-WINDOW is not nil, open the buffer in an other window."
     (unless (lsp-ocaml--load-uri uri nil)
       (message "No alternate file %s could be found for %s" (f-filename uri) (buffer-name)))))
 
+(defun lsp-ocaml-type-enclosing ()
+  "Returns the type of the indent at point."
+  (interactive)
+  (lsp-ocaml--init-type-enclosing-config)
+  (when-let* ((type (lsp-ocaml--get-and-display-type-enclosing)))
+    (set-transient-map lsp-ocaml-type-enclosing-map t)))
+
 (lsp-consistency-check lsp-ocaml)
 
 (provide 'lsp-ocaml)

docs/manual-language-docs/lsp-ocaml.md

@@ -8,6 +8,34 @@ root_file: docs/manual-language-docs/lsp-ocaml.md
 
 ### Commands
 
+#### `lsp-ocaml-type-enclosing`
+
+Gets the type of ident under the cursor. It will highlight the ident and display its type.
+
+When this function is called it will create a transient keymap `lsp-ocaml-type-enclosing-map` that allows to do the following things:
+- Increase/decrease the number of aliases expansions. As an example, suppose we want to type `h` in the following expression:
+  ```ocaml
+  type t = A | B
+  let h : t = A
+  ```
+  - The lowest verbosity will give `type t`
+  - The next verbosity will give `type t = A | B`
+- Go up/down the enclosing type (bound to `C-<up>/<down>` by default). As an example:
+  ```ocaml
+  module A = struct
+    let h : t = A
+    let f () = ()
+
+    (** Test doc *)
+    let g (f: 'a -> 'b) a = f a
+  end
+  ```
+  - Typing on the last `a` will show `'a`
+  - Going up will highlight `f a` of type `'b`
+  - Going up will highlight `(f: 'a -> 'b) a = f a` of type `('a -> 'b) -> 'a -> 'b`
+  - Going up will highlight the whole module and display its entire type
+- Copy the current type (bound to `C-w` by default)
+
 #### `lsp-ocaml-find-alternate-file`
 
 Find the interface corresponding to an implementation or the implementation corresponding to an interface.

lsp-mode.el

@@ -5457,25 +5457,29 @@ If EXCLUDE-DECLARATION is non-nil, request the server to include declarations."
 (define-derived-mode lsp-help-mode help-mode "LspHelp"
   "Major mode for displaying lsp help.")
 
+(defun lsp--display-contents (contents)
+  "Display CONTENTS in a dedicated buffer."
+  (if (and contents (not (equal contents "")))
+      (let ((lsp-help-buf-name "*lsp-help*"))
+        (with-current-buffer (get-buffer-create lsp-help-buf-name)
+          (delay-mode-hooks
+            (lsp-help-mode)
+            (with-help-window lsp-help-buf-name
+              (insert
+               (mapconcat 'string-trim-right
+                          (split-string (lsp--render-on-hover-content contents t) "\n")
+                          "\n"))))
+          (run-mode-hooks)))
+    (lsp--info "No content at point.")))
+
 (defun lsp-describe-thing-at-point ()
   "Display the type signature and documentation of the thing at point."
   (interactive)
   (let ((contents (-some->> (lsp--text-document-position-params)
                     (lsp--make-request "textDocument/hover")
                     (lsp--send-request)
                     (lsp:hover-contents))))
-    (if (and contents (not (equal contents "")))
-        (let ((lsp-help-buf-name "*lsp-help*"))
-          (with-current-buffer (get-buffer-create lsp-help-buf-name)
-            (delay-mode-hooks
-              (lsp-help-mode)
-              (with-help-window lsp-help-buf-name
-                (insert
-                 (mapconcat 'string-trim-right
-                            (split-string (lsp--render-on-hover-content contents t) "\n")
-                            "\n"))))
-            (run-mode-hooks)))
-      (lsp--info "No content at point."))))
+    (lsp--display-contents contents)))
 
 (defun lsp--point-in-bounds-p (bounds)
   "Return whether the current point is within BOUNDS."

lsp-protocol.el

@@ -433,7 +433,10 @@ See `-let' for a description of the destructuring mechanism."
 (lsp-interface (csharp-ls:CSharpMetadata (:textDocument))
                (csharp-ls:CSharpMetadataResponse (:source :projectName :assemblyName :symbolName)))
 
-(lsp-interface (ocaml-lsp:SwitchImplIntfParams (:uri) nil))
+(lsp-interface (ocaml-lsp:SwitchImplIntfParams (:uri) nil)
+               (ocaml-lsp:TypeEnclosingParams (:uri :at :index :verbosity) nil)
+               (ocaml-lsp:TypeEnclosingResult (:index :enclosings :type) nil)
+               (ocaml-lsp:GetDocumentationParams (:textDocument :position :contentFormat) nil))
 
 (lsp-interface (rls:Cmd (:args :binary :env :cwd) nil))