cider-eldoc.el

;;; cider-eldoc.el --- eldoc support for Clojure -*- lexical-binding: t -*-

;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
;; Copyright © 2013-2022 Bozhidar Batsov, Artur Malabarba and CIDER contributors
;;
;; Author: Tim King <kingtim@gmail.com>
;;         Phil Hagelberg <technomancy@gmail.com>
;;         Bozhidar Batsov <bozhidar@batsov.dev>
;;         Artur Malabarba <bruce.connor.am@gmail.com>
;;         Hugo Duncan <hugo@hugoduncan.org>
;;         Steve Purcell <steve@sanityinc.com>

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;; This file is not part of GNU Emacs.

;;; Commentary:

;; eldoc support for Clojure.

;;; Code:

(require 'cider-client)
(require 'cider-common) ; for cider-symbol-at-point
(require 'subr-x)
(require 'cider-util)
(require 'nrepl-dict)

(require 'seq)

(require 'eldoc)

(defvar cider-extra-eldoc-commands '("yas-expand")
  "Extra commands to be added to eldoc's safe commands list.")

(defcustom cider-eldoc-max-num-sexps-to-skip 30
  "The maximum number of sexps to skip while searching the beginning of current sexp."
  :type 'integer
  :group 'cider
  :package-version '(cider . "0.10.1"))

(defvar-local cider-eldoc-last-symbol nil
  "The eldoc information for the last symbol we checked.")

(defcustom cider-eldoc-ns-function #'identity
  "A function that returns a ns string to be used by eldoc.
Takes one argument, a namespace name.
For convenience, some functions are already provided for this purpose:
`cider-abbreviate-ns', and `cider-last-ns-segment'."
  :type '(choice (const :tag "Full namespace" identity)
                 (const :tag "Abbreviated namespace" cider-abbreviate-ns)
                 (const :tag "Last name in namespace" cider-last-ns-segment)
                 (function :tag "Custom function"))
  :group 'cider
  :package-version '(cider . "0.13.0"))

(defcustom cider-eldoc-max-class-names-to-display 3
  "The maximum number of classes to display in an eldoc string.
An eldoc string for Java interop forms can have a number of classes prefixed to
it, when the form belongs to more than 1 class.  When, not nil we only display
the names of first `cider-eldoc-max-class-names-to-display' classes and add
a \"& x more\" suffix. Otherwise, all the classes are displayed."
  :type 'integer
  :safe #'integerp
  :group 'cider
  :package-version '(cider . "0.13.0"))

(defcustom cider-eldoc-display-for-symbol-at-point t
  "When non-nil, display eldoc for symbol at point if available.
So in (map inc ...) when the cursor is over inc its eldoc would be
displayed.  When nil, always display eldoc for first symbol of the sexp."
  :type 'boolean
  :safe #'booleanp
  :group 'cider
  :package-version '(cider . "0.13.0"))

(defcustom cider-eldoc-display-context-dependent-info nil
  "When non-nil, display context dependent info in the eldoc where possible.
CIDER will try to add expected function arguments based on the current context,
for example for the datomic.api/q function where it will show the expected
inputs of the query at point."
  :type 'boolean
  :group 'cider
  :package-version '(cider . "0.15.0"))

(defun cider--eldoc-format-class-names (class-names)
  "Return a formatted CLASS-NAMES prefix string.
CLASS-NAMES is a list of classes to which a Java interop form belongs.
Only keep the first `cider-eldoc-max-class-names-to-display' names, and
add a \"& x more\" suffix.  Return nil if the CLASS-NAMES list is empty or
mapping `cider-eldoc-ns-function' on it returns an empty list."
  (when-let* ((eldoc-class-names (seq-remove #'null (mapcar (apply-partially cider-eldoc-ns-function) class-names)))
              (eldoc-class-names-length (length eldoc-class-names)))
    (cond
     ;; truncate class-names list and then format it
     ((and cider-eldoc-max-class-names-to-display
           (> eldoc-class-names-length cider-eldoc-max-class-names-to-display))
      (format "(%s & %s more)"
              (thread-first eldoc-class-names
                (seq-take cider-eldoc-max-class-names-to-display)
                (string-join " ")
                (cider-propertize 'ns))
              (- eldoc-class-names-length cider-eldoc-max-class-names-to-display)))

     ;; format the whole list but add surrounding parentheses
     ((> eldoc-class-names-length 1)
      (format "(%s)"
              (thread-first eldoc-class-names
                (string-join " ")
                (cider-propertize 'ns))))

     ;; don't add the parentheses
     (t (format "%s" (car eldoc-class-names))))))

(defun cider-eldoc-format-thing (ns symbol thing type)
  "Format the eldoc subject defined by NS, SYMBOL, THING and TYPE.
THING represents the thing at point which triggered eldoc.  Normally NS and
SYMBOL are used (they are derived from THING), but when empty we fallback to
THING (e.g. for Java methods).  Format it as a function, if FUNCTION-P
is non-nil.  Else format it as a variable."
  (if-let* ((method-name (if (and symbol (not (string= symbol "")))
                             symbol
                           thing))
            (propertized-method-name (cider-propertize method-name type))
            (ns-or-class (if (and ns (stringp ns))
                             (funcall cider-eldoc-ns-function ns)
                           (cider--eldoc-format-class-names ns))))
      (format "%s/%s"
              ;; we set font-lock properties of classes in `cider--eldoc-format-class-names'
              ;; to avoid font locking the parentheses and "& x more"
              ;; so we only propertize ns-or-class if not already done
              (if (get-text-property 1 'face ns-or-class)
                  ;; it is already propertized
                  ns-or-class
                (cider-propertize ns-or-class 'ns))
              propertized-method-name)
    ;; in case ns-or-class is nil
    propertized-method-name))

(defun cider-eldoc-format-sym-doc (var ns docstring)
  "Return the formatted eldoc string for VAR and DOCSTRING.

Consider the value of `eldoc-echo-area-use-multiline-p' while formatting.
If the entire line cannot fit in the echo area, the var name may be
truncated or eliminated entirely from the output to make room for the
description.

Try to truncate the var with various strategies, so that the var and
the docstring can be displayed in the minibuffer without resizing the window.
We start with `cider-abbreviate-ns' and `cider-last-ns-segment'.
Next, if the var is in current namespace, we remove NS from the eldoc string.
Otherwise, only the docstring is returned."
  (let* ((ea-multi eldoc-echo-area-use-multiline-p)
         ;; Subtract 1 from window width since emacs will not write
         ;; any chars to the last column, or in later versions, will
         ;; cause a wraparound and resize of the echo area.
         (ea-width (1- (window-width (minibuffer-window))))
         (strip (- (+ (length var) (length docstring)) ea-width))
         (newline (string-match-p "\n" docstring))
         ;; Truncated var can be ea-var long
         ;; Subtract 2 to account for the : and / added when including
         ;; the namespace prefixed form in eldoc string
         (ea-var (- (- ea-width (length docstring)) 2)))
    (cond
     ((or (eq ea-multi t)
          (and (<= strip 0) (null newline))
          (and ea-multi (or (> (length docstring) ea-width) newline)))
      (format "%s: %s" var docstring))

     ;; Now we have to truncate either the docstring or the var
     (newline (cider-eldoc-format-sym-doc var ns (substring docstring 0 newline)))

     ;; Only return the truncated docstring
     ((> (length docstring) ea-width)
      (substring docstring 0 ea-width))

     ;; Try to truncate the var with cider-abbreviate-ns
     ((<= (length (cider-abbreviate-ns var)) ea-var)
      (format "%s: %s" (cider-abbreviate-ns var) docstring))

     ;; Try to truncate var with cider-last-ns-segment
     ((<= (length (cider-last-ns-segment var)) ea-var)
      (format "%s: %s" (cider-last-ns-segment var) docstring))

     ;; If the var is in current namespace, we try to truncate the var by
     ;; skipping the namespace from the returned eldoc string
     ((and (string-equal ns (cider-current-ns))
           (<= (- (length var) (length ns)) ea-var))
      (format "%s: %s"
              (replace-regexp-in-string (format "%s/" ns) "" var)
              docstring))

     ;; We couldn't fit the var and docstring in the available space,
     ;; so we just display the docstring
     (t docstring))))

(defun cider-eldoc-format-variable (thing eldoc-info)
  "Return the formatted eldoc string for a variable.

THING is the variable name.  ELDOC-INFO is a p-list containing the eldoc
information."
  (let* ((ns (lax-plist-get eldoc-info "ns"))
         (symbol (lax-plist-get eldoc-info "symbol"))
         (docstring (lax-plist-get eldoc-info "docstring"))
         (formatted-var (cider-eldoc-format-thing ns symbol thing 'var)))
    (when docstring
      (cider-eldoc-format-sym-doc formatted-var ns docstring))))

(defun cider-eldoc-format-function (thing pos eldoc-info)
  "Return the formatted eldoc string for a function.
THING is the function name.  POS is the argument-index of the functions
arglists.  ELDOC-INFO is a p-list containing the eldoc information."
  (let ((ns (lax-plist-get eldoc-info "ns"))
        (symbol (lax-plist-get eldoc-info "symbol"))
        (arglists (lax-plist-get eldoc-info "arglists")))
    (format "%s: %s"
            (cider-eldoc-format-thing ns symbol thing 'fn)
            (cider-eldoc-format-arglist arglists pos))))

(defun cider-highlight-args (arglist pos)
  "Format the the function ARGLIST for eldoc.
POS is the index of the currently highlighted argument."
  (let* ((rest-pos (cider--find-rest-args-position arglist))
         (i 0))
    (mapconcat
     (lambda (arg)
       (let ((argstr (format "%s" arg)))
         (if (string= arg "&")
             argstr
           (prog1
               (if (or (= (1+ i) pos)
                       (and rest-pos
                            (> (1+ i) rest-pos)
                            (> pos rest-pos)))
                   (propertize argstr 'face
                               'eldoc-highlight-function-argument)
                 argstr)
             (setq i (1+ i)))))) arglist " ")))

(defun cider--find-rest-args-position (arglist)
  "Find the position of & in the ARGLIST vector."
  (seq-position arglist "&"))

(defun cider-highlight-arglist (arglist pos)
  "Format the ARGLIST for eldoc.
POS is the index of the argument to highlight."
  (concat "[" (cider-highlight-args arglist pos) "]"))

(defun cider-eldoc-format-arglist (arglist pos)
  "Format all the ARGLIST for eldoc.
POS is the index of current argument."
  (concat "("
          (mapconcat (lambda (args) (cider-highlight-arglist args pos))
                     arglist
                     " ")
          ")"))

(defun cider-eldoc-beginning-of-sexp ()
  "Move to the beginning of current sexp.

Return the number of nested sexp the point was over or after.  Return nil
if the maximum number of sexps to skip is exceeded."
  (let ((parse-sexp-ignore-comments t)
        (num-skipped-sexps 0))
    (condition-case _
        (progn
          ;; First account for the case the point is directly over a
          ;; beginning of a nested sexp.
          (condition-case _
              (let ((p (point)))
                (forward-sexp -1)
                (forward-sexp 1)
                (when (< (point) p)
                  (setq num-skipped-sexps 1)))
            (error))
          (while
              (let ((p (point)))
                (forward-sexp -1)
                (when (< (point) p)
                  (setq num-skipped-sexps
                        (unless (and cider-eldoc-max-num-sexps-to-skip
                                     (>= num-skipped-sexps
                                         cider-eldoc-max-num-sexps-to-skip))
                          ;; Without the above guard,
                          ;; `cider-eldoc-beginning-of-sexp' could traverse the
                          ;; whole buffer when the point is not within a
                          ;; list. This behavior is problematic especially with
                          ;; a buffer containing a large number of
                          ;; non-expressions like a REPL buffer.
                          (1+ num-skipped-sexps)))))))
      (error))
    num-skipped-sexps))

(defun cider-eldoc-thing-type (eldoc-info)
  "Return the type of the ELDOC-INFO being displayed by eldoc.
It can be a function or var now."
  (pcase (lax-plist-get eldoc-info "type")
    ("function" 'fn)
    ("special-form" 'special-form)
    ("macro" 'macro)
    ("method" 'method)
    ("variable" 'var)))

(defun cider-eldoc-info-at-point ()
  "Return eldoc info at point.
First go to the beginning of the sexp and check if the eldoc is to be
considered (i.e sexp is a method call) and not a map or vector literal.
Then go back to the point and return its eldoc."
  (save-excursion
    (unless (cider-in-comment-p)
      (let* ((current-point (point)))
        (cider-eldoc-beginning-of-sexp)
        (unless (member (or (char-before (point)) 0) '(?\" ?\{ ?\[))
          (goto-char current-point)
          (when-let* ((eldoc-info (cider-eldoc-info
                                   (cider--eldoc-remove-dot (cider-symbol-at-point)))))
            `("eldoc-info" ,eldoc-info
              "thing" ,(cider-symbol-at-point)
              "pos" 0)))))))

(defun cider-eldoc-info-at-sexp-beginning ()
  "Return eldoc info for first symbol in the sexp."
  (save-excursion
    (when-let* ((beginning-of-sexp (cider-eldoc-beginning-of-sexp))
                ;; If we are at the beginning of function name, this will be -1
                (argument-index (max 0 (1- beginning-of-sexp))))
      (unless (or (memq (or (char-before (point)) 0)
                        '(?\" ?\{ ?\[))
                  (cider-in-comment-p))
        (when-let* ((eldoc-info (cider-eldoc-info
                                 (cider--eldoc-remove-dot (cider-symbol-at-point)))))
          `("eldoc-info" ,eldoc-info
            "thing" ,(cider-symbol-at-point)
            "pos" ,argument-index))))))

(defun cider-eldoc-info-in-current-sexp ()
  "Return eldoc information from the sexp.
If `cider-eldoc-display-for-symbol-at-poin' is non-nil and
the symbol at point has a valid eldoc available, return that.
Otherwise return the eldoc of the first symbol of the sexp."
  (or (when cider-eldoc-display-for-symbol-at-point
        (cider-eldoc-info-at-point))
      (cider-eldoc-info-at-sexp-beginning)))

(defun cider-eldoc--convert-ns-keywords (thing)
  "Convert THING values that match ns macro keywords to function names."
  (pcase thing
    (":import" "clojure.core/import")
    (":refer-clojure" "clojure.core/refer-clojure")
    (":use" "clojure.core/use")
    (":refer" "clojure.core/refer")
    (_ thing)))

(defun cider-eldoc-info (thing)
  "Return the info for THING.
This includes the arglist and ns and symbol name (if available)."
  (let ((thing (cider-eldoc--convert-ns-keywords thing)))
    (when (and (cider-nrepl-op-supported-p "eldoc")
               thing
               ;; ignore blank things
               (not (string-blank-p thing))
               ;; ignore string literals
               (not (string-prefix-p "\"" thing))
               ;; ignore regular expressions
               (not (string-prefix-p "#" thing))
               ;; ignore chars
               (not (string-prefix-p "\\" thing))
               ;; ignore numbers
               (not (string-match-p "^[0-9]" thing)))
      ;; check if we can used the cached eldoc info
      (cond
       ;; handle keywords for map access
       ((string-prefix-p ":" thing) (list "symbol" thing
                                          "type" "function"
                                          "arglists" '(("map") ("map" "not-found"))))
       ;; handle Classname. by displaying the eldoc for new
       ((string-match-p "^[A-Z].+\\.$" thing) (list "symbol" thing
                                                    "type" "function"
                                                    "arglists" '(("args*"))))
       ;; generic case
       (t (if (equal thing (car cider-eldoc-last-symbol))
              (cadr cider-eldoc-last-symbol)
            (when-let* ((eldoc-info (cider-sync-request:eldoc thing)))
              (let* ((arglists (nrepl-dict-get eldoc-info "eldoc"))
                     (docstring (nrepl-dict-get eldoc-info "docstring"))
                     (type (nrepl-dict-get eldoc-info "type"))
                     (ns (nrepl-dict-get eldoc-info "ns"))
                     (class (nrepl-dict-get eldoc-info "class"))
                     (name (nrepl-dict-get eldoc-info "name"))
                     (member (nrepl-dict-get eldoc-info "member"))
                     (ns-or-class (if (and ns (not (string= ns "")))
                                      ns
                                    class))
                     (name-or-member (if (and name (not (string= name "")))
                                         name
                                       (format ".%s" member)))
                     (eldoc-plist (list "ns" ns-or-class
                                        "symbol" name-or-member
                                        "arglists" arglists
                                        "docstring" docstring
                                        "type" type)))
                ;; add context dependent args if requested by defcustom
                ;; do not cache this eldoc info to avoid showing info
                                        ;: of the previous context
                (if cider-eldoc-display-context-dependent-info
                    (cond
                     ;; add inputs of datomic query
                     ((and (equal ns-or-class "datomic.api")
                           (equal name-or-member "q"))
                      (let ((arglists (lax-plist-get eldoc-plist "arglists")))
                        (lax-plist-put eldoc-plist "arglists"
                                       (cider--eldoc-add-datomic-query-inputs-to-arglists arglists))))
                     ;; if none of the clauses is successful, do cache the eldoc
                     (t (setq cider-eldoc-last-symbol (list thing eldoc-plist))))
                  ;; middleware eldoc lookups are expensive, so we
                  ;; cache the last lookup.  This eliminates the need
                  ;; for extra middleware requests within the same sexp.
                  (setq cider-eldoc-last-symbol (list thing eldoc-plist)))
                eldoc-plist))))))))

(defun cider--eldoc-remove-dot (sym)
  "Remove the preceding \".\" from a namespace qualified SYM and return sym.
Only useful for interop forms.  Clojure forms would be returned unchanged."
  (when sym (replace-regexp-in-string "/\\." "/" sym)))

(defun cider--eldoc-edn-file-p (file-name)
  "Check whether FILE-NAME is representing an EDN file."
  (and file-name (equal (file-name-extension file-name) "edn")))

(defun cider--eldoc-add-datomic-query-inputs-to-arglists (arglists)
  "Add the expected inputs of the datomic query to the ARGLISTS."
  (if (cider-second-sexp-in-list)
      (let* ((query (cider-second-sexp-in-list))
             (query-inputs (nrepl-dict-get
                            (cider-sync-request:eldoc-datomic-query query)
                            "inputs")))
        (if query-inputs
            (thread-first
                (thread-last arglists
                  (car)
                  (remove "&")
                  (remove "inputs"))
              (append (car query-inputs))
              (list))
          arglists))
    arglists))

(defun cider-eldoc (&rest _ignored)
  "Backend function for eldoc to show argument list in the echo area."
  (when (and (cider-connected-p)
             ;; don't clobber an error message in the minibuffer
             (not (member last-command '(next-error previous-error)))
             ;; don't try to provide eldoc in EDN buffers
             (not (cider--eldoc-edn-file-p buffer-file-name)))
    (let* ((sexp-eldoc-info (cider-eldoc-info-in-current-sexp))
           (eldoc-info (lax-plist-get sexp-eldoc-info "eldoc-info"))
           (pos (lax-plist-get sexp-eldoc-info "pos"))
           (thing (lax-plist-get sexp-eldoc-info "thing")))
      (when eldoc-info
        (if (eq (cider-eldoc-thing-type eldoc-info) 'var)
            (cider-eldoc-format-variable thing eldoc-info)
          (cider-eldoc-format-function thing pos eldoc-info))))))

(defun cider-eldoc-setup ()
  "Setup eldoc in the current buffer.
eldoc mode has to be enabled for this to have any effect."
  ;; Emacs 28.1 changes the way eldoc is setup.
  ;; There you can have multiple eldoc functions.
  (if (boundp 'eldoc-documentation-functions)
      (add-hook 'eldoc-documentation-functions #'cider-eldoc nil t)
    (setq-local eldoc-documentation-function #'cider-eldoc))
  (apply #'eldoc-add-command cider-extra-eldoc-commands))

(provide 'cider-eldoc)

;;; cider-eldoc.el ends here