emacs/code/elpa/lsp-mode-20230823.446/lsp-clojure.el

;;; lsp-clojure.el --- Clojure Client settings -*- lexical-binding: t; -*-

;; Copyright (C) 2019  Benedek Fazekas

;; Author: Benedek Fazekas <benedek.fazekas@gmail.com>
;; Keywords: languages,tools

;; 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 <https://www.gnu.org/licenses/>.

;;; Commentary:

;; lsp-clojure client

;;; Code:

(require 'lsp-mode)
(require 'lsp-protocol)
(require 'cl-lib)
(require 'lsp-semantic-tokens)

(defgroup lsp-clojure nil
  "LSP support for Clojure."
  :link '(url-link "https://github.com/snoe/clojure-lsp")
  :group 'lsp-mode
  :tag "Lsp Clojure")

(define-obsolete-variable-alias 'lsp-clojure-server-command
  'lsp-clojure-custom-server-command  "lsp-mode 8.0.0")

(defcustom lsp-clojure-custom-server-command nil
  "The clojure-lisp server command."
  :group 'lsp-clojure
  :risky t
  :type '(repeat string))

(defcustom lsp-clojure-server-download-url
  (format "https://github.com/clojure-lsp/clojure-lsp/releases/latest/download/clojure-lsp-native-%s.zip"
          (let ((arch (car (split-string system-configuration "-"))))
            (pcase system-type
              ('gnu/linux (concat "linux-"
                                  (cond
                                   ((string= "x86_64" arch) "amd64")
                                   (t arch))))
              ('darwin (concat "macos-"
                               (cond
                                ((string= "x86_64" arch) "amd64")
                                (t arch))))
              ('windows-nt "windows-amd64"))))
  "Automatic download url for lsp-clojure."
  :type 'string
  :group 'lsp-clojure
  :package-version '(lsp-mode . "8.0.0"))

(defcustom lsp-clojure-server-store-path
  (f-join lsp-server-install-dir
          "clojure"
          (if (eq system-type 'windows-nt)
              "clojure-lsp.exe"
            "clojure-lsp"))
  "The path to the file in which `clojure-lsp' will be stored."
  :type 'file
  :group 'lsp-clojure
  :package-version '(lsp-mode . "8.0.0"))

(defcustom lsp-clojure-trace-enable nil
  "Enable trace logs between client and clojure-lsp server."
  :group 'lsp-clojure
  :type 'boolean)

(defcustom lsp-clojure-workspace-dir (expand-file-name (locate-user-emacs-file "workspace/"))
  "LSP clojure workspace directory."
  :group 'lsp-clojure
  :risky t
  :type 'directory)

(defcustom lsp-clojure-workspace-cache-dir (expand-file-name ".cache/" lsp-clojure-workspace-dir)
  "LSP clojure workspace cache directory."
  :group 'lsp-clojure
  :risky t
  :type 'directory)

(defcustom lsp-clojure-library-dirs (list lsp-clojure-workspace-cache-dir
                                          (expand-file-name "~/.gitlibs/libs"))
  "LSP clojure dirs that should be considered library folders."
  :group 'lsp-clojure
  :type 'list)

(defcustom lsp-clojure-test-tree-position-params nil
  "The optional test tree position params.
Defaults to side following treemacs default."
  :type 'list
  :group 'lsp-clojure)

;; Internal

(lsp-interface
 (Clojure:CursorInfoParams (:textDocument :position) nil))

(lsp-dependency
 'clojure-lsp
 `(:download :url lsp-clojure-server-download-url
   :decompress :zip
   :store-path lsp-clojure-server-store-path
   :set-executable? t)
 '(:system "clojure-lsp"))

;; Refactorings

(defun lsp-clojure--execute-command (command &optional args)
  "Send an executeCommand request for COMMAND with ARGS."
  (lsp--cur-workspace-check)
  (lsp-send-execute-command command (apply #'vector args)))

(defun lsp-clojure--refactoring-call (refactor-name &rest additional-args)
  "Send an executeCommand request for REFACTOR-NAME with ADDITIONAL-ARGS.
If there are more arguments expected after the line and column numbers."
  (lsp--cur-workspace-check)
  (lsp-clojure--execute-command refactor-name (cl-list* (lsp--buffer-uri)
                                                        (- (line-number-at-pos) 1) ;; clojure-lsp expects line numbers to start at 0
                                                        (current-column)
                                                        additional-args)))

(defun lsp-clojure-add-import-to-namespace (import-name)
  "Add to IMPORT-NAME to :import form."
  (interactive "MImport name: ")
  (lsp-clojure--refactoring-call "add-import-to-namespace" import-name))

(defun lsp-clojure-add-missing-libspec ()
  "Apply add-missing-libspec refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "add-missing-libspec"))

(defun lsp-clojure-clean-ns ()
  "Apply clean-ns refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "clean-ns"))

(defun lsp-clojure-cycle-coll ()
  "Apply cycle-coll refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "cycle-coll"))

(defun lsp-clojure-cycle-privacy ()
  "Apply cycle-privacy refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "cycle-privacy"))

(defun lsp-clojure-expand-let ()
  "Apply expand-let refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "expand-let"))

(defun lsp-clojure-extract-function (function-name)
  "Move form at point into a new function named FUNCTION-NAME."
  (interactive "MFunction name: ") ;; Name of the function
  (lsp-clojure--refactoring-call "extract-function" function-name))

(defun lsp-clojure-inline-symbol ()
  "Apply inline-symbol refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "inline-symbol"))

(defun lsp-clojure-introduce-let (binding-name)
  "Move form at point into a new let binding as BINDING-NAME."
  (interactive "MBinding name: ") ;; Name of the let binding
  (lsp-clojure--refactoring-call "introduce-let" binding-name))

(defun lsp-clojure-move-to-let (binding-name)
  "Move form at point into nearest existing let binding as BINDING-NAME."
  (interactive "MBinding name: ") ;; Name of the let binding
  (lsp-clojure--refactoring-call "move-to-let" binding-name))

(defun lsp-clojure-thread-first ()
  "Apply thread-first refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "thread-first"))

(defun lsp-clojure-thread-first-all ()
  "Apply thread-first-all refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "thread-first-all"))

(defun lsp-clojure-thread-last ()
  "Apply thread-last refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "thread-last"))

(defun lsp-clojure-thread-last-all ()
  "Apply thread-last-all refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "thread-last-all"))

(defun lsp-clojure-unwind-all ()
  "Apply unwind-all refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "unwind-all"))

(defun lsp-clojure-unwind-thread ()
  "Apply unwind-thread refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "unwind-thread"))

(defun lsp-clojure-create-function ()
  "Apply create-function refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "create-function"))

(defun lsp-clojure-create-test ()
  "Apply create-test refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "create-test"))

(defun lsp-clojure-sort-map ()
  "Apply sort-map refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "sort-map"))

(defun lsp-clojure-move-coll-entry-up ()
  "Apply move coll entry up refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "move-coll-entry-up"))

(defun lsp-clojure-move-coll-entry-down ()
  "Apply move coll entry down refactoring at point."
  (interactive)
  (lsp-clojure--refactoring-call "move-coll-entry-down"))

(defun lsp-clojure-move-form (dest-filename)
  "Apply move-form refactoring at point to DEST-FILENAME."
  (interactive
   (list (or (read-file-name "Move form to: ")
             (user-error "No filename selected. Aborting"))))
  (lsp-clojure--refactoring-call "move-form" (expand-file-name dest-filename)))

(defun lsp-clojure-server-info ()
  "Request server info."
  (interactive)
  (lsp--cur-workspace-check)
  (lsp-notify "clojure/serverInfo/log" nil))

(defvar lsp-clojure-server-buffer-name "*lsp-clojure-server-log*")

(defun lsp-clojure--server-log-revert-function (original-file-log-buffer &rest _)
  "Spit contents to ORIGINAL-FILE-LOG-BUFFER."
  (with-current-buffer (get-buffer-create lsp-clojure-server-buffer-name)
    (erase-buffer)
    (insert (with-current-buffer original-file-log-buffer (buffer-string)))
    (goto-char (point-max))
    (read-only-mode)))

(defun lsp-clojure-server-log ()
  "Open a buffer with the server logs."
  (interactive)
  (lsp--cur-workspace-check)
  (let* ((log-path (-> (lsp--json-serialize (lsp-request "clojure/serverInfo/raw" nil))
                       (lsp--read-json)
                       (lsp-get :log-path))))
    (with-current-buffer (find-file log-path)
      (read-only-mode)
      (goto-char (point-max)))))

(defun lsp-clojure-server-info-raw ()
  "Request server info raw data."
  (interactive)
  (lsp--cur-workspace-check)
  (message "%s" (lsp--json-serialize (lsp-request "clojure/serverInfo/raw" nil))))

(defun lsp-clojure-cursor-info ()
  "Request cursor info at point."
  (interactive)
  (lsp--cur-workspace-check)
  (lsp-notify "clojure/cursorInfo/log"
              (lsp-make-clojure-cursor-info-params
               :textDocument (lsp-make-text-document-identifier :uri (lsp--buffer-uri))
               :position (lsp-make-position :line (- (line-number-at-pos) 1)
                                            :character (current-column)))))

(defun lsp-clojure-resolve-macro-as ()
  "Ask to user how the unresolved macro should be resolved."
  (interactive)
  (lsp--cur-workspace-check)
  (lsp-clojure--execute-command "resolve-macro-as"
                                (list (lsp--buffer-uri)
                                      (- (line-number-at-pos) 1) ;; clojure-lsp expects line numbers to start at 0
                                      (current-column))))

(defun lsp-clojure--ensure-dir (path)
  "Ensure that directory PATH exists."
  (unless (file-directory-p path)
    (make-directory path t)))

(defun lsp-clojure--get-metadata-location (file-location)
  "Given a FILE-LOCATION return the file containing the metadata for the file."
  (format "%s.%s.metadata"
          (file-name-directory file-location)
          (file-name-base file-location)))

(defun lsp-clojure--file-in-jar (uri)
  "Check URI for a valid jar and include it in workspace."
  (string-match "^\\(jar\\|zip\\):\\(file:.+\\)!/\\(.+\\)" uri)
  (let* ((ns-path (match-string 3 uri))
         (ns (s-replace "/" "." ns-path))
         (file-location (concat lsp-clojure-workspace-cache-dir ns)))
    (unless (file-readable-p file-location)
      (lsp-clojure--ensure-dir (file-name-directory file-location))
      (with-lsp-workspace (lsp-find-workspace 'clojure-lsp nil)
        (let ((content (lsp-send-request (lsp-make-request "clojure/dependencyContents" (list :uri uri)))))
          (with-temp-file file-location
            (insert content))
          (with-temp-file (lsp-clojure--get-metadata-location file-location)
            (insert uri)))))
    file-location))

(defun lsp-clojure--server-executable-path ()
  "Return the clojure-lsp server command."
  (or (executable-find "clojure-lsp")
      (lsp-package-path 'clojure-lsp)))

(lsp-defun lsp-clojure--show-references ((&Command :arguments? args))
  "Show references for command with ARGS.
ARGS is a vector which the first element is the uri, the second the line
and the third the column."
  (lsp-show-xrefs
   (lsp--locations-to-xref-items
    (lsp-request "textDocument/references"
                 (lsp--make-reference-params
                  (lsp--text-document-position-params
                   (list :uri (seq-elt args 0))
                   (list :line (1- (seq-elt args 1))
                         :character (1- (seq-elt args 2)))))))
   nil
   t))

(defvar-local lsp-clojure--test-tree-data nil)
(defconst lsp-clojure--test-tree-buffer-name "*Clojure Test Tree*")

(defvar treemacs-position)
(defvar treemacs-width)
(declare-function lsp-treemacs-render "ext:lsp-treemacs" (tree title expand-depth &optional buffer-name))
(declare-function lsp-treemacs--open-file-in-mru "ext:lsp-treemacs" (file))

(defun lsp-clojure--test-tree-ret-action (uri range)
  "Build the ret action for an item in the test tree view.
URI is the source of the item.
RANGE is the range of positions to where this item should point."
  (interactive)
  (lsp-treemacs--open-file-in-mru (lsp--uri-to-path uri))
  (goto-char (lsp--position-to-point (lsp:range-start range)))
  (run-hooks 'xref-after-jump-hook))

(lsp-defun lsp-clojure--test-tree-data->tree (uri (&clojure-lsp:TestTreeNode :name :range :kind :children?))
  "Builds a test tree.
URI is the source of the test tree.
NODE is the node with all test children data."
  (-let* ((icon (cl-case kind
                  (1 'namespace)
                  (2 'method)
                  (3 'field)))
          (base-tree (list :key name
                           :label name
                           :icon icon
                           :ret-action (lambda (&rest _) (lsp-clojure--test-tree-ret-action uri range))
                           :uri uri)))
    (if (seq-empty-p children?)
        base-tree
      base-tree
      (plist-put base-tree :children (seq-map (-partial #'lsp-clojure--test-tree-data->tree uri) children?)))))

(lsp-defun lsp-clojure--render-test-tree ((&clojure-lsp:TestTreeParams :uri :tree))
  "Render a test tree view for current test tree buffer data."
  (save-excursion
    (lsp-treemacs-render
     (list (lsp-clojure--test-tree-data->tree uri tree))
     "Clojure Test Tree"
     t
     lsp-clojure--test-tree-buffer-name)))

(defun lsp-clojure--show-test-tree (ignore-focus?)
  "Show a test tree for current buffer.
Focus on it if IGNORE-FOCUS? is nil."
  (if lsp-clojure--test-tree-data
      (-let* ((tree-buffer (lsp-clojure--render-test-tree lsp-clojure--test-tree-data))
              (position-params (or lsp-clojure-test-tree-position-params
                                   `((side . ,treemacs-position)
                                     (slot . 2)
                                     (window-width . ,treemacs-width))))
              (window (display-buffer-in-side-window tree-buffer position-params)))
        (unless ignore-focus?
          (select-window window)
          (set-window-dedicated-p window t)))
    (unless ignore-focus?
      (lsp-log "No Clojure test tree data found."))))

(lsp-defun lsp-clojure--handle-test-tree (_workspace (notification &as &clojure-lsp:TestTreeParams :uri))
  "Test tree notification handler for workspace WORKSPACE.
NOTIFICATION is the test tree notification data received from server.
It updates the test tree view data."
  (when (require 'lsp-treemacs nil t)
    (when-let (buffer (find-buffer-visiting (lsp--uri-to-path uri)))
      (with-current-buffer buffer
        (setq lsp-clojure--test-tree-data notification)
        (when (get-buffer-window lsp-clojure--test-tree-buffer-name)
          (lsp-clojure--show-test-tree t))))))

;;;###autoload
(defun lsp-clojure-show-test-tree (ignore-focus?)
  "Show a test tree and focus on it if IGNORE-FOCUS? is nil."
  (interactive "P")
  (if (require 'lsp-treemacs nil t)
      (lsp-clojure--show-test-tree ignore-focus?)
    (error "The package lsp-treemacs is not installed")))

(defun lsp-clojure--build-command ()
  "Build clojure-lsp start command."
  (let* ((base-command (or lsp-clojure-custom-server-command
                           (-some-> (lsp-clojure--server-executable-path) list))))
    (if lsp-clojure-trace-enable
        (-map-last #'stringp
                   (lambda (command)
                     (concat command " --trace"))
                   base-command)
      base-command)))

(lsp-register-client
 (make-lsp-client
  :download-server-fn (lambda (_client callback error-callback _update?)
                        (lsp-package-ensure 'clojure-lsp callback error-callback))
  :semantic-tokens-faces-overrides '(:types (("macro" . font-lock-keyword-face)
                                             ("keyword" . clojure-keyword-face)
                                             ("event" . default)))
  :new-connection (lsp-stdio-connection
                   #'lsp-clojure--build-command
                   #'lsp-clojure--build-command)
  :major-modes '(clojure-mode clojurec-mode clojurescript-mode clojure-ts-mode)
  :library-folders-fn (lambda (_workspace) lsp-clojure-library-dirs)
  :uri-handlers (lsp-ht ("jar" #'lsp-clojure--file-in-jar))
  :action-handlers (lsp-ht ("code-lens-references" #'lsp-clojure--show-references))
  :notification-handlers (lsp-ht ("clojure/textDocument/testTree" #'lsp-clojure--handle-test-tree))
  :initialization-options '(:dependency-scheme "jar"
                            :show-docs-arity-on-same-line? t)
  :custom-capabilities `((experimental . ((testTree . ,(and (require 'lsp-treemacs nil t) t)))))
  :server-id 'clojure-lsp))

(lsp-consistency-check lsp-clojure)

;; For debugging

(declare-function cider-connect-clj "ext:cider" (params))

(defun lsp-clojure-nrepl-connect ()
  "Connect to the running nrepl debug server of clojure-lsp."
  (interactive)
  (let ((info (lsp-clojure-server-info-raw)))
    (save-match-data
      (when (functionp 'cider-connect-clj)
        (when-let (port (and (string-match "\"port\":\\([0-9]+\\)" info)
                             (match-string 1 info)))
          (cider-connect-clj `(:host "localhost"
                               :port ,port)))))))

;; Cider integration

(defun lsp-clojure-semantic-tokens-refresh (&rest _)
  "Force refresh semantic tokens."
  (when-let ((workspace (and lsp-semantic-tokens-enable
                             (lsp-find-workspace 'clojure-lsp (buffer-file-name)))))
    (--each (lsp--workspace-buffers workspace)
      (when (lsp-buffer-live-p it)
        (lsp-with-current-buffer it
          (lsp-semantic-tokens--enable))))))

(with-eval-after-load 'cider
  (when lsp-semantic-tokens-enable
    ;; refresh tokens as cider flush font-faces after disconnected
    (add-hook 'cider-mode-hook #'lsp-clojure-semantic-tokens-refresh)))

(provide 'lsp-clojure)
;;; lsp-clojure.el ends here