From: Andreas Gerler Date: Sat, 21 Dec 2024 16:25:31 +0000 (+0100) Subject: update cider X-Git-Url: http://git.bundesbrandschatzamt.de/?a=commitdiff_plain;h=d770f67303b8ad9f744f0952c2ecbadb2eea9ac2;p=emacsconfig.git update cider Signed-off-by: Andreas Gerler --- diff --git a/elpa/cider-20230707.640/cider-apropos.el b/elpa/cider-20230707.640/cider-apropos.el deleted file mode 100644 index 5cadc3de..00000000 --- a/elpa/cider-20230707.640/cider-apropos.el +++ /dev/null @@ -1,210 +0,0 @@ -;;; cider-apropos.el --- Apropos functionality for Clojure -*- lexical-binding: t -*- - -;; Copyright © 2014-2023 Jeff Valk, Bozhidar Batsov and CIDER contributors -;; -;; Author: Jeff Valk - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Apropos functionality for Clojure. - -;;; Code: - -(require 'cider-doc) ; for cider-doc-lookup -(require 'cider-find) ; for cider--find-var -(require 'cider-util) -(require 'subr-x) -(require 'cider-connection) ; for cider-ensure-connected - -(require 'cider-client) -(require 'cider-popup) -(require 'nrepl-dict) - -(require 'apropos) -(require 'button) - -(defconst cider-apropos-buffer "*cider-apropos*") - -(defcustom cider-apropos-actions '(("display-doc" . cider-doc-lookup) - ("find-def" . cider--find-var) - ("lookup-on-clojuredocs" . cider-clojuredocs-lookup)) - "Controls the actions to be applied on the symbol found by an apropos search. -The first action key in the list will be selected as default. If the list -contains only one action key, the associated action function will be -applied automatically. An action function can be any function that receives -the symbol found by the apropos search as argument." - :type '(alist :key-type string :value-type function) - :group 'cider - :package-version '(cider . "0.13.0")) - -(define-button-type 'apropos-special-form - 'apropos-label "Special form" - 'apropos-short-label "s" - 'face 'font-lock-keyword-face - 'help-echo "mouse-2, RET: Display more help on this special form" - 'follow-link t - 'action (lambda (button) - (describe-function (button-get button 'apropos-symbol)))) - -(defun cider-apropos-doc (button) - "Display documentation for the symbol represented at BUTTON." - (cider-doc-lookup (button-get button 'apropos-symbol))) - -(defun cider-apropos-summary (query ns docs-p include-private-p case-sensitive-p) - "Return a short description for the performed apropos search. - -QUERY can be a regular expression list of space-separated words -\(e.g take while) which will be converted to a regular expression -\(like take.+while) automatically behind the scenes. The search may be -limited to the namespace NS, and may optionally search doc strings -\(based on DOCS-P), include private vars (based on INCLUDE-PRIVATE-P), -and be case-sensitive (based on CASE-SENSITIVE-P)." - (concat (if case-sensitive-p "Case-sensitive " "") - (if docs-p "Documentation " "") - (format "Apropos for %S" query) - (if ns (format " in namespace %S" ns) "") - (if include-private-p - " (public and private symbols)" - " (public symbols only)"))) - -(defun cider-apropos-highlight (doc query) - "Return the DOC string propertized to highlight QUERY matches." - (let ((pos 0)) - (while (string-match query doc pos) - (setq pos (match-end 0)) - (put-text-property (match-beginning 0) - (match-end 0) - 'font-lock-face apropos-match-face doc))) - doc) - -(defvar cider-use-tooltips) -(defun cider-apropos-result (result query docs-p) - "Emit a RESULT matching QUERY into current buffer, formatted for DOCS-P." - (nrepl-dbind-response result (name type doc) - (let* ((label (capitalize (if (string= type "variable") "var" type))) - (help (concat "Display doc for this " (downcase label))) - (props (list 'apropos-symbol name - 'action #'cider-apropos-doc)) - (props (if cider-use-tooltips - (append props (list 'help-echo help)) - props))) - (cider-propertize-region props - (insert-text-button name 'type 'apropos-symbol) - (insert "\n ") - (insert-text-button label 'type (intern (concat "apropos-" type))) - (insert ": ") - (let ((beg (point))) - (if docs-p - (insert (cider-apropos-highlight doc query) "\n") - (insert doc) - (fill-region beg (point)))) - (insert "\n"))))) - -(defun cider-show-apropos (summary results query docs-p) - "Show SUMMARY and RESULTS for QUERY in a pop-up buffer, formatted for DOCS-P." - (with-current-buffer (cider-popup-buffer cider-apropos-buffer 'select 'apropos-mode 'ancillary) - (let ((inhibit-read-only t)) - (if (boundp 'header-line-format) - (setq-local header-line-format summary) - (insert summary "\n\n")) - (dolist (result results) - (cider-apropos-result result query docs-p)) - (goto-char (point-min))))) - -;;;###autoload -(defun cider-apropos (query &optional ns docs-p privates-p case-sensitive-p) - "Show all symbols whose names match QUERY, a regular expression. -QUERY can also be a list of space-separated words (e.g. take while) which -will be converted to a regular expression (like take.+while) automatically -behind the scenes. The search may be limited to the namespace NS, and may -optionally search doc strings (based on DOCS-P), include private vars -\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P)." - (interactive - (cons (read-string "Search for Clojure symbol (a regular expression): ") - (when current-prefix-arg - (list (let ((ns (completing-read "Namespace (default is all): " (cider-sync-request:ns-list)))) - (if (string= ns "") nil ns)) - (y-or-n-p "Search doc strings? ") - (y-or-n-p "Include private symbols? ") - (y-or-n-p "Case-sensitive? "))))) - (cider-ensure-connected) - (cider-ensure-op-supported "apropos") - (if-let* ((summary (cider-apropos-summary - query ns docs-p privates-p case-sensitive-p)) - (results (cider-sync-request:apropos query ns docs-p privates-p case-sensitive-p))) - (cider-show-apropos summary results query docs-p) - (message "No apropos matches for %S" query))) - -;;;###autoload -(defun cider-apropos-documentation () - "Shortcut for (cider-apropos nil t)." - (interactive) - (cider-ensure-connected) - (cider-ensure-op-supported "apropos") - (cider-apropos (read-string "Search for Clojure documentation (a regular expression): ") nil t)) - -(defun cider-apropos-act-on-symbol (symbol) - "Apply selected action on SYMBOL." - (let* ((first-action-key (car (car cider-apropos-actions))) - (action-key (if (= 1 (length cider-apropos-actions)) - first-action-key - (completing-read (format "Choose action to apply to `%s` (default %s): " - symbol first-action-key) - cider-apropos-actions nil nil nil nil first-action-key))) - (action-fn (cdr (assoc action-key cider-apropos-actions)))) - (if action-fn - (funcall action-fn symbol) - (user-error "Unknown action `%s`" action-key)))) - -;;;###autoload -(defun cider-apropos-select (query &optional ns docs-p privates-p case-sensitive-p) - "Similar to `cider-apropos', but presents the results in a completing read. -Show all symbols whose names match QUERY, a regular expression. -QUERY can also be a list of space-separated words (e.g. take while) which -will be converted to a regular expression (like take.+while) automatically -behind the scenes. The search may be limited to the namespace NS, and may -optionally search doc strings (based on DOCS-P), include private vars -\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P)." - (interactive - (cons (read-string "Search for Clojure symbol (a regular expression): ") - (when current-prefix-arg - (list (let ((ns (completing-read "Namespace (default is all): " (cider-sync-request:ns-list)))) - (if (string= ns "") nil ns)) - (y-or-n-p "Search doc strings? ") - (y-or-n-p "Include private symbols? ") - (y-or-n-p "Case-sensitive? "))))) - (cider-ensure-connected) - (cider-ensure-op-supported "apropos") - (if-let* ((summary (cider-apropos-summary - query ns docs-p privates-p case-sensitive-p)) - (results (mapcar (lambda (r) (nrepl-dict-get r "name")) - (cider-sync-request:apropos query ns docs-p privates-p case-sensitive-p)))) - (cider-apropos-act-on-symbol (completing-read (concat summary ": ") results)) - (message "No apropos matches for %S" query))) - -;;;###autoload -(defun cider-apropos-documentation-select () - "Shortcut for (cider-apropos-select nil t)." - (interactive) - (cider-ensure-connected) - (cider-ensure-op-supported "apropos") - (cider-apropos-select (read-string "Search for Clojure documentation (a regular expression): ") nil t)) - -(provide 'cider-apropos) - -;;; cider-apropos.el ends here diff --git a/elpa/cider-20230707.640/cider-autoloads.el b/elpa/cider-20230707.640/cider-autoloads.el deleted file mode 100644 index e418fe65..00000000 --- a/elpa/cider-20230707.640/cider-autoloads.el +++ /dev/null @@ -1,815 +0,0 @@ -;;; cider-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*- -;; -;;; Code: - -(add-to-list 'load-path (directory-file-name - (or (file-name-directory #$) (car load-path)))) - - -;;;### (autoloads nil "cider" "cider.el" (0 0 0 0)) -;;; Generated autoloads from cider.el - -(autoload 'cider-version "cider" "\ -Display CIDER's version." t nil) - (autoload 'cider-start-map "cider" "CIDER jack-in and connect keymap." t 'keymap) - -(autoload 'cider-jack-in-clj "cider" "\ -Start an nREPL server for the current project and connect to it. -PARAMS is a plist optionally containing :project-dir and :jack-in-cmd. -With the prefix argument, allow editing of the jack in command; with a -double prefix prompt for all these parameters. - -\(fn PARAMS)" t nil) - -(autoload 'cider-jack-in-cljs "cider" "\ -Start an nREPL server for the current project and connect to it. -PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and -:cljs-repl-type (e.g. Node, Figwheel, etc). With the prefix argument, -allow editing of the jack in command; with a double prefix prompt for all -these parameters. - -\(fn PARAMS)" t nil) - -(autoload 'cider-jack-in-clj&cljs "cider" "\ -Start an nREPL server and connect with clj and cljs REPLs. -PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and -:cljs-repl-type (e.g. Node, Figwheel, etc). With the prefix argument, -allow for editing of the jack in command; with a double prefix prompt for -all these parameters. When SOFT-CLJS-START is non-nil, start cljs REPL -only when the ClojureScript dependencies are met. - -\(fn &optional PARAMS SOFT-CLJS-START)" t nil) - -(autoload 'cider-connect-sibling-clj "cider" "\ -Create a Clojure REPL with the same server as OTHER-REPL. -PARAMS is for consistency with other connection commands and is currently -ignored. OTHER-REPL defaults to `cider-current-repl' and in programs can -also be a server buffer, in which case a new session with a REPL for that -server is created. - -\(fn PARAMS &optional OTHER-REPL)" t nil) - -(autoload 'cider-connect-sibling-cljs "cider" "\ -Create a ClojureScript REPL with the same server as OTHER-REPL. -PARAMS is a plist optionally containing :cljs-repl-type (e.g. Node, -Figwheel, etc). All other parameters are inferred from the OTHER-REPL. -OTHER-REPL defaults to `cider-current-repl' but in programs can also be a -server buffer, in which case a new session for that server is created. - -\(fn PARAMS &optional OTHER-REPL)" t nil) - -(autoload 'cider-connect-clj "cider" "\ -Initialize a Clojure connection to an nREPL server. -PARAMS is a plist optionally containing :host, :port and :project-dir. On -prefix argument, prompt for all the parameters. - -\(fn &optional PARAMS)" t nil) - -(autoload 'cider-connect-cljs "cider" "\ -Initialize a ClojureScript connection to an nREPL server. -PARAMS is a plist optionally containing :host, :port, :project-dir and -:cljs-repl-type (e.g. Node, Figwheel, etc). On prefix, prompt for all the -parameters regardless of their supplied or default values. - -\(fn &optional PARAMS)" t nil) - -(autoload 'cider-connect-clj&cljs "cider" "\ -Initialize a Clojure and ClojureScript connection to an nREPL server. -PARAMS is a plist optionally containing :host, :port, :project-dir and -:cljs-repl-type (e.g. Node, Figwheel, etc). When SOFT-CLJS-START is -non-nil, don't start if ClojureScript requirements are not met. - -\(fn PARAMS &optional SOFT-CLJS-START)" t nil) - -(autoload 'cider "cider" "\ -Start a connection of any type interactively." t nil) - -(defalias 'cider-jack-in #'cider-jack-in-clj) - -(defalias 'cider-connect #'cider-connect-clj) - -(autoload 'cider-jack-in-universal "cider" "\ -Start and connect to an nREPL server for the current project or ARG project id. - -If a project is found in current dir, call `cider-jack-in' passing ARG as -first parameter, of which see. Otherwise, ask user which project type to -start an nREPL server and connect to without a project. - -But if invoked with a numeric prefix ARG, then start an nREPL server for -the project type denoted by ARG number and connect to it, even if there is -no project for it in the current dir. - -The supported project tools and their assigned numeric prefix ids are -sourced from `cider-jack-in-universal-options', of which see. - -You can pass a numeric prefix argument n with `M-n` or `C-u n`. - -For example, to jack in to leiningen which is assigned to prefix arg 2 type - -M-2 \\[cider-jack-in-universal]. - -\(fn ARG)" t nil) - -(with-eval-after-load 'clojure-mode (define-key clojure-mode-map (kbd "C-c M-x") #'cider) (define-key clojure-mode-map (kbd "C-c M-j") #'cider-jack-in-clj) (define-key clojure-mode-map (kbd "C-c M-J") #'cider-jack-in-cljs) (define-key clojure-mode-map (kbd "C-c M-c") #'cider-connect-clj) (define-key clojure-mode-map (kbd "C-c M-C") #'cider-connect-cljs) (define-key clojure-mode-map (kbd "C-c C-x") 'cider-start-map) (define-key clojure-mode-map (kbd "C-c C-s") 'sesman-map) (require 'sesman) (sesman-install-menu clojure-mode-map) (add-hook 'clojure-mode-hook (lambda nil (setq-local sesman-system 'CIDER)))) - -(register-definition-prefixes "cider" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-apropos" "cider-apropos.el" (0 0 0 0)) -;;; Generated autoloads from cider-apropos.el - -(autoload 'cider-apropos "cider-apropos" "\ -Show all symbols whose names match QUERY, a regular expression. -QUERY can also be a list of space-separated words (e.g. take while) which -will be converted to a regular expression (like take.+while) automatically -behind the scenes. The search may be limited to the namespace NS, and may -optionally search doc strings (based on DOCS-P), include private vars -\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P). - -\(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t nil) - -(autoload 'cider-apropos-documentation "cider-apropos" "\ -Shortcut for (cider-apropos nil t)." t nil) - -(autoload 'cider-apropos-select "cider-apropos" "\ -Similar to `cider-apropos', but presents the results in a completing read. -Show all symbols whose names match QUERY, a regular expression. -QUERY can also be a list of space-separated words (e.g. take while) which -will be converted to a regular expression (like take.+while) automatically -behind the scenes. The search may be limited to the namespace NS, and may -optionally search doc strings (based on DOCS-P), include private vars -\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P). - -\(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t nil) - -(autoload 'cider-apropos-documentation-select "cider-apropos" "\ -Shortcut for (cider-apropos-select nil t)." t nil) - -(register-definition-prefixes "cider-apropos" '("apropos-special-form" "cider-")) - -;;;*** - -;;;### (autoloads nil "cider-browse-ns" "cider-browse-ns.el" (0 0 -;;;;;; 0 0)) -;;; Generated autoloads from cider-browse-ns.el - -(autoload 'cider-browse-ns "cider-browse-ns" "\ -List all NAMESPACE's vars in BUFFER. - -\(fn NAMESPACE)" t nil) - -(autoload 'cider-browse-ns-all "cider-browse-ns" "\ -List all loaded namespaces in BUFFER." t nil) - -(register-definition-prefixes "cider-browse-ns" '("cider-browse-ns-")) - -;;;*** - -;;;### (autoloads nil "cider-browse-spec" "cider-browse-spec.el" -;;;;;; (0 0 0 0)) -;;; Generated autoloads from cider-browse-spec.el - -(autoload 'cider-browse-spec "cider-browse-spec" "\ -Browse SPEC definition. - -\(fn SPEC)" t nil) - -(autoload 'cider-browse-spec-all "cider-browse-spec" "\ -Open list of specs in a popup buffer. - -With a prefix argument ARG, prompts for a regexp to filter specs. -No filter applied if the regexp is the empty string. - -\(fn &optional ARG)" t nil) - -(register-definition-prefixes "cider-browse-spec" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-cheatsheet" "cider-cheatsheet.el" (0 -;;;;;; 0 0 0)) -;;; Generated autoloads from cider-cheatsheet.el - -(autoload 'cider-cheatsheet "cider-cheatsheet" "\ -Navigate `cider-cheatsheet-hierarchy' with `completing-read'. - -When you make it to a Clojure var its doc buffer gets displayed." t nil) - -(register-definition-prefixes "cider-cheatsheet" '("cider-cheatsheet-")) - -;;;*** - -;;;### (autoloads nil "cider-classpath" "cider-classpath.el" (0 0 -;;;;;; 0 0)) -;;; Generated autoloads from cider-classpath.el - -(autoload 'cider-classpath "cider-classpath" "\ -List all classpath entries." t nil) - -(autoload 'cider-open-classpath-entry "cider-classpath" "\ -Open a classpath entry." t nil) - -(register-definition-prefixes "cider-classpath" '("cider-classpath-")) - -;;;*** - -;;;### (autoloads nil "cider-client" "cider-client.el" (0 0 0 0)) -;;; Generated autoloads from cider-client.el - -(register-definition-prefixes "cider-client" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-clojuredocs" "cider-clojuredocs.el" -;;;;;; (0 0 0 0)) -;;; Generated autoloads from cider-clojuredocs.el - -(autoload 'cider-clojuredocs-web "cider-clojuredocs" "\ -Open ClojureDocs documentation in the default web browser. - -Prompts for the symbol to use, or uses the symbol at point, depending on -the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the -opposite of what that option dictates. - -\(fn &optional ARG)" t nil) - -(autoload 'cider-clojuredocs-refresh-cache "cider-clojuredocs" "\ -Refresh the ClojureDocs cache." t nil) - -(autoload 'cider-clojuredocs "cider-clojuredocs" "\ -Open ClojureDocs documentation in a popup buffer. - -Prompts for the symbol to use, or uses the symbol at point, depending on -the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the -opposite of what that option dictates. - -\(fn &optional ARG)" t nil) - -(register-definition-prefixes "cider-clojuredocs" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-common" "cider-common.el" (0 0 0 0)) -;;; Generated autoloads from cider-common.el - -(register-definition-prefixes "cider-common" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-completion" "cider-completion.el" (0 -;;;;;; 0 0 0)) -;;; Generated autoloads from cider-completion.el - -(register-definition-prefixes "cider-completion" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-connection" "cider-connection.el" (0 -;;;;;; 0 0 0)) -;;; Generated autoloads from cider-connection.el - -(register-definition-prefixes "cider-connection" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-debug" "cider-debug.el" (0 0 0 0)) -;;; Generated autoloads from cider-debug.el - -(autoload 'cider-debug-defun-at-point "cider-debug" "\ -Instrument the \"top-level\" expression at point. -If it is a defn, dispatch the instrumented definition. Otherwise, -immediately evaluate the instrumented expression. - -While debugged code is being evaluated, the user is taken through the -source code and displayed the value of various expressions. At each step, -a number of keys will be prompted to the user." t nil) - -(register-definition-prefixes "cider-debug" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-doc" "cider-doc.el" (0 0 0 0)) -;;; Generated autoloads from cider-doc.el - -(register-definition-prefixes "cider-doc" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-eldoc" "cider-eldoc.el" (0 0 0 0)) -;;; Generated autoloads from cider-eldoc.el - -(register-definition-prefixes "cider-eldoc" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-eval" "cider-eval.el" (0 0 0 0)) -;;; Generated autoloads from cider-eval.el - -(register-definition-prefixes "cider-eval" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-find" "cider-find.el" (0 0 0 0)) -;;; Generated autoloads from cider-find.el - -(autoload 'cider-find-var "cider-find" "\ -Find definition for VAR at LINE. -Prompt according to prefix ARG and `cider-prompt-for-symbol'. -A single or double prefix argument inverts the meaning of -`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes -the results to be displayed in a different window. The default value is -thing at point. - -\(fn &optional ARG VAR LINE)" t nil) - -(autoload 'cider-find-dwim-at-mouse "cider-find" "\ -Find and display variable or resource at mouse EVENT. - -\(fn EVENT)" t nil) - -(autoload 'cider-find-dwim "cider-find" "\ -Find and display the SYMBOL-FILE at point. -SYMBOL-FILE could be a var or a resource. If thing at point is empty then -show Dired on project. If var is not found, try to jump to resource of the -same name. When called interactively, a prompt is given according to the -variable `cider-prompt-for-symbol'. A single or double prefix argument -inverts the meaning. A prefix of `-' or a double prefix argument causes -the results to be displayed in a different window. A default value of thing -at point is given when prompted. - -\(fn SYMBOL-FILE)" t nil) - -(autoload 'cider-find-resource "cider-find" "\ -Find the resource at PATH. -Prompt for input as indicated by the variable `cider-prompt-for-symbol'. -A single or double prefix argument inverts the meaning of -`cider-prompt-for-symbol'. A prefix argument of `-` or a double prefix -argument causes the results to be displayed in other window. The default -value is thing at point. - -\(fn PATH)" t nil) - -(autoload 'cider-find-ns "cider-find" "\ -Find the file containing NS. -A prefix ARG of `-` or a double prefix argument causes -the results to be displayed in a different window. - -\(fn &optional ARG NS)" t nil) - -(autoload 'cider-find-keyword "cider-find" "\ -Find the namespace of the keyword at point and its first occurrence there. - -For instance - if the keyword at point is \":cider.demo/keyword\", this command -would find the namespace \"cider.demo\" and afterwards find the first mention -of \"::keyword\" there. - -Prompt according to prefix ARG and `cider-prompt-for-symbol'. -A single or double prefix argument inverts the meaning of -`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes -the results to be displayed in a different window. The default value is -thing at point. - -\(fn &optional ARG)" t nil) - -(register-definition-prefixes "cider-find" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-format" "cider-format.el" (0 0 0 0)) -;;; Generated autoloads from cider-format.el - -(autoload 'cider-format-region "cider-format" "\ -Format the Clojure code in the current region. -START and END represent the region's boundaries. - -\(fn START END)" t nil) - -(autoload 'cider-format-defun "cider-format" "\ -Format the code in the current defun." t nil) - -(autoload 'cider-format-buffer "cider-format" "\ -Format the Clojure code in the current buffer." t nil) - -(autoload 'cider-format-edn-buffer "cider-format" "\ -Format the EDN data in the current buffer." t nil) - -(autoload 'cider-format-edn-region "cider-format" "\ -Format the EDN data in the current region. -START and END represent the region's boundaries. - -\(fn START END)" t nil) - -(autoload 'cider-format-edn-last-sexp "cider-format" "\ -Format the EDN data of the last sexp." t nil) - -(register-definition-prefixes "cider-format" '("cider--format-")) - -;;;*** - -;;;### (autoloads nil "cider-inspector" "cider-inspector.el" (0 0 -;;;;;; 0 0)) -;;; Generated autoloads from cider-inspector.el - -(autoload 'cider-inspect-last-sexp "cider-inspector" "\ -Inspect the result of the the expression preceding point." t nil) - -(autoload 'cider-inspect-defun-at-point "cider-inspector" "\ -Inspect the result of the \"top-level\" expression at point." t nil) - -(autoload 'cider-inspect-last-result "cider-inspector" "\ -Inspect the most recent eval result." t nil) - -(autoload 'cider-inspect "cider-inspector" "\ -Inspect the result of the preceding sexp. - -With a prefix argument ARG it inspects the result of the \"top-level\" form. -With a second prefix argument it prompts for an expression to eval and inspect. - -\(fn &optional ARG)" t nil) - -(autoload 'cider-inspect-expr "cider-inspector" "\ -Evaluate EXPR in NS and inspect its value. -Interactively, EXPR is read from the minibuffer, and NS the -current buffer's namespace. - -\(fn EXPR NS)" t nil) - -(register-definition-prefixes "cider-inspector" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-jar" "cider-jar.el" (0 0 0 0)) -;;; Generated autoloads from cider-jar.el - -(register-definition-prefixes "cider-jar" '("cider-jar-")) - -;;;*** - -;;;### (autoloads nil "cider-log" "cider-log.el" (0 0 0 0)) -;;; Generated autoloads from cider-log.el - (autoload 'cider-log-framework "cider-log" "Show the Cider log framework menu." t) - (autoload 'cider-log-appender "cider-log" "Show the Cider log appender menu." t) - (autoload 'cider-log-consumer "cider-log" "Show the Cider log consumer menu." t) - (autoload 'cider-log-event "cider-log" "Show the Cider log event menu." t) - (autoload 'cider-log "cider-log" "Show the Cider log menu." t) - -(register-definition-prefixes "cider-log" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-macroexpansion" "cider-macroexpansion.el" -;;;;;; (0 0 0 0)) -;;; Generated autoloads from cider-macroexpansion.el - -(autoload 'cider-macroexpand-1 "cider-macroexpansion" "\ -Invoke \\=`macroexpand-1\\=` on the expression preceding point. -If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of -\\=`macroexpand-1\\=`. - -\(fn &optional PREFIX)" t nil) - -(autoload 'cider-macroexpand-all "cider-macroexpansion" "\ -Invoke \\=`macroexpand-all\\=` on the expression preceding point." t nil) - -(register-definition-prefixes "cider-macroexpansion" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-mode" "cider-mode.el" (0 0 0 0)) -;;; Generated autoloads from cider-mode.el - -(defvar cider-mode-line '(:eval (format " cider[%s]" (cider--modeline-info))) "\ -Mode line lighter for cider mode. - -The value of this variable is a mode line template as in -`mode-line-format'. See Info Node `(elisp)Mode Line Format' for details -about mode line templates. - -Customize this variable to change how cider mode displays its status in the -mode line. The default value displays the current connection. Set this -variable to nil to disable the mode line entirely.") - -(custom-autoload 'cider-mode-line "cider-mode" t) - -(with-eval-after-load 'clojure-mode (easy-menu-define cider-clojure-mode-menu-open clojure-mode-map "Menu for Clojure mode.\n This is displayed in `clojure-mode' buffers, if `cider-mode' is not active." `("CIDER" :visible (not cider-mode) ["Start a Clojure REPL" cider-jack-in-clj :help "Starts an nREPL server and connects a Clojure REPL to it."] ["Connect to a Clojure REPL" cider-connect-clj :help "Connects to a REPL that's already running."] ["Start a ClojureScript REPL" cider-jack-in-cljs :help "Starts an nREPL server and connects a ClojureScript REPL to it."] ["Connect to a ClojureScript REPL" cider-connect-cljs :help "Connects to a ClojureScript REPL that's already running."] ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clj&cljs :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL."] "--" ["View user manual" cider-view-manual]))) - -(autoload 'cider-mode "cider-mode" "\ -Minor mode for REPL interaction from a Clojure buffer. - -This is a minor mode. If called interactively, toggle the `Cider -mode' mode. If the prefix argument is positive, enable the mode, -and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `cider-mode'. - -The mode's hook is called both when the mode is enabled and when -it is disabled. - -\\{cider-mode-map} - -\(fn &optional ARG)" t nil) - -(register-definition-prefixes "cider-mode" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-ns" "cider-ns.el" (0 0 0 0)) -;;; Generated autoloads from cider-ns.el - -(autoload 'cider-ns-reload "cider-ns" "\ -Send a (require 'ns :reload) to the REPL. - -With an argument PROMPT, it prompts for a namespace name. This is the -Clojure out of the box reloading experience and does not rely on -org.clojure/tools.namespace. See Commentary of this file for a longer list -of differences. From the Clojure doc: \":reload forces loading of all the -identified libs even if they are already loaded\". - -\(fn &optional PROMPT)" t nil) - -(autoload 'cider-ns-reload-all "cider-ns" "\ -Send a (require 'ns :reload-all) to the REPL. - -With an argument PROMPT, it prompts for a namespace name. This is the -Clojure out of the box reloading experience and does not rely on -org.clojure/tools.namespace. See Commentary of this file for a longer list -of differences. From the Clojure doc: \":reload-all implies :reload and -also forces loading of all libs that the identified libs directly or -indirectly load via require\". - -\(fn &optional PROMPT)" t nil) - -(autoload 'cider-ns-refresh "cider-ns" "\ -Reload modified and unloaded namespaces on the classpath. - -With a single prefix argument, or if MODE is `refresh-all', reload all -namespaces on the classpath unconditionally. - -With a double prefix argument, or if MODE is `clear', clear the state of -the namespace tracker before reloading. This is useful for recovering from -some classes of error (for example, those caused by circular dependencies) -that a normal reload would not otherwise recover from. The trade-off of -clearing is that stale code from any deleted files may not be completely -unloaded. - -With a negative prefix argument, or if MODE is `inhibit-fns', prevent any -refresh functions (defined in `cider-ns-refresh-before-fn' and -`cider-ns-refresh-after-fn') from being invoked. - -\(fn &optional MODE)" t nil) - -(register-definition-prefixes "cider-ns" '("cider-ns-")) - -;;;*** - -;;;### (autoloads nil "cider-overlays" "cider-overlays.el" (0 0 0 -;;;;;; 0)) -;;; Generated autoloads from cider-overlays.el - -(register-definition-prefixes "cider-overlays" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-popup" "cider-popup.el" (0 0 0 0)) -;;; Generated autoloads from cider-popup.el - -(register-definition-prefixes "cider-popup" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-profile" "cider-profile.el" (0 0 0 0)) -;;; Generated autoloads from cider-profile.el - -(autoload 'cider-profile-samples "cider-profile" "\ -Displays current max-sample-count. -If optional QUERY is specified, set max-sample-count and display new value. - -\(fn &optional QUERY)" t nil) - -(autoload 'cider-profile-var-profiled-p "cider-profile" "\ -Displays the profiling status of var under point. -Prompts for var if none under point or QUERY is present. - -\(fn QUERY)" t nil) - -(autoload 'cider-profile-ns-toggle "cider-profile" "\ -Toggle profiling for the ns associated with optional QUERY. - -If optional argument QUERY is non-nil, prompt for ns. Otherwise use -current ns. - -\(fn &optional QUERY)" t nil) - -(autoload 'cider-profile-toggle "cider-profile" "\ -Toggle profiling for the given QUERY. -Defaults to the symbol at point. -With prefix arg or no symbol at point, prompts for a var. - -\(fn QUERY)" t nil) - -(autoload 'cider-profile-summary "cider-profile" "\ -Display a summary of currently collected profile data." t nil) - -(autoload 'cider-profile-var-summary "cider-profile" "\ -Display profile data for var under point QUERY. -Defaults to the symbol at point. With prefix arg or no symbol at point, -prompts for a var. - -\(fn QUERY)" t nil) - -(autoload 'cider-profile-clear "cider-profile" "\ -Clear any collected profile data." t nil) - -(register-definition-prefixes "cider-profile" '("cider-profile-")) - -;;;*** - -;;;### (autoloads nil "cider-repl" "cider-repl.el" (0 0 0 0)) -;;; Generated autoloads from cider-repl.el - -(register-definition-prefixes "cider-repl" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-repl-history" "cider-repl-history.el" -;;;;;; (0 0 0 0)) -;;; Generated autoloads from cider-repl-history.el - -(autoload 'cider-repl-history "cider-repl-history" "\ -Display items in the CIDER command history in another buffer." t nil) - -(register-definition-prefixes "cider-repl-history" '("cider-repl-history-")) - -;;;*** - -;;;### (autoloads nil "cider-resolve" "cider-resolve.el" (0 0 0 0)) -;;; Generated autoloads from cider-resolve.el - -(register-definition-prefixes "cider-resolve" '("cider-resolve-")) - -;;;*** - -;;;### (autoloads nil "cider-scratch" "cider-scratch.el" (0 0 0 0)) -;;; Generated autoloads from cider-scratch.el - -(autoload 'cider-scratch "cider-scratch" "\ -Go to the scratch buffer named `cider-scratch-buffer-name'." t nil) - -(register-definition-prefixes "cider-scratch" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-selector" "cider-selector.el" (0 0 0 -;;;;;; 0)) -;;; Generated autoloads from cider-selector.el - -(autoload 'cider-selector "cider-selector" "\ -Select a new buffer by type, indicated by a single character. -The user is prompted for a single character indicating the method by -which to choose a new buffer. The `?' character describes the -available methods. OTHER-WINDOW provides an optional target. -See `def-cider-selector-method' for defining new methods. - -\(fn &optional OTHER-WINDOW)" t nil) - -(register-definition-prefixes "cider-selector" '("??" "?c" "?d" "?e" "?m" "?p" "?q" "?r" "?s" "?x" "cider-selector-" "def-cider-selector-method")) - -;;;*** - -;;;### (autoloads nil "cider-stacktrace" "cider-stacktrace.el" (0 -;;;;;; 0 0 0)) -;;; Generated autoloads from cider-stacktrace.el - -(register-definition-prefixes "cider-stacktrace" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-test" "cider-test.el" (0 0 0 0)) -;;; Generated autoloads from cider-test.el - -(defvar cider-auto-test-mode nil "\ -Non-nil if Cider-Auto-Test mode is enabled. -See the `cider-auto-test-mode' command -for a description of this minor mode. -Setting this variable directly does not take effect; -either customize it (see the info node `Easy Customization') -or call the function `cider-auto-test-mode'.") - -(custom-autoload 'cider-auto-test-mode "cider-test" nil) - -(autoload 'cider-auto-test-mode "cider-test" "\ -Toggle automatic testing of Clojure files. - -This is a minor mode. If called interactively, toggle the -`Cider-Auto-Test mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='cider-auto-test-mode)'. - -The mode's hook is called both when the mode is enabled and when -it is disabled. - -When enabled this reruns tests every time a Clojure file is loaded. -Only runs tests corresponding to the loaded file's namespace and does -nothing if no tests are defined or if the file failed to load. - -\(fn &optional ARG)" t nil) - -(register-definition-prefixes "cider-test" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-tracing" "cider-tracing.el" (0 0 0 0)) -;;; Generated autoloads from cider-tracing.el - -(autoload 'cider-toggle-trace-var "cider-tracing" "\ -Toggle var tracing. -Prompts for the symbol to use, or uses the symbol at point, depending on -the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the -opposite of what that option dictates. - -\(fn ARG)" t nil) - -(autoload 'cider-toggle-trace-ns "cider-tracing" "\ -Toggle ns tracing. -Defaults to the current ns. With prefix arg QUERY, prompts for a ns. - -\(fn QUERY)" t nil) - -(register-definition-prefixes "cider-tracing" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-util" "cider-util.el" (0 0 0 0)) -;;; Generated autoloads from cider-util.el - -(autoload 'cider-view-manual "cider-util" "\ -View the manual in your default browser." t nil) - -(register-definition-prefixes "cider-util" '("cider-")) - -;;;*** - -;;;### (autoloads nil "cider-xref" "cider-xref.el" (0 0 0 0)) -;;; Generated autoloads from cider-xref.el - -(autoload 'cider-xref-fn-refs "cider-xref" "\ -Show all functions that reference the var matching NS and SYMBOL. - -\(fn &optional NS SYMBOL)" t nil) - -(autoload 'cider-xref-fn-deps "cider-xref" "\ -Show all functions referenced by the var matching NS and SYMBOL. - -\(fn &optional NS SYMBOL)" t nil) - -(autoload 'cider-xref-fn-refs-select "cider-xref" "\ -Displays the references for NS and SYMBOL using completing read. - -\(fn &optional NS SYMBOL)" t nil) - -(autoload 'cider-xref-fn-deps-select "cider-xref" "\ -Displays the function dependencies for NS and SYMBOL using completing read. - -\(fn &optional NS SYMBOL)" t nil) - -(register-definition-prefixes "cider-xref" '("cider-")) - -;;;*** - -;;;### (autoloads nil "nrepl-client" "nrepl-client.el" (0 0 0 0)) -;;; Generated autoloads from nrepl-client.el - -(register-definition-prefixes "nrepl-client" '("cider-" "emacs-bug-46284/when-27.1-windows-nt" "nrepl-")) - -;;;*** - -;;;### (autoloads nil "nrepl-dict" "nrepl-dict.el" (0 0 0 0)) -;;; Generated autoloads from nrepl-dict.el - -(register-definition-prefixes "nrepl-dict" '("nrepl-")) - -;;;*** - -;;;### (autoloads nil nil ("cider-pkg.el") (0 0 0 0)) - -;;;*** - -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; coding: utf-8 -;; End: -;;; cider-autoloads.el ends here diff --git a/elpa/cider-20230707.640/cider-browse-ns.el b/elpa/cider-20230707.640/cider-browse-ns.el deleted file mode 100644 index 88811fdb..00000000 --- a/elpa/cider-20230707.640/cider-browse-ns.el +++ /dev/null @@ -1,550 +0,0 @@ -;;; cider-browse-ns.el --- CIDER namespace browser -*- lexical-binding: t; -*- - -;; Copyright © 2014-2023 John Andrews, Bozhidar Batsov and CIDER contributors - -;; Author: John Andrews - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; M-x cider-browse-ns -;; -;; Display a list of all vars in a namespace. -;; Pressing will take you to the cider-doc buffer for that var. -;; Pressing ^ will take you to a list of all namespaces (akin to `dired-mode'). - -;; M-x cider-browse-ns-all -;; -;; Explore Clojure namespaces by browsing a list of all namespaces. -;; Pressing expands into a list of that namespace's vars as if by -;; executing the command (cider-browse-ns "my.ns"). - -;;; Code: - -(require 'cider-client) -(require 'cider-popup) -(require 'cider-util) -(require 'nrepl-dict) - -(require 'subr-x) -(require 'easymenu) -(require 'button) -(require 'cl-lib) -(require 'thingatpt) - - -(defgroup cider-browse-ns nil - "Display contents of namespaces for CIDER." - :prefix "cider-browse-ns-" - :group 'cider) - -(defface cider-browse-ns-extra-info-face - '((t (:inherit shadow))) - "Face for displaying extra info of namespace vars." - :package-version '(cider . "1.4.0")) - -(defcustom cider-browse-ns-default-filters nil - "List of default hide filters to apply to browse-ns buffer. - -Available options include `private', `test', `macro', `function', and -`var'." - :type 'list - :package-version '(cider . "1.4.0")) - -(defconst cider-browse-ns-buffer "*cider-ns-browser*") - -(defvar-local cider-browse-ns-current-ns nil) - -(defvar-local cider-browse-ns-filters nil) -(defvar-local cider-browse-ns-show-all nil) -(defvar-local cider-browse-ns-group-by nil) -(defvar-local cider-browse-ns-items nil) -(defvar-local cider-browse-ns-title nil) -(defvar-local cider-browse-ns-group-by nil) - - -;; Mode Definition - -(defvar cider-browse-ns-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map cider-popup-buffer-mode-map) - (define-key map "d" #'cider-browse-ns-doc-at-point) - (define-key map "s" #'cider-browse-ns-find-at-point) - (define-key map (kbd "RET") #'cider-browse-ns-operate-at-point) - (define-key map "^" #'cider-browse-ns-all) - (define-key map "n" #'next-line) - (define-key map "p" #'previous-line) - - (define-key map "a" #'cider-browse-ns-toggle-all) - - (define-key map (kbd "h p") #'cider-browse-ns-toggle-hide-private) - (define-key map (kbd "h t") #'cider-browse-ns-toggle-hide-test) - (define-key map (kbd "h m") #'cider-browse-ns-toggle-hide-macro) - (define-key map (kbd "h f") #'cider-browse-ns-toggle-hide-function) - (define-key map (kbd "h v") #'cider-browse-ns-toggle-hide-var) - - (define-key map (kbd "g t") #'cider-browse-ns-group-by-type) - (define-key map (kbd "g v") #'cider-browse-ns-group-by-visibility) - - (easy-menu-define cider-browse-ns-mode-menu map - "Menu for CIDER's namespace browser" - '("Namespace Browser" - ["Show doc" cider-browse-ns-doc-at-point] - ["Go to definition" cider-browse-ns-find-at-point] - "--" - ["Browse all namespaces" cider-browse-ns-all])) - map)) - -(defvar cider-browse-ns-mouse-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-1] #'cider-browse-ns-handle-mouse) - map)) - -(define-derived-mode cider-browse-ns-mode special-mode "browse-ns" - "Major mode for browsing Clojure namespaces. - -\\{cider-browse-ns-mode-map}" - (setq-local electric-indent-chars nil) - (setq-local sesman-system 'CIDER) - (when cider-special-mode-truncate-lines - (setq-local truncate-lines t)) - (setq-local cider-browse-ns-current-ns nil)) - -(defun cider-browse-ns--text-face (var-meta) - "Return font-lock-face for a var. -VAR-META contains the metadata information used to decide a face. -Presence of \"arglists\" and \"macro\" indicates a macro form. -Only \"arglists\" indicates a function. Otherwise, its a variable. -If the NAMESPACE is not loaded in the REPL, assume TEXT is a fn." - (cond - ((not var-meta) 'font-lock-function-name-face) - ((and (nrepl-dict-contains var-meta "arglists") - (string= (nrepl-dict-get var-meta "macro") "true")) - 'font-lock-keyword-face) - ((nrepl-dict-contains var-meta "arglists") 'font-lock-function-name-face) - (t 'font-lock-variable-name-face))) - -(defun cider-browse-ns--properties (var var-meta) - "Decorate VAR with a clickable keymap and a face. -VAR-META is used to decide a font-lock face." - (let ((face (cider-browse-ns--text-face var-meta))) - (propertize var - 'font-lock-face face - 'mouse-face 'highlight - 'keymap cider-browse-ns-mouse-map))) - -(defun cider-browse-ns--ns-list (buffer title nss) - "List the namespaces NSS in BUFFER. - -Buffer is rendered with TITLE at the top and lists ITEMS filtered according -to user settings." - (let ((dict (nrepl-dict))) - (dolist (ns nss) - (nrepl-dict-put dict ns (nrepl-dict "ns" "true"))) - (cider-browse-ns--list buffer title dict nil))) - -(defun cider-browse-ns--list (buffer title items ns) - "Initialize rendering of browse-ns BUFFER. - -Initialize the buffer's TITLE, namespace NS, and the nrepl-dict ITEMS to be -displayed." - (with-current-buffer buffer - (cider-browse-ns-mode) - (setq-local cider-browse-ns-items items) - (setq-local cider-browse-ns-title title) - (setq-local cider-browse-ns-filters cider-browse-ns-default-filters) - (setq-local cider-browse-ns-current-ns ns)) - (cider-browse-ns--render-buffer)) - -(defun cider-browse-ns--meta-macro-p (var-meta) - "Return non-nil if VAR-META is the metadata of a macro." - (and (nrepl-dict-contains var-meta "arglists") - (string= (nrepl-dict-get var-meta "macro") "true"))) - -(defun cider-browse-ns--meta-test-p (var-meta) - "Return non-nil if VAR-META is the metadata of a test." - (nrepl-dict-contains var-meta "test")) - -(defun cider-browse-ns--meta-function-p (var-meta) - "Return non-nil if VAR-META is the metadata of a function." - (and (nrepl-dict-contains var-meta "arglists") - (not (cider-browse-ns--meta-macro-p var-meta)))) - -(defun cider-browse-ns--meta-private-p (var-meta) - "Return non-nil if VAR-META indicates a private element." - (string= (nrepl-dict-get var-meta "private") "true")) - -(defun cider-browse-ns--meta-var-p (var-meta) - "Return non-nil if VAR-META indicates a var." - (not (or (cider-browse-ns--meta-test-p var-meta) - (cider-browse-ns--meta-macro-p var-meta) - (cider-browse-ns--meta-function-p var-meta)))) - -(defun cider-browse-ns--item-filter (_ var-meta) - "Return non-nil if item containing VAR-META should be listed in buffer." - (let ((function-filter-p (memq 'function cider-browse-ns-filters)) - (var-filter-p (memq 'var cider-browse-ns-filters)) - (private-filter-p (memq 'private cider-browse-ns-filters)) - (test-filter-p (memq 'test cider-browse-ns-filters)) - (macro-filter-p (memq 'macro cider-browse-ns-filters))) - ;; check if item should be displayed - (let* ((macro-p (cider-browse-ns--meta-macro-p var-meta)) - (function-p (cider-browse-ns--meta-function-p var-meta)) - (private-p (cider-browse-ns--meta-private-p var-meta)) - (test-p (cider-browse-ns--meta-test-p var-meta)) - (var-p (cider-browse-ns--meta-var-p var-meta))) - (or cider-browse-ns-show-all - (not (or (and macro-p macro-filter-p) - (and function-p function-filter-p) - (and test-p test-filter-p) - (and var-p var-filter-p) - (and private-p private-filter-p))))))) - -(defun cider-browse-ns--propertized-item (key items) - "Return propertized line of item KEY in nrepl-dict ITEMS." - (let* ((var-meta (nrepl-dict-get items key)) - (face (cider-browse-ns--text-face (nrepl-dict-get items key))) - (private-p (string= (nrepl-dict-get var-meta "private") "true")) - (test-p (nrepl-dict-contains var-meta "test")) - (ns-p (nrepl-dict-contains var-meta "ns"))) - (concat - (propertize key - 'font-lock-face face - 'ns ns-p) - " " - (cond - (test-p (propertize "(test) " 'face 'cider-browse-ns-extra-info-face)) - (private-p (propertize "(-) " 'face 'cider-browse-ns-extra-info-face)) - (t ""))))) - -(defun cider-browse-ns--display-list (keys items max-length &optional label) - "Render the items of KEYS as condained in the nrepl-dict ITEMS. - -Pad the row to be MAX-LENGTH+1. If LABEL is non-nil, add a header to the -list of items." - (when keys - (when label - (insert " " label ":\n")) - (dolist (key keys) - (let* ((doc (nrepl-dict-get-in items (list key "doc"))) - (doc (when doc (read doc))) - (first-doc-line (cider-browse-ns--first-doc-line doc)) - (item-line (cider-browse-ns--propertized-item key items))) - (insert " ") - (insert item-line) - (when cider-browse-ns-current-ns - (insert (make-string (+ (- max-length (string-width item-line)) 1) ?·)) - (insert " " (propertize first-doc-line 'font-lock-face 'font-lock-doc-face))) - (insert "\n"))) - (insert "\n"))) - -(defun cider-browse-ns--column-width (items) - "Determine the display width of displayed ITEMS." - (let* ((propertized-lines - (seq-map (lambda (key) - (cider-browse-ns--propertized-item key items)) - (nrepl-dict-keys items)))) - (if propertized-lines - (apply #'max (seq-map (lambda (entry) (string-width entry)) - propertized-lines)) - 0))) - -(defun cider-browse-ns--render-items (items) - "Render the nrepl-dict ITEMS to the browse-ns buffer." - (let* ((max-length (cider-browse-ns--column-width items))) - (cl-labels - ((keys-from-pred - (pred items) - (nrepl-dict-keys (nrepl-dict-filter (lambda (_ var-meta) - (funcall pred var-meta)) - items)))) - (cond - ((eql cider-browse-ns-group-by 'type) - (let* ((func-keys (keys-from-pred #'cider-browse-ns--meta-function-p items)) - (macro-keys (keys-from-pred #'cider-browse-ns--meta-macro-p items)) - (var-keys (keys-from-pred #'cider-browse-ns--meta-var-p items)) - (test-keys (keys-from-pred #'cider-browse-ns--meta-test-p items))) - (cider-browse-ns--display-list func-keys items max-length "Functions") - (cider-browse-ns--display-list macro-keys items max-length "Macros") - (cider-browse-ns--display-list var-keys items max-length "Vars") - (cider-browse-ns--display-list test-keys items max-length "Tests"))) - ((eql cider-browse-ns-group-by 'visibility) - (let* ((public-keys - (keys-from-pred - (lambda (var-meta) - (not (cider-browse-ns--meta-private-p var-meta))) - items)) - (private-keys (keys-from-pred #'cider-browse-ns--meta-private-p items))) - (cider-browse-ns--display-list public-keys items max-length "Public") - (cider-browse-ns--display-list private-keys items max-length "Private"))) - (t - (cider-browse-ns--display-list - (nrepl-dict-keys items) items max-length)))))) - -(defun cider-browse-ns--filter (flag) - "Toggle the filter indicated by FLAG and re-render the buffer." - (setq cider-browse-ns-filters - (if (memq flag cider-browse-ns-filters) - (remq flag cider-browse-ns-filters) - (cons flag cider-browse-ns-filters))) - (cider-browse-ns--render-buffer)) - -(defun cider-browse-ns--button-filter (button) - "Handle filter action for BUTTON." - (let ((flag (button-get button 'filter))) - (cider-browse-ns--filter flag))) - -(defun cider-browse-ns--group (flag) - "Set the group-by option to FLAG and re-renderthe buffer." - (setq cider-browse-ns-group-by - (if (eql flag cider-browse-ns-group-by) nil flag)) - (cider-browse-ns--render-buffer)) - -(defun cider-browse-ns--button-group (button) - "Handle grouping action for BUTTON." - (let ((flag (button-get button 'group-by))) - (cider-browse-ns--group flag))) - -(defun cider-browse-ns--toggle-all (_button) - "Toggle the display-all visibility setting." - (setq cider-browse-ns-show-all (not cider-browse-ns-show-all)) - (cider-browse-ns--render-buffer)) - -(defun cider-browse-ns--render-header (&optional filtered-items-ct) - "Render the section at the top of the buffer displaying visibility controls. - -If FILTERED-ITEMS-CT is non-nil, then display a message of how many items -are being filtered." - ;; Display Show line - (insert " Show: ") - (insert-text-button "All" - 'follow-link t - 'action #'cider-browse-ns--toggle-all - ;; 'help-echo (cider-stacktrace-tooltip) - 'face (if cider-browse-ns-show-all - 'cider-stacktrace-filter-active-face - nil)) - (insert "\n") - ;; Display Filters - (let ((filters '(("Private" private) - ("Test" test) - ("Macro" macro) - ("Function" function) - ("Var" var)))) - (insert " Hide: ") - (dolist (filter filters) - (seq-let (title key) filter - (let ((is-active (memq key cider-browse-ns-filters))) - (insert-text-button title - 'filter key - 'follow-link t - 'action #'cider-browse-ns--button-filter - ;; 'help-echo (cider-stacktrace-tooltip) - 'face (if (and is-active (not cider-browse-ns-show-all)) - 'cider-stacktrace-filter-active-face - nil)) - (insert " ")))) - (when filtered-items-ct - (insert (format "(%d items filtered)" filtered-items-ct)))) - (insert "\n") - ;; Groupings - (insert " Group-by: ") - (let ((groupings '(("Type" type) - ("Visibility" visibility)))) - (dolist (grouping groupings) - (seq-let (title key) grouping - (let ((is-active (eql key cider-browse-ns-group-by))) - (insert-text-button title - 'group-by key - 'follow-link t - 'action #'cider-browse-ns--button-group - ;; 'help-echo () - 'face (if is-active - 'cider-stacktrace-filter-active-face - nil))) - (insert " ")))) - (insert "\n\n")) - -(defun cider-browse-ns--render-buffer (&optional buffer) - "Render the sections of the browse-ns buffer. - -Render occurs in BUFFER if non-nil. This function is the main entrypoint -for redisplaying the buffer when filters change." - (with-current-buffer (or buffer (current-buffer)) - (let* ((inhibit-read-only t) - (point (point)) - (filtered-items (nrepl-dict-filter #'cider-browse-ns--item-filter - cider-browse-ns-items)) - (filtered-item-ct (- (length (nrepl-dict-keys cider-browse-ns-items)) - (length (nrepl-dict-keys filtered-items))))) - (erase-buffer) - (insert (propertize (cider-propertize cider-browse-ns-title 'ns) 'ns t) "\n") - (when cider-browse-ns-current-ns - (cider-browse-ns--render-header filtered-item-ct)) - (cider-browse-ns--render-items filtered-items) - (goto-char point)))) - -(defun cider-browse-ns--first-doc-line (doc) - "Return the first line of the given DOC string. -If the first line of the DOC string contains multiple sentences, only -the first sentence is returned. If the DOC string is nil, a Not documented -string is returned." - (if doc - (let* ((split-newline (split-string doc "\n")) - (first-line (car split-newline))) - (cond - ((string-match "\\. " first-line) (substring first-line 0 (match-end 0))) - ((= 1 (length split-newline)) first-line) - (t (concat first-line "...")))) - "Not documented.")) - -(defun cider-browse-ns--combined-vars-with-meta (namespace) - "Return the combined public and private vars in NAMESPACE. - -Private vars have the additional metadata \"private\": \"true\" in their -var-meta map." - (let ((items (cider-sync-request:ns-vars-with-meta namespace)) - (private-items (cider-sync-request:private-ns-vars-with-meta namespace))) - (when private-items - (dolist (key (nrepl-dict-keys private-items)) - (let ((var-meta (nrepl-dict-put (nrepl-dict-get private-items key) - "private" "true"))) - (setq items (nrepl-dict-put items key var-meta))))) - items)) - -;; Interactive Functions - -;;;###autoload -(defun cider-browse-ns (namespace) - "List all NAMESPACE's vars in BUFFER." - (interactive (list (completing-read "Browse namespace: " (cider-sync-request:ns-list)))) - (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer 'select nil 'ancillary) - (cider-browse-ns--list (current-buffer) - namespace - (cider-browse-ns--combined-vars-with-meta namespace) - namespace))) - -;;;###autoload -(defun cider-browse-ns-all () - "List all loaded namespaces in BUFFER." - (interactive) - (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer 'select nil 'ancillary) - (let ((names (cider-sync-request:ns-list))) - (cider-browse-ns--ns-list - (current-buffer) - "All loaded namespaces" - (mapcar (lambda (name) - (cider-browse-ns--properties name nil)) - names))))) - -(defun cider-browse-ns--thing-at-point () - "Get the thing at point. -Return a list of the type ('ns or 'var) and the value." - (let ((ns-p (get-text-property (point) 'ns)) - (line (car (split-string (string-trim (thing-at-point 'line)) " ")))) - (if (or ns-p (string-match "\\." line)) - `(ns ,line) - `(var ,(format "%s/%s" - (or (get-text-property (point) 'cider-browse-ns-current-ns) - cider-browse-ns-current-ns) - line))))) - -(defun cider-browse-ns-toggle-all () - "Toggle showing all of the items in the browse-ns buffer." - (interactive) - (cider-browse-ns--toggle-all nil)) - -(defun cider-browse-ns-toggle-hide-private () - "Toggle visibility of private items displayed in browse-ns buffer." - (interactive) - (cider-browse-ns--filter 'private)) - -(defun cider-browse-ns-toggle-hide-test () - "Toggle visibility of test items displayed in browse-ns buffer." - (interactive) - (cider-browse-ns--filter 'test)) - -(defun cider-browse-ns-toggle-hide-macro () - "Toggle visibility of macro items displayed in browse-ns buffer." - (interactive) - (cider-browse-ns--filter 'macro)) - -(defun cider-browse-ns-toggle-hide-function () - "Toggle visibility of function items displayed in browse-ns buffer." - (interactive) - (cider-browse-ns--filter 'function)) - -(defun cider-browse-ns-toggle-hide-var () - "Toggle visibility of var items displayed in browse-ns buffer." - (interactive) - (cider-browse-ns--filter 'var)) - -(defun cider-browse-ns-group-by-type () - "Toggle visibility of var items displayed in browse-ns buffer." - (interactive) - (cider-browse-ns--group 'type)) - -(defun cider-browse-ns-group-by-visibility () - "Toggle visibility of var items displayed in browse-ns buffer." - (interactive) - (cider-browse-ns--group 'visibility)) - - -(declare-function cider-doc-lookup "cider-doc") - -(defun cider-browse-ns-doc-at-point () - "Show the documentation for the thing at current point." - (interactive) - (let* ((thing (cider-browse-ns--thing-at-point)) - (value (cadr thing))) - ;; value is either some ns or a var - (cider-doc-lookup value))) - -(defun cider-browse-ns-operate-at-point () - "Expand browser according to thing at current point. -If the thing at point is a ns it will be browsed, -and if the thing at point is some var - its documentation will -be displayed." - (interactive) - (let* ((thing (cider-browse-ns--thing-at-point)) - (type (car thing)) - (value (cadr thing))) - (if (eq type 'ns) - (cider-browse-ns value) - (cider-doc-lookup value)))) - -(declare-function cider-find-ns "cider-find") -(declare-function cider-find-var "cider-find") - -(defun cider-browse-ns-find-at-point () - "Find the definition of the thing at point." - (interactive) - (let* ((thing (cider-browse-ns--thing-at-point)) - (type (car thing)) - (value (cadr thing))) - (if (eq type 'ns) - (cider-find-ns nil value) - (cider-find-var current-prefix-arg value)))) - -(defun cider-browse-ns-handle-mouse (_event) - "Handle mouse click EVENT." - (interactive "e") - (cider-browse-ns-operate-at-point)) - -(provide 'cider-browse-ns) - -;;; cider-browse-ns.el ends here diff --git a/elpa/cider-20230707.640/cider-browse-spec.el b/elpa/cider-20230707.640/cider-browse-spec.el deleted file mode 100644 index 0ccf2390..00000000 --- a/elpa/cider-20230707.640/cider-browse-spec.el +++ /dev/null @@ -1,455 +0,0 @@ -;;; cider-browse-spec.el --- CIDER spec browser -*- lexical-binding: t; -*- - -;; Copyright © 2017-2023 Juan Monetta, Bozhidar Batsov and CIDER contributors - -;; Author: Juan Monetta - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; M-x cider-browse-spec -;; -;; Display a spec description you can browse. -;; Pressing over a sub spec will take you to the description of that sub spec. -;; Pressing ^ takes you to the list of all specs. - -;; M-x cider-browse-spec-all -;; -;; Explore clojure.spec registry by browsing a list of all specs. -;; Pressing over a spec display the spec description you can browse. - -;;; Code: - -(require 'cider-client) -(require 'cider-popup) -(require 'cider-util) -(require 'cl-lib) -(require 'nrepl-dict) -(require 'seq) -(require 'subr-x) -(require 'help-mode) - -;; The buffer names used by the spec browser -(defconst cider-browse-spec-buffer "*cider-spec-browser*") -(defconst cider-browse-spec-example-buffer "*cider-spec-example*") - -;; Mode Definition - -(defvar cider-browse-spec-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map (make-composed-keymap button-buffer-map - cider-popup-buffer-mode-map)) - (define-key map (kbd "RET") #'cider-browse-spec--browse-at) - (define-key map "n" #'forward-button) - (define-key map "p" #'backward-button) - map) - "Keymap for `cider-browse-spec-mode'.") - -(define-derived-mode cider-browse-spec-mode special-mode "Specs" - "Major mode for browsing Clojure specs. - -\\{cider-browse-spec-mode-map}" - (setq-local electric-indent-chars nil) - (setq-local sesman-system 'CIDER) - (when cider-special-mode-truncate-lines - (setq-local truncate-lines t))) - -(defvar cider-browse-spec--current-spec nil) - -(defvar cider-browse-spec-view-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map help-mode-map) - (define-key map (kbd "RET") #'cider-browse-spec--browse-at) - (define-key map "^" #'cider-browse-spec-all) - (define-key map "e" #'cider-browse-spec--print-curr-spec-example) - (define-key map "n" #'forward-button) - (define-key map "p" #'backward-button) - map) - "Keymap for `cider-browse-spec-view-mode'.") - -(define-derived-mode cider-browse-spec-view-mode help-mode "Spec" - "Major mode for displaying CIDER spec. - -\\{cider-browse-spec-view-mode-map}" - (setq-local cider-browse-spec--current-spec nil) - (setq-local electric-indent-chars nil) - (setq-local sesman-system 'CIDER) - (when cider-special-mode-truncate-lines - (setq-local truncate-lines t))) - -(defvar cider-browse-spec-example-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map cider-popup-buffer-mode-map) - (define-key map "^" #'cider-browse-spec-all) - (define-key map "e" #'cider-browse-spec--print-curr-spec-example) - (define-key map "g" #'revert-buffer) - map) - "Keymap for `cider-browse-spec-example-mode'.") - -(define-derived-mode cider-browse-spec-example-mode special-mode "Example" - "Major mode for Clojure spec examples. - -\\{cider-browse-spec-example-mode-map}" - (setq-local electric-indent-chars nil) - (setq-local revert-buffer-function #'cider-browse-spec--example-revert-buffer-function) - (setq-local sesman-system 'CIDER) - (when cider-special-mode-truncate-lines - (setq-local truncate-lines t))) - -;; Non interactive functions - -(define-button-type 'cider-browse-spec--spec - 'action #'cider-browse-spec--browse-at - 'face nil - 'follow-link t - 'help-echo "View spec") - -(defun cider-browse-spec--draw-list-buffer (buffer title specs) - "Reset contents of BUFFER. -Display TITLE at the top and SPECS are indented underneath." - (with-current-buffer buffer - (cider-browse-spec-mode) - (let ((inhibit-read-only t)) - (erase-buffer) - (goto-char (point-max)) - (insert (cider-propertize title 'emph) "\n") - (dolist (spec-name specs) - (insert (propertize " " 'spec-name spec-name)) - (thread-first - (cider-font-lock-as-clojure spec-name) - (insert-text-button 'type 'cider-browse-spec--spec) - (button-put 'spec-name spec-name)) - (insert (propertize "\n" 'spec-name spec-name))) - (goto-char (point-min))))) - -(defun cider--qualified-keyword-p (str) - "Return non nil if STR is a namespaced keyword." - (string-match-p "^:.+/.+$" str)) - -(defun cider--spec-fn-p (value fn-name) - "Return non nil if VALUE is clojure.spec.[alpha]/FN-NAME." - (string-match-p (concat "^\\(clojure.spec\\|clojure.spec.alpha\\|clojure.alpha.spec\\)/" fn-name "$") value)) - -(defun cider-browse-spec--render-schema-map (spec-form) - "Render the s/schema map declaration SPEC-FORM." - (let ((name-spec-pairs (seq-partition (cdaadr spec-form) 2))) - (format "(s/schema\n {%s})" - (string-join - (thread-last - (seq-sort-by #'car #'string< name-spec-pairs) - (mapcar (lambda (s) (concat (cl-first s) " " (cider-browse-spec--pprint (cl-second s)))))) - "\n ")))) - -(defun cider-browse-spec--render-schema-vector (spec-form) - "Render the s/schema vector declaration SPEC-FORM." - (format "(s/schema\n [%s])" - (string-join - (thread-last - (cl-second spec-form) - (mapcar (lambda (s) (cider-browse-spec--pprint s)))) - "\n "))) - -(defun cider-browse-spec--render-schema (spec-form) - "Render the s/schema SPEC-FORM." - (let ((schema-args (cl-second spec-form))) - (if (and (listp schema-args) - (nrepl-dict-p (cl-first schema-args))) - (cider-browse-spec--render-schema-map spec-form) - (cider-browse-spec--render-schema-vector spec-form)))) - -(defun cider-browse-spec--render-select (spec-form) - "Render the s/select SPEC-FORM." - (let ((keyset (cl-second spec-form)) - (selection (cl-third spec-form))) - (format "(s/select\n %s\n [%s])" - (cider-browse-spec--pprint keyset) - (string-join - (thread-last - selection - (mapcar (lambda (s) (cider-browse-spec--pprint s)))) - "\n ")))) - -(defun cider-browse-spec--render-union (spec-form) - "Render the s/union SPEC-FORM." - (let ((keyset (cl-second spec-form)) - (selection (cl-third spec-form))) - (format "(s/union\n %s\n [%s])" - (cider-browse-spec--pprint keyset) - (string-join - (thread-last - selection - (mapcar (lambda (s) (cider-browse-spec--pprint s)))) - "\n ")))) - -(defun cider-browse-spec--render-vector (spec-form) - "Render SPEC-FORM as a vector." - (format "[%s]" (string-join (mapcar #'cider-browse-spec--pprint spec-form)))) - -(defun cider-browse-spec--render-map-entry (spec-form) - "Render SPEC-FORM as a map entry." - (let ((key (cl-first spec-form)) - (value (cl-second spec-form))) - (format "%s %s" (cider-browse-spec--pprint key) - (if (listp value) - (cider-browse-spec--render-vector value) - (cider-browse-spec--pprint value))))) - -(defun cider-browse-spec--render-map (spec-form) - "Render SPEC-FORM as a map." - (let ((map-entries (cl-rest spec-form))) - (format "{%s}" (thread-last - (seq-partition map-entries 2) - (seq-map #'cider-browse-spec--render-map-entry) - (string-join))))) - -(defun cider-browse-spec--pprint (form) - "Given a spec FORM builds a multi line string with a pretty render of that FORM." - (cond ((stringp form) - (if (cider--qualified-keyword-p form) - (with-temp-buffer - (thread-first - form - (insert-text-button 'type 'cider-browse-spec--spec) - (button-put 'spec-name form)) - (buffer-string)) - ;; to make it easier to read replace all clojure.spec ns with s/ - ;; and remove all clojure.core ns - (thread-last - form - (replace-regexp-in-string "^\\(clojure.spec\\|clojure.spec.alpha\\|clojure.alpha.spec\\)/" "s/") - (replace-regexp-in-string "^\\(clojure.core\\)/" "")))) - - ((and (listp form) (stringp (cl-first form))) - (let ((form-tag (cl-first form))) - (cond - ;; prettier fns #() - ((string-equal form-tag "clojure.core/fn") - (if (equal (cl-second form) '("%")) - (format "#%s" (cl-reduce #'concat (mapcar #'cider-browse-spec--pprint (cl-rest (cl-rest form))))) - (format "(fn [%%] %s)" (cl-reduce #'concat (mapcar #'cider-browse-spec--pprint (cl-rest (cl-rest form))))))) - ;; prettier (s/and ) - ((cider--spec-fn-p form-tag "and") - (format "(s/and\n%s)" (string-join (thread-last - (cl-rest form) - (mapcar #'cider-browse-spec--pprint) - (mapcar (lambda (x) (format "%s" x)))) - "\n"))) - ;; prettier (s/or ) - ((cider--spec-fn-p form-tag "or") - (let ((name-spec-pair (seq-partition (cl-rest form) 2))) - (format "(s/or\n%s)" (string-join - (thread-last - name-spec-pair - (mapcar (lambda (s) (format "%s %s" (cl-first s) (cider-browse-spec--pprint (cl-second s)))))) - "\n")))) - ;; prettier (s/merge ) - ((cider--spec-fn-p form-tag "merge") - (format "(s/merge\n%s)" (string-join (thread-last - (cl-rest form) - (mapcar #'cider-browse-spec--pprint) - (mapcar (lambda (x) (format "%s" x)))) - "\n"))) - ;; prettier (s/keys ) - ((cider--spec-fn-p form-tag "keys") - (let ((keys-args (seq-partition (cl-rest form) 2))) - (format "(s/keys%s)" (thread-last - keys-args - (mapcar (lambda (s) - (let ((key-type (cl-first s)) - (specs-vec (cl-second s))) - (concat "\n" key-type - " [" - (string-join (thread-last - specs-vec - (mapcar #'cider-browse-spec--pprint) - (mapcar (lambda (x) (format "%s" x)))) - "\n") - "]")))) - (cl-reduce #'concat))))) - ;; prettier (s/multi-spec) - ((cider--spec-fn-p form-tag "multi-spec") - (let ((multi-method (cl-second form)) - (retag (cl-third form)) - (sub-specs (cl-rest (cl-rest (cl-rest form))))) - (format "(s/multi-spec %s %s\n%s)" - multi-method - retag - (string-join - (thread-last - sub-specs - (mapcar (lambda (s) - (concat "\n\n" (cl-first s) " " (cider-browse-spec--pprint (cl-second s)))))) - "\n")))) - ;; prettier (s/cat ) - ((cider--spec-fn-p form-tag "cat") - (let ((name-spec-pairs (seq-partition (cl-rest form) 2))) - (format "(s/cat %s)" - (thread-last - name-spec-pairs - (mapcar (lambda (s) - (concat "\n" (cl-first s) " " (cider-browse-spec--pprint (cl-second s))))) - (cl-reduce #'concat))))) - ;; prettier (s/alt ) - ((cider--spec-fn-p form-tag "alt") - (let ((name-spec-pairs (seq-partition (cl-rest form) 2))) - (format "(s/alt %s)" - (thread-last - name-spec-pairs - (mapcar (lambda (s) - (concat "\n" (cl-first s) " " (cider-browse-spec--pprint (cl-second s))))) - (cl-reduce #'concat))))) - ;; prettier (s/fspec ) - ((cider--spec-fn-p form-tag "fspec") - (thread-last - (seq-partition (cl-rest form) 2) - (cl-remove-if (lambda (s) (and (stringp (cl-second s)) - (string-empty-p (cl-second s))))) - (mapcar (lambda (s) - (format "\n%-11s: %s" (pcase (cl-first s) - (":args" "arguments") - (":ret" "returns") - (":fn" "invariants")) - (cider-browse-spec--pprint (cl-second s))))) - (cl-reduce #'concat) - (format "%s"))) - ;; prettier (s/schema ) - ((cider--spec-fn-p form-tag "schema") - (cider-browse-spec--render-schema form)) - ;; prettier (s/select ) - ((cider--spec-fn-p form-tag "select") - (cider-browse-spec--render-select form)) - ;; prettier (s/union ) - ((cider--spec-fn-p form-tag "union") - (cider-browse-spec--render-union form)) - ;; every other with no special management - (t (format "(%s %s)" - (cider-browse-spec--pprint form-tag) - (string-join (mapcar #'cider-browse-spec--pprint (cl-rest form)) " ")))))) - ((nrepl-dict-p form) - (cider-browse-spec--render-map form)) - (t (format "%s" form)))) - -(defun cider-browse-spec--pprint-indented (spec-form) - "Indent (pretty-print) and font-lock SPEC-FORM. -Return the result as a string." - (with-temp-buffer - (clojure-mode) - (insert (cider-browse-spec--pprint spec-form)) - (indent-region (point-min) (point-max)) - (font-lock-ensure) - (buffer-string))) - -(defun cider-browse-spec--draw-spec-buffer (buffer spec spec-form) - "Reset contents of BUFFER and draws everything needed to browse the SPEC-FORM. -Display SPEC as a title and uses `cider-browse-spec--pprint' to display -a more user friendly representation of SPEC-FORM." - (with-current-buffer buffer - (let ((inhibit-read-only t)) - (cider--help-setup-xref (list #'cider-browse-spec spec) nil buffer) - (goto-char (point-max)) - (insert (cider-font-lock-as-clojure spec) "\n\n") - (insert (cider-browse-spec--pprint-indented spec-form)) - (cider--make-back-forward-xrefs) - (current-buffer)))) - -(defun cider-browse-spec--browse (spec) - "Browse SPEC." - (cider-ensure-connected) - (cider-ensure-op-supported "spec-form") - ;; Expand auto-resolved keywords - (when-let* ((val (and (string-match-p "^::.+" spec) - (nrepl-dict-get (cider-sync-tooling-eval spec (cider-current-ns)) "value")))) - (setq spec val)) - (with-current-buffer (cider-popup-buffer cider-browse-spec-buffer 'select #'cider-browse-spec-view-mode 'ancillary) - (setq-local cider-browse-spec--current-spec spec) - (cider-browse-spec--draw-spec-buffer (current-buffer) - spec - (cider-sync-request:spec-form spec)) - (goto-char (point-min)) - (current-buffer))) - -(defun cider-browse-spec--browse-at (&optional pos) - "View the definition of a spec. - -Optional argument POS is the position of a spec, defaulting to point. POS -may also be a button, so this function can be used a the button's `action' -property." - (interactive) - (let ((pos (or pos (point)))) - (when-let* ((spec (button-get pos 'spec-name))) - (cider-browse-spec--browse spec)))) - -;; Interactive Functions - -(defun cider-browse-spec--print-curr-spec-example () - "Generate and print an example of the current spec." - (interactive) - (cider-ensure-connected) - (cider-ensure-op-supported "spec-example") - (if-let* ((spec cider-browse-spec--current-spec)) - (if-let* ((example (cider-sync-request:spec-example spec))) - (with-current-buffer (cider-popup-buffer cider-browse-spec-example-buffer 'select #'cider-browse-spec-example-mode 'ancillary) - (setq-local cider-browse-spec--current-spec spec) - (let ((inhibit-read-only t)) - (insert "Example of " (cider-font-lock-as-clojure spec)) - (insert "\n\n") - (insert (cider-font-lock-as-clojure example)) - (goto-char (point-min)))) - (error (format "No example for spec %s" spec))) - (error "No current spec"))) - -(defun cider-browse-spec--example-revert-buffer-function (&rest _) - "`revert-buffer' function for `cider-browse-spec-example-mode'. - -Generates a new example for the current spec." - (cider-browse-spec--print-curr-spec-example)) - -;;;###autoload -(defun cider-browse-spec (spec) - "Browse SPEC definition." - (interactive (list (completing-read "Browse spec: " - (cider-sync-request:spec-list) - nil nil - (cider-symbol-at-point)))) - (cider-browse-spec--browse spec)) - -(defun cider-browse-spec-regex (regex) - "Open the list of specs that matches REGEX in a popup buffer. -Displays all specs when REGEX is nil." - (cider-ensure-connected) - (cider-ensure-op-supported "spec-list") - (let ((filter-regex (or regex ""))) - (with-current-buffer (cider-popup-buffer cider-browse-spec-buffer 'select nil 'ancillary) - (let ((specs (cider-sync-request:spec-list filter-regex))) - (cider-browse-spec--draw-list-buffer (current-buffer) - (if (string-empty-p filter-regex) - "All specs in registry" - (format "All specs matching regex `%s' in registry" filter-regex)) - specs))))) - -;;;###autoload -(defun cider-browse-spec-all (&optional arg) - "Open list of specs in a popup buffer. - -With a prefix argument ARG, prompts for a regexp to filter specs. -No filter applied if the regexp is the empty string." - (interactive "P") - (cider-browse-spec-regex (if arg (read-string "Filter regex: ") ""))) - -(provide 'cider-browse-spec) - -;;; cider-browse-spec.el ends here diff --git a/elpa/cider-20230707.640/cider-cheatsheet.el b/elpa/cider-20230707.640/cider-cheatsheet.el deleted file mode 100644 index 533dae85..00000000 --- a/elpa/cider-20230707.640/cider-cheatsheet.el +++ /dev/null @@ -1,577 +0,0 @@ -;;; cider-cheatsheet.el --- Quick reference for Clojure -*- lexical-binding: t -*- - -;; Copyright © 2019-2023 Kris Jenkins, Bozhidar Batsov and CIDER contributors -;; -;; Author: Kris Jenkins - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; A quick reference system for Clojure. Fast, searchable & available offline. - -;; Mostly taken from Kris Jenkins' `clojure-cheatsheet' -;; See: https://github.com/clojure-emacs/clojure-cheatsheet - -;;; Code: - -(require 'cider-doc) -(require 'seq) - -(defconst cider-cheatsheet-hierarchy - '(("Primitives" - ("Numbers" - ("Arithmetic" - (clojure.core + - * / quot rem mod dec inc max min)) - ("Compare" - (clojure.core = == not= < > <= >= compare)) - ("Bitwise" - (clojure.core bit-and bit-and-not bit-clear bit-flip bit-not bit-or bit-set bit-shift-left bit-shift-right bit-test bit-xor unsigned-bit-shift-right)) - ("Cast" - (clojure.core byte short long int float double bigdec bigint biginteger num rationalize)) - ("Test" - (clojure.core nil? some? identical? zero? pos? neg? even? odd?)) - ("Random" - (clojure.core rand rand-int)) - ("BigDecimal" - (clojure.core with-precision)) - ("Ratios" - (clojure.core numerator denominator ratio?)) - ("Arbitrary Precision Arithmetic" - (clojure.core +\' -\' *\' inc\' dec\')) - ("Unchecked" - (clojure.core *unchecked-math* - unchecked-add - unchecked-add-int - unchecked-byte - unchecked-char - unchecked-dec - unchecked-dec-int - unchecked-divide-int - unchecked-double - unchecked-float - unchecked-inc - unchecked-inc-int - unchecked-int - unchecked-long - unchecked-multiply - unchecked-multiply-int - unchecked-negate - unchecked-negate-int - unchecked-remainder-int - unchecked-short - unchecked-subtract - unchecked-subtract-int))) - - ("Strings" - ("Create" - (clojure.core str format)) - ("Use" - (clojure.core count get subs compare) - (clojure.string join escape split split-lines replace replace-first reverse re-quote-replacement index-of last-index-of starts-with? ends-with? includes?)) - ("Regex" - (clojure.core re-find re-seq re-matches re-pattern re-matcher re-groups) - (clojure.string replace replace-first re-quote-replacement)) - ("Letters" - (clojure.string capitalize lower-case upper-case)) - ("Trim" - (clojure.string trim trim-newline triml trimr)) - ("Test" - (clojure.core char char? string?) - (clojure.string blank?))) - - ("Other" - ("Characters" - (clojure.core char char-name-string char-escape-string)) - ("Keywords" - (clojure.core keyword keyword? find-keyword)) - ("Symbols" - (clojure.core symbol symbol? gensym)) - ("Data Readers" - (clojure.core *data-readers* default-data-readers *default-data-reader-fn*)))) - - ("Collections" - ("Generic Ops" - (clojure.core count bounded-count empty not-empty into conj)) - ("Tree Walking" - (clojure.walk walk prewalk prewalk-demo prewalk-replace postwalk postwalk-demo postwalk-replace keywordize-keys stringify-keys)) - ("Content tests" - (clojure.core distinct? empty? every? not-every? some not-any?)) - ("Capabilities" - (clojure.core sequential? associative? sorted? counted? reversible?)) - ("Type tests" - (clojure.core type class coll? list? vector? set? map? seq? - number? integer? float? decimal? class? rational? ratio? - chunked-seq? reduced? special-symbol? record?)) - ("Lists" - ("Create" - (clojure.core list list*)) - ("Examine" - (clojure.core first nth peek)) - ("Change" - (clojure.core cons conj rest pop))) - - ("Vectors" - ("Create" - (clojure.core vec vector vector-of)) - ("Examine" - (clojure.core get peek)) - - ("Change" - (clojure.core assoc pop subvec replace conj rseq)) - ("Ops" - (clojure.core mapv filterv reduce-kv))) - - ("Sets" - ("Create" - (clojure.core set hash-set sorted-set sorted-set-by)) - ("Examine" - (clojure.core get contains?)) - ("Change" - (clojure.core conj disj)) - ("Relational Algebra" - (clojure.set join select project union difference intersection)) - ("Get map" - (clojure.set index rename-keys rename map-invert)) - ("Test" - (clojure.set subset? superset?)) - ("Sorted Sets" - (clojure.core rseq subseq rsubseq))) - - ("Maps" - ("Create" - (clojure.core hash-map array-map zipmap sorted-map sorted-map-by bean frequencies group-by)) - ("Examine" - (clojure.core get get-in contains? find keys vals map-entry?)) - ("Change" - (clojure.core assoc assoc-in dissoc merge merge-with select-keys update update-in)) - ("Entry" - (clojure.core key val)) - ("Sorted Maps" - (clojure.core rseq subseq rsubseq))) - - ("Hashes" - (clojure.core hash hash-ordered-coll hash-unordered-coll mix-collection-hash)) - - ("Volatiles" - (clojure.core volatile! volatile? vreset! vswap!))) - - ("Functions" - ("Create" - (clojure.core fn defn defn- definline identity constantly comp complement partial juxt memfn memoize fnil every-pred some-fn trampoline)) - ("Call" - (clojure.core -> ->> some-> some->> as-> cond-> cond->>)) - ("Test" - (clojure.core fn? ifn?))) - - ("Transducers" - ("Create" - (clojure.core cat dedupe distinct drop drop-while filter halt-when interpose keep keep-indexed map map-indexed mapcat partition-all partition-by random-sample remove replace take take-nth take-while)) - ("Call" - (clojure.core ->Eduction eduction into sequence transduce completing run!)) - ("Early Termination" - (clojure.core deref reduced reduced? ensure-reduced unreduced))) - - ("Spec" - ("Operations" - (clojure.spec.alpha valid? conform unform explain explain-data explain-str explain-out form describe assert check-asserts check-asserts?)) - ("Generator Ops" - (clojure.spec.alpha gen exercise exercise-fn)) - ("Defn & Registry" - (clojure.spec.alpha def fdef registry get-spec spec? spec with-gen)) - ("Logical" - (clojure.spec.alpha and or)) - ("Collection" - (clojure.spec.alpha coll-of map-of every every-kv keys merge)) - ("Regex " - (clojure.spec.alpha cat alt * + \? & keys*)) - ("Range" - (clojure.spec.alpha int-in inst-in double-in int-in-range? inst-in-range?)) - ("Custom Explain" - (clojure.spec.alpha explain-printer *explain-out*)) - ("Other" - (clojure.spec.alpha nilable multi-spec fspec conformer)) - - ("Predicates with test.check generators" - ("Numbers" - (clojure.core number? rational? integer? ratio? decimal? float? zero? double? int? nat-int? neg-int? pos-int?)) - ("Symbols & Keywords" - (clojure.core keyword? symbol? ident? qualified-ident? qualified-keyword? qualified-symbol? simple-ident? simple-keyword? simple-symbol?)) - ("Scalars" - (clojure.core string? true? false? nil? some? boolean? bytes? inst? uri? uuid?)) - ("Collections" - (clojure.core list? map? set? vector? associative? coll? sequential? seq? empty? indexed? seqable?)) - ("Other" - (clojure.core any?)))) - - ("Other" - ("XML" - (clojure.core xml-seq) - (clojure.xml parse)) - ("REPL" - (clojure.core *1 *2 *3 *e *print-dup* *print-length* *print-level* *print-meta* *print-readably*)) - ("EDN" - (clojure.edn read read-string)) - ("Compiling Code & Class Generation" - (clojure.core *compile-files* *compile-path* *file* *warn-on-reflection* compile gen-class gen-interface loaded-libs test)) - ("Misc" - (clojure.core eval force name *clojure-version* clojure-version *command-line-args*)) - ("Pretty Printing" - (clojure.pprint pprint print-table pp *print-right-margin*)) - ("Browser / Shell" - (clojure.java.browse browse-url) - (clojure.java.shell sh with-sh-dir with-sh-env))) - - ("Vars & Global Environment" - ("Def Variants" - (:special def) - (clojure.core defn defn- definline defmacro defmethod defmulti defonce defrecord)) - ("Interned Vars" - (:special var) - (clojure.core declare intern binding find-var)) - ("Var Objects" - (clojure.core with-local-vars var-get var-set alter-var-root var?)) - ("Var Validators" - (clojure.core set-validator! get-validator))) - - ("Reader Conditionals" - (clojure.core reader-conditional reader-conditional? tagged-literal tagged-literal?)) - - ("Abstractions" - ("Protocols" - (clojure.core defprotocol extend extend-type extend-protocol reify extends? satisfies? extenders)) - ("Records & Types" - (clojure.core defrecord deftype)) - ("Multimethods" - ("Define" - (clojure.core defmulti defmethod)) - ("Dispatch" - (clojure.core get-method methods)) - ("Remove" - (clojure.core remove-method remove-all-methods)) - ("Prefer" - (clojure.core prefer-method prefers)) - ("Relation" - (clojure.core derive isa? parents ancestors descendants make-hierarchy)))) - - ("Macros" - ("Create" - (clojure.core defmacro definline)) - ("Debug" - (clojure.core macroexpand-1 macroexpand) - (clojure.walk macroexpand-all)) - ("Branch" - (clojure.core and or when when-not when-let when-first if-not if-let cond condp case)) - ("Loop" - (clojure.core for doseq dotimes while)) - ("Arrange" - (clojure.core .. doto ->)) - ("Scope" - (clojure.core binding locking time) - (clojure.core with-in-str with-local-vars with-open with-out-str with-precision with-redefs with-redefs-fn)) - ("Lazy" - (clojure.core lazy-cat lazy-seq delay delay?)) - ("Doc" - (clojure.core assert comment) - (clojure.repl doc dir dir-fn source-fn))) - - ("Java Interop" - ("General" - (:special new set!) - (clojure.core .. doto bean comparator enumeration-seq import iterator-seq memfn definterface supers bases)) - ("Cast" - (clojure.core boolean byte short char int long float double bigdec bigint num cast biginteger)) - ("Exceptions" - (:special throw try catch finally) - (clojure.core ex-info ex-data Throwable->map StackTraceElement->vec) - (clojure.repl pst)) - ("Arrays" - ("Create" - (clojure.core boolean-array byte-array double-array char-array float-array int-array long-array make-array object-array short-array to-array)) - ("Manipulate" - (clojure.core aclone aget aset alength amap areduce aset-int aset-long aset-short aset-boolean aset-byte aset-char aset-double aset-float)) - ("Cast" - (clojure.core booleans bytes chars doubles floats ints longs shorts))) - ("Proxy" - ("Create" - (clojure.core proxy get-proxy-class construct-proxy init-proxy)) - ("Misc" - (clojure.core proxy-mappings proxy-super update-proxy)))) - - ("Namespaces" - ("Current" - (clojure.core *ns*)) - ("Create Switch" - (clojure.core ns in-ns create-ns)) - ("Add" - (clojure.core alias import intern refer refer-clojure)) - ("Find" - (clojure.core all-ns find-ns)) - ("Examine" - (clojure.core ns-aliases ns-imports ns-interns ns-map ns-name ns-publics ns-refers)) - ("From symbol" - (clojure.core resolve namespace ns-resolve the-ns)) - ("Remove" - (clojure.core ns-unalias ns-unmap remove-ns))) - ("Loading" - ("Load libs" - (clojure.core require use import refer)) - ("List Loaded" - (clojure.core loaded-libs)) - ("Load Misc" - (clojure.core load load-file load-reader load-string))) - - ("Concurrency" - ("Atoms" - (clojure.core atom swap! swap-vals! reset! reset-vals! compare-and-set!)) - ("Futures" - (clojure.core future future-call future-cancel future-cancelled? future-done? future?)) - ("Threads" - (clojure.core bound-fn bound-fn* get-thread-bindings pop-thread-bindings push-thread-bindings)) - - ("Misc" - (clojure.core locking pcalls pvalues pmap seque promise deliver)) - - ("Refs & Transactions" - ("Create" - (clojure.core ref)) - ("Examine" - (clojure.core deref)) - ("Transaction" - (clojure.core sync dosync io!)) - ("In Transaction" - (clojure.core ensure ref-set alter commute)) - ("Validators" - (clojure.core get-validator set-validator!)) - ("History" - (clojure.core ref-history-count ref-max-history ref-min-history))) - - ("Agents & Asynchronous Actions" - ("Create" - (clojure.core agent)) - ("Examine" - (clojure.core agent-error)) - ("Change State" - (clojure.core send send-off restart-agent send-via set-agent-send-executor! set-agent-send-off-executor!)) - ("Block Waiting" - (clojure.core await await-for)) - ("Ref Validators" - (clojure.core get-validator set-validator!)) - ("Watchers" - (clojure.core add-watch remove-watch)) - ("Thread Handling" - (clojure.core shutdown-agents)) - ("Error" - (clojure.core error-handler set-error-handler! error-mode set-error-mode!)) - ("Misc" - (clojure.core *agent* release-pending-sends)))) - - ("Sequences" - ("Creating a Lazy Seq" - ("From Collection" - (clojure.core seq sequence keys vals rseq subseq rsubseq)) - ("From Producer Fn" - (clojure.core lazy-seq repeatedly iterate)) - ("From Constant" - (clojure.core repeat range)) - ("From Other" - (clojure.core file-seq line-seq resultset-seq re-seq tree-seq xml-seq iterator-seq enumeration-seq)) - ("From Seq" - (clojure.core keep keep-indexed))) - - ("Seq in, Seq out" - ("Get shorter" - (clojure.core distinct dedupe filter remove for)) - ("Get longer" - (clojure.core cons conj concat lazy-cat mapcat cycle interleave interpose))) - ("Tail-items" - (clojure.core rest nthrest fnext nnext drop drop-while take-last for)) - ("Head-items" - (clojure.core take take-nth take-while butlast drop-last for)) - ("Change" - (clojure.core conj concat distinct flatten group-by partition partition-all partition-by split-at split-with filter remove replace shuffle random-sample)) - ("Rearrange" - (clojure.core reverse sort sort-by compare)) - ("Process items" - (clojure.core map pmap map-indexed mapcat for replace seque)) - - ("Using a Seq" - ("Extract item" - (clojure.core first second last rest next ffirst nfirst fnext nnext nth nthnext rand-nth when-first max-key min-key)) - ("Construct coll" - (clojure.core zipmap into reduce reductions set vec into-array to-array-2d)) - ("Pass to fn" - (clojure.core apply)) - ("Search" - (clojure.core some filter)) - ("Force evaluation" - (clojure.core doseq dorun doall)) - ("Check for forced" - (clojure.core realized?)))) - - ("Zippers" - ("Create" - (clojure.zip zipper seq-zip vector-zip xml-zip)) - ("Get loc" - (clojure.zip up down left right leftmost rightmost)) - ("Get seq" - (clojure.zip lefts rights path children)) - ("Change" - (clojure.zip make-node replace edit insert-child insert-left insert-right append-child remove)) - ("Move" - (clojure.zip next prev)) - ("XML" - (clojure.data.zip.xml attr attr= seq-test tag= text text= xml-> xml1->)) - ("Misc" - (clojure.zip root node branch? end?))) - - ("Documentation" - ("REPL" - (clojure.repl doc find-doc apropos source pst) - (clojure.java.javadoc javadoc))) - - ("Transients" - ("Create" - (clojure.core transient persistent!)) - ("Change" - (clojure.core conj! pop! assoc! dissoc! disj!))) - ("Misc" - ("Compare" - (clojure.core = == identical? not= not compare) - (clojure.data diff)) - ("Test" - (clojure.core true? false? nil? instance?))) - - ("IO" - ("To/from ..." - (clojure.core spit slurp)) - ("To *out*" - (clojure.core pr prn print printf println newline) - (clojure.pprint print-table)) - ("To writer" - (clojure.pprint pprint cl-format)) - ("To string" - (clojure.core format with-out-str pr-str prn-str print-str println-str)) - ("From *in*" - (clojure.core read-line read)) - ("From reader" - (clojure.core line-seq read)) - ("From string" - (clojure.core read-string with-in-str)) - ("Open" - (clojure.core with-open) - (clojure.java.io reader writer input-stream output-stream)) - ("Interop" - (clojure.java.io make-writer make-reader make-output-stream make-input-stream)) - ("Misc" - (clojure.core flush file-seq *in* *out* *err*) - (clojure.java.io file copy delete-file resource as-file as-url as-relative-path make-parents))) - - ("Metadata" - (clojure.core meta with-meta alter-meta! reset-meta! vary-meta)) - - ("Special Forms" - (:special def if do quote var recur throw try monitor-enter monitor-exit) - (clojure.core fn loop) - ("Binding / Destructuring" - (clojure.core let fn letfn defn defmacro loop for doseq if-let if-some when-let when-some))) - - ("Async" - ("Main" - (clojure.core.async go go-loop ! >!! chan put! take take! close! timeout offer! poll! promise-chan)) - ("Choice" - (clojure.core.async alt! alt!! alts! alts!! do-alts)) - ("Buffering" - (clojure.core.async buffer dropping-buffer sliding-buffer unblocking-buffer?)) - ("Pipelines" - (clojure.core.async pipeline pipeline-async pipeline-blocking)) - ("Threading" - (clojure.core.async thread thread-call)) - ("Mixing" - (clojure.core.async admix solo-mode mix unmix unmix-all toggle merge pipe unique)) - ("Multiples" - (clojure.core.async mult tap untap untap-all)) - ("Publish/Subscribe" - (clojure.core.async pub sub unsub unsub-all)) - ("Higher Order" - (clojure.core.async filter< filter> map map< map> mapcat< mapcat> partition partition-by reduce remove< remove> split)) - ("Pre-Populate" - (clojure.core.async into onto-chan to-chan))) - ("Unit Tests" - ("Defining" - (clojure.test deftest deftest- testing is are)) - ("Running" - (clojure.test run-tests run-all-tests test-vars)) - ("Fixtures" - (clojure.test use-fixtures join-fixtures compose-fixtures)))) - "A data structure for Clojure cheatsheet information. - -It's a tree, where the head of each list determines the context of the rest -of the list. The head may be: - - - A string, in which case it's a (sub)heading for the rest of the items. - - - A symbol, in which case it's the Clojure namespace of the symbols that - follow it. - - - The keyword :special, in which case it's a Clojure special form - - - Any other keyword, in which case it's a typed item that will be passed - through. - -Note that some Clojure symbols appear in more than once. This is entirely -intentional. For instance, `map` belongs in the sections on collections -and transducers.") - -(defun cider-cheatsheet--expand-vars (list) - "Expand the symbols in LIST to fully-qualified var names. - -This list is supposed to have the following format: - - (my-ns var1 var2 var3)" - (let ((ns (car list)) - (vars (cdr list))) - (if (eq ns :special) - (mapcar #'symbol-name vars) - (mapcar (lambda (var) (format "%s/%s" ns var)) vars)))) - -(defun cider-cheatsheet--select-var (var-list) - "Expand the symbols in VAR-LIST to fully-qualified var names. - -The list can hold one or more lists inside - one per each namespace." - (let ((namespaced-vars (seq-mapcat #'cider-cheatsheet--expand-vars - (seq-remove (lambda (list) - (eq (car list) :url)) - var-list)))) - (cider-doc-lookup (completing-read "Select var: " namespaced-vars)))) - -;;;###autoload -(defun cider-cheatsheet () - "Navigate `cider-cheatsheet-hierarchy' with `completing-read'. - -When you make it to a Clojure var its doc buffer gets displayed." - (interactive) - (let ((cheatsheet-data cider-cheatsheet-hierarchy)) - (while (stringp (caar cheatsheet-data)) - (let* ((sections (mapcar #'car cheatsheet-data)) - (sel-section (completing-read "Select cheatsheet section: " sections)) - (section-data (seq-find (lambda (elem) (equal (car elem) sel-section)) cheatsheet-data))) - (setq cheatsheet-data (cdr section-data)))) - (cider-cheatsheet--select-var cheatsheet-data))) - -(provide 'cider-cheatsheet) - -;;; cider-cheatsheet.el ends here diff --git a/elpa/cider-20230707.640/cider-classpath.el b/elpa/cider-20230707.640/cider-classpath.el deleted file mode 100644 index 0b628eeb..00000000 --- a/elpa/cider-20230707.640/cider-classpath.el +++ /dev/null @@ -1,109 +0,0 @@ -;;; cider-classpath.el --- Basic Java classpath browser -*- lexical-binding: t; -*- - -;; Copyright © 2014-2023 Bozhidar Batsov and CIDER contributors - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Basic Java classpath browser for CIDER. - -;;; Code: - -(require 'cider-client) -(require 'cider-popup) -(require 'subr-x) - -(defvar cider-classpath-buffer "*cider-classpath*") - -(defvar cider-classpath-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map cider-popup-buffer-mode-map) - (define-key map (kbd "RET") #'cider-classpath-operate-on-point) - (define-key map "n" #'next-line) - (define-key map "p" #'previous-line) - map)) - -(defvar cider-classpath-mouse-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-1] #'cider-classpath-handle-mouse) - map)) - -(define-derived-mode cider-classpath-mode special-mode "classpath" - "Major mode for browsing the entries in Java's classpath. - -\\{cider-classpath-mode-map}" - (setq-local electric-indent-chars nil) - (setq-local sesman-system 'CIDER) - (when cider-special-mode-truncate-lines - (setq-local truncate-lines t))) - -(defun cider-classpath-list (buffer items) - "Populate BUFFER with ITEMS." - (with-current-buffer buffer - (cider-classpath-mode) - (let ((inhibit-read-only t)) - (erase-buffer) - (dolist (item items) - (insert item "\n")) - (goto-char (point-min))))) - -(defun cider-classpath-properties (text) - "Decorate TEXT with a clickable keymap and function face." - (let ((face (cond - ((not (file-exists-p text)) 'font-lock-warning-face) - ((file-directory-p text) 'dired-directory) - (t 'default)))) - (propertize text - 'font-lock-face face - 'mouse-face 'highlight - 'keymap cider-classpath-mouse-map))) - -(defun cider-classpath-operate-on-point () - "Expand browser according to thing at current point." - (interactive) - (let* ((bol (line-beginning-position)) - (eol (line-end-position)) - (line (buffer-substring-no-properties bol eol))) - (find-file-other-window line))) - -(defun cider-classpath-handle-mouse (_event) - "Handle mouse click EVENT." - (interactive "e") - (cider-classpath-operate-on-point)) - -;;;###autoload -(defun cider-classpath () - "List all classpath entries." - (interactive) - (cider-ensure-connected) - (with-current-buffer (cider-popup-buffer cider-classpath-buffer 'select nil 'ancillary) - (cider-classpath-list (current-buffer) - (mapcar (lambda (name) - (cider-classpath-properties name)) - (cider-classpath-entries))))) - -;;;###autoload -(defun cider-open-classpath-entry () - "Open a classpath entry." - (interactive) - (cider-ensure-connected) - (when-let* ((entry (completing-read "Classpath entries: " (cider-classpath-entries)))) - (find-file-other-window entry))) - -(provide 'cider-classpath) - -;;; cider-classpath.el ends here diff --git a/elpa/cider-20230707.640/cider-client.el b/elpa/cider-20230707.640/cider-client.el deleted file mode 100644 index d9975263..00000000 --- a/elpa/cider-20230707.640/cider-client.el +++ /dev/null @@ -1,849 +0,0 @@ -;;; cider-client.el --- A layer of abstraction above low-level nREPL client code. -*- lexical-binding: t -*- - -;; Copyright © 2013-2023 Bozhidar Batsov -;; -;; Author: Bozhidar Batsov - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; A layer of abstraction above the low-level nREPL client code. - -;;; Code: - -(require 'map) -(require 'seq) -(require 'subr-x) -(require 'parseedn) - -(require 'clojure-mode) -(require 'spinner) - -(require 'cider-connection) -(require 'cider-common) -(require 'cider-util) -(require 'nrepl-client) - - -;;; Eval spinner -(defcustom cider-eval-spinner-type 'progress-bar - "Appearance of the evaluation spinner. - -Value is a symbol. The possible values are the symbols in the -`spinner-types' variable." - :type 'symbol - :group 'cider - :package-version '(cider . "0.10.0")) - -(defcustom cider-show-eval-spinner t - "When true, show the evaluation spinner in the mode line." - :type 'boolean - :group 'cider - :package-version '(cider . "0.10.0")) - -(defcustom cider-eval-spinner-delay 1 - "Amount of time, in seconds, after which the evaluation spinner will be shown." - :type 'integer - :group 'cider - :package-version '(cider . "0.10.0")) - -(defcustom cider-enhanced-cljs-completion-p t - "This setting enables dynamic cljs completions. -That is, expressions at point are evaluated and the properties of the -resulting value are used to compute completions." - :type 'boolean - :group 'cider - :package-version '(cider . "0.23.0")) - -(defcustom cider-before-eval-hook nil - "List of functions to call before eval request is sent to nrepl." - :type 'hook - :group 'cider - :package-version '(cider . "1.2.0")) - -(defcustom cider-after-eval-done-hook nil - "List of functions to call after eval was responded by nrepl with done status." - :type 'hook - :group 'cider - :package-version '(cider . "1.2.0")) - -(defun cider-spinner-start (buffer) - "Start the evaluation spinner in BUFFER. -Do nothing if `cider-show-eval-spinner' is nil." - (when cider-show-eval-spinner - (with-current-buffer buffer - (spinner-start cider-eval-spinner-type nil - cider-eval-spinner-delay)))) - -(defun cider-eval-spinner (eval-buffer response) - "Handle RESPONSE stopping the spinner. -EVAL-BUFFER is the buffer where the spinner was started." - ;; buffer still exists and - ;; we've got status "done" from nrepl - ;; stop the spinner - (when (and (buffer-live-p eval-buffer) - (let ((status (nrepl-dict-get response "status"))) - (or (member "done" status) - (member "eval-error" status) - (member "error" status)))) - (with-current-buffer eval-buffer - (when spinner-current (spinner-stop))))) - - -;;; Evaluation helpers -(defun cider-ns-form-p (form) - "Check if FORM is an ns form." - (string-match-p "^[[:space:]]*\(ns\\([[:space:]]*$\\|[[:space:]]+\\)" form)) - -(defun cider-ns-from-form (ns-form) - "Get ns substring from NS-FORM." - (when (string-match "^[ \t\n]*\(ns[ \t\n]+\\([^][ \t\n(){}]+\\)" ns-form) - (match-string-no-properties 1 ns-form))) - -(defvar-local cider-buffer-ns nil - "Current Clojure namespace of some buffer. -Useful for special buffers (e.g. REPL, doc buffers) that have to keep track -of a namespace. This should never be set in Clojure buffers, as there the -namespace should be extracted from the buffer's ns form.") - -(defun cider-current-ns (&optional no-default) - "Return the current ns. -The ns is extracted from the ns form for Clojure buffers and from -`cider-buffer-ns' for all other buffers. If it's missing, use the current -REPL's ns, otherwise fall back to \"user\". When NO-DEFAULT is non-nil, it -will return nil instead of \"user\"." - (or cider-buffer-ns - (clojure-find-ns) - (when-let* ((repl (cider-current-repl))) - (buffer-local-value 'cider-buffer-ns repl)) - (if no-default nil "user"))) - -(defun cider-path-to-ns (relpath) - "Transform RELPATH to Clojure namespace. -Remove extension and substitute \"/\" with \".\", \"_\" with \"-\"." - (thread-last - relpath - (file-name-sans-extension) - (replace-regexp-in-string "/" ".") - (replace-regexp-in-string "_" "-"))) - -(defun cider-expected-ns (&optional path) - "Return the namespace string matching PATH, or nil if not found. -If PATH is nil, use the path to the file backing the current buffer. The -command falls back to `clojure-expected-ns' in the absence of an active -nREPL connection." - (if (cider-connected-p) - (let* ((path (file-truename (or path buffer-file-name))) - (relpath (thread-last - (cider-classpath-entries) - (seq-filter #'file-directory-p) - (seq-map (lambda (dir) - (when (file-in-directory-p path dir) - (file-relative-name path dir)))) - (seq-filter #'identity) - (seq-sort (lambda (a b) - (< (length a) (length b)))) - (car)))) - (if relpath - (cider-path-to-ns relpath) - (clojure-expected-ns path))) - (clojure-expected-ns path))) - -(defun cider-nrepl-op-supported-p (op &optional connection skip-ensure) - "Check whether the CONNECTION supports the nREPL middleware OP. -Skip check if repl is active if SKIP-ENSURE is non nil." - (nrepl-op-supported-p op (or connection (cider-current-repl nil (if skip-ensure - nil - 'ensure))))) - -(defun cider-ensure-op-supported (op) - "Check for support of middleware op OP. -Signal an error if it is not supported." - (unless (cider-nrepl-op-supported-p op) - (user-error "`%s' requires the nREPL op \"%s\" (provided by cider-nrepl)" this-command op))) - -(defun cider-nrepl-send-request (request callback &optional connection tooling) - "Send REQUEST and register response handler CALLBACK. -REQUEST is a pair list of the form (\"op\" \"operation\" \"par1-name\" - \"par1\" ... ). -If CONNECTION is provided dispatch to that connection instead of -the current connection. Return the id of the sent message. -If TOOLING is truthy then the tooling session is used." - (nrepl-send-request request callback (or connection (cider-current-repl 'any 'ensure)) tooling)) - -(defun cider-nrepl-send-sync-request (request &optional connection abort-on-input) - "Send REQUEST to the nREPL server synchronously using CONNECTION. -Hold till final \"done\" message has arrived and join all response messages -of the same \"op\" that came along and return the accumulated response. -If ABORT-ON-INPUT is non-nil, the function will return nil -at the first sign of user input, so as not to hang the -interface." - (nrepl-send-sync-request request - (or connection (cider-current-repl 'any 'ensure)) - abort-on-input)) - -(defun cider-nrepl-send-unhandled-request (request &optional connection) - "Send REQUEST to the nREPL CONNECTION and ignore any responses. -Immediately mark the REQUEST as done. Return the id of the sent message." - (let* ((conn (or connection (cider-current-repl 'any 'ensure))) - (id (nrepl-send-request request #'ignore conn))) - (with-current-buffer conn - (nrepl--mark-id-completed id)) - id)) - -(defun cider-nrepl-request:eval (input callback &optional ns line column additional-params connection) - "Send the request INPUT and register the CALLBACK as the response handler. -If NS is non-nil, include it in the request. LINE and COLUMN, if non-nil, -define the position of INPUT in its buffer. ADDITIONAL-PARAMS is a plist -to be appended to the request message. CONNECTION is the connection -buffer, defaults to (cider-current-repl)." - (let ((connection (or connection (cider-current-repl nil 'ensure))) - (eval-buffer (current-buffer))) - (run-hooks 'cider-before-eval-hook) - (nrepl-request:eval input - (lambda (response) - (when cider-show-eval-spinner - (cider-eval-spinner connection response)) - (when (and (buffer-live-p eval-buffer) - (member "done" (nrepl-dict-get response "status"))) - (with-current-buffer eval-buffer - (run-hooks 'cider-after-eval-done-hook))) - (funcall callback response)) - connection - ns line column additional-params) - (cider-spinner-start connection))) - -(defun cider-nrepl-sync-request:eval (input &optional connection ns) - "Send the INPUT to the nREPL CONNECTION synchronously. -If NS is non-nil, include it in the eval request." - (nrepl-sync-request:eval input (or connection (cider-current-repl nil 'ensure)) ns)) - -(defcustom cider-format-code-options nil - "A map of options that will be passed to `cljfmt' to format code. -Assuming this is the Clojure map you want to use as `cljfmt' options: - - {:indents {org.me/foo [[:inner 0]]} - :alias-map {\"me\" \"org.me\"}} - -you need to encode it as the following plist: - - '((\"indents\" ((\"org.me/foo\" ((\"inner\" 0))))) (\"alias-map\" ((\"me\" \"org.me\"))))" - :type 'list - :group 'cider - :package-version '(cider . "1.1.0")) - -(defun cider--nrepl-format-code-request-map (&optional format-options) - "Map to merge into requests that require code formatting. -If non-nil, FORMAT-OPTIONS specifies the options cljfmt will use to format -the code. See `cider-format-code-options` for details." - (when format-options - (let* ((indents-dict (when (assoc "indents" format-options) - (thread-last - (cadr (assoc "indents" format-options)) - (map-pairs) - (seq-mapcat #'identity) - (apply #'nrepl-dict)))) - (alias-map-dict (when (assoc "alias-map" format-options) - (thread-last - (cadr (assoc "alias-map" format-options)) - (map-pairs) - (seq-mapcat #'identity) - (apply #'nrepl-dict))))) - (thread-last - (map-merge 'list - (when indents-dict - `(("indents" ,indents-dict))) - (when alias-map-dict - `(("alias-map" ,alias-map-dict)))) - (map-pairs) - (seq-mapcat #'identity) - (apply #'nrepl-dict))))) - -(defcustom cider-print-fn 'pprint - "Sets the function to use for printing. - -nil – to defer to nREPL to choose the printing function. This will use -the bound value of \\=`nrepl.middleware.print/*print-fn*\\=`, which -defaults to the equivalent of \\=`clojure.core/pr\\=`. - -`pr' – to use the equivalent of \\=`clojure.core/pr\\=`. - -`pprint' – to use \\=`clojure.pprint/pprint\\=` (this is the default). - -`fipp' – to use the Fast Idiomatic Pretty Printer, approximately 5-10x -faster than \\=`clojure.core/pprint\\=`. - -`puget' – to use Puget, which provides canonical serialization of data on -top of fipp, but at a slight performance cost. - -`zprint' – to use zprint, a fast and flexible alternative to the libraries -mentioned above. - -Alternatively can be the namespace-qualified name of a Clojure var whose -function takes three arguments: the object to print, the -\\=`java.io.PrintWriter\\=` to print on, and a (possibly nil) map of -options. If the function cannot be resolved, will behave as if set to -nil." - :type '(choice (const nil) - (const pr) - (const pprint) - (const fipp) - (const puget) - (const zprint) - string) - :group 'cider - :package-version '(cider . "0.21.0")) - -(defcustom cider-print-options nil - "A map of options that will be passed to `cider-print-fn'. -Here's an example for `pprint': - - '((\"length\" 50) (\"right-margin\" 70))" - :type 'list - :group 'cider - :package-version '(cider . "0.21.0")) - -(make-obsolete-variable 'cider-pprint-fn 'cider-print-fn "0.21") -(make-obsolete-variable 'cider-pprint-options 'cider-print-options "0.21") - -(defcustom cider-print-quota (* 1024 1024) - "A hard limit on the number of bytes to return from any printing operation. -Set to nil for no limit." - :type 'integer - :group 'cider - :package-version '(cider . "0.21.0")) - -(defcustom cider-print-buffer-size (* 4 1024) - "The size in bytes of each value/output chunk when using print streaming. -Smaller values mean smaller data chunks and faster feedback, but they also mean -smaller results that can be font-locked as Clojure in the REPL buffers, as only -a single chunk result can be font-locked. - -The default value in nREPL is 1024." - :type 'integer - :group 'cider - :package-version '(cider . "0.25.0")) - -(defun cider--print-fn () - "Return the value to send in the nrepl.middleware.print/print slot." - (pcase cider-print-fn - (`pr "cider.nrepl.pprint/pr") - (`pprint "cider.nrepl.pprint/pprint") - (`fipp "cider.nrepl.pprint/fipp-pprint") - (`puget "cider.nrepl.pprint/puget-pprint") - (`zprint "cider.nrepl.pprint/zprint-pprint") - (_ cider-print-fn))) - -(defvar cider--print-options-mapping - '((right-margin - ((fipp . width) (puget . width) (zprint . width))) - (length - ((fipp . print-length) (puget . print-length) (zprint . max-length))) - (level - ((fipp . print-level) (puget . print-level) (zprint . max-depth)))) - "A mapping of print option for the various supported print engines.") - -(defun cider--print-option (name printer) - "Convert the generic NAME to its PRINTER specific variant. -E.g. pprint's right-margin would become width for fipp. -The function is useful when you want to generate dynamically -print options. - -NAME can be a string or a symbol. PRINTER has to be a symbol. -The result will be a string." - (let* ((name (cider-maybe-intern name)) - (result (cdr (assoc printer (cadr (assoc name cider--print-options-mapping)))))) - (symbol-name (or result name)))) - -(defun cider--nrepl-print-request-map (&optional right-margin) - "Map to merge into requests that require pretty-printing. -RIGHT-MARGIN specifies the maximum column-width of the printed result, and -is included in the request if non-nil." - (let* ((width-option (cider--print-option "right-margin" cider-print-fn)) - (print-options (thread-last - (map-merge 'hash-table - `((,width-option ,right-margin)) - cider-print-options) - (map-pairs) - (seq-mapcat #'identity) - (apply #'nrepl-dict)))) - (map-merge 'list - `(("nrepl.middleware.print/stream?" "1")) - (when cider-print-fn - `(("nrepl.middleware.print/print" ,(cider--print-fn)))) - (when cider-print-quota - `(("nrepl.middleware.print/quota" ,cider-print-quota))) - (when cider-print-buffer-size - `(("nrepl.middleware.print/buffer-size" ,cider-print-buffer-size))) - (unless (nrepl-dict-empty-p print-options) - `(("nrepl.middleware.print/options" ,print-options)))))) - -(defun cider--nrepl-pr-request-map () - "Map to merge into requests that do not require pretty printing." - (let ((print-options (thread-last - cider-print-options - (map-pairs) - (seq-mapcat #'identity) - (apply #'nrepl-dict)))) - (map-merge 'list - `(("nrepl.middleware.print/print" "cider.nrepl.pprint/pr") - ("nrepl.middleware.print/stream?" nil)) - (unless (nrepl-dict-empty-p print-options) - `(("nrepl.middleware.print/options" ,print-options))) - (when cider-print-quota - `(("nrepl.middleware.print/quota" ,cider-print-quota)))))) - -(defun cider--nrepl-content-type-map () - "Map to be merged into an eval request to make it use content-types." - '(("content-type" "true"))) - -(defun cider-tooling-eval (input callback &optional ns connection) - "Send the request INPUT to CONNECTION and register the CALLBACK. -NS specifies the namespace in which to evaluate the request. Requests -evaluated in the tooling nREPL session don't affect the thread-local -bindings of the primary eval nREPL session (e.g. this is not going to -clobber *1/2/3)." - ;; namespace forms are always evaluated in the "user" namespace - (nrepl-request:eval input - callback - (or connection (cider-current-repl nil 'ensure)) - ns nil nil nil 'tooling)) - -(defun cider-sync-tooling-eval (input &optional ns connection) - "Send the request INPUT to CONNECTION and evaluate in synchronously. -NS specifies the namespace in which to evaluate the request. Requests -evaluated in the tooling nREPL session don't affect the thread-local -bindings of the primary eval nREPL session (e.g. this is not going to -clobber *1/2/3)." - ;; namespace forms are always evaluated in the "user" namespace - (nrepl-sync-request:eval input - (or connection (cider-current-repl nil 'ensure)) - ns - 'tooling)) - -(defun cider-library-present-p (lib-ns) - "Check whether LIB-NS is present. -If a certain well-known ns in a library is present we assume that library -itself is present." - (nrepl-dict-get (cider-sync-tooling-eval (format "(require '%s)" lib-ns)) "value")) - - -;;; Interrupt evaluation - -(defun cider-interrupt-handler (buffer) - "Create an interrupt response handler for BUFFER." - (nrepl-make-response-handler buffer nil nil nil nil)) - -(defun cider-interrupt () - "Interrupt any pending evaluations." - (interactive) - ;; FIXME: does this work correctly in cljc files? - (with-current-buffer (cider-current-repl nil 'ensure) - (let ((pending-request-ids (cider-util--hash-keys nrepl-pending-requests))) - (dolist (request-id pending-request-ids) - (nrepl-request:interrupt - request-id - (cider-interrupt-handler (current-buffer)) - (cider-current-repl)))))) - -(defun cider-nrepl-eval-session () - "Return the eval nREPL session id of the current connection." - (with-current-buffer (cider-current-repl) - nrepl-session)) - -(defun cider-nrepl-tooling-session () - "Return the tooling nREPL session id of the current connection." - (with-current-buffer (cider-current-repl) - nrepl-tooling-session)) - -(defun cider--var-choice (var-info) - "Prompt to choose from among multiple VAR-INFO candidates, if required. -This is needed only when the symbol queried is an unqualified host platform -method, and multiple classes have a so-named member. If VAR-INFO does not -contain a `candidates' key, it is returned as is." - (let ((candidates (nrepl-dict-get var-info "candidates"))) - (if candidates - (let* ((classes (nrepl-dict-keys candidates)) - (choice (completing-read "Member in class: " classes nil t)) - (info (nrepl-dict-get candidates choice))) - info) - var-info))) - -;; FIXME: Now that nREPL supports a lookup op natively, we should -;; remove this eval-based hack at some point. -(defconst cider-info-form " -(do - (require 'clojure.java.io) - (require 'clojure.walk) - - (if-let [var (resolve '%s)] - (let [info (meta var)] - (-> info - (update :ns str) - (update :name str) - (update :file (comp str clojure.java.io/resource)) - (cond-> (:macro info) (update :macro str)) - (cond-> (:special-form info) (update :special-form str)) - (cond-> (:protocol info) (update :protocol str)) - (cond-> (:arglists info) (update :arglists str)) - (assoc :arglists-str (str (:arglists info))) - (clojure.walk/stringify-keys))))) -") - -(defun cider-fallback-eval:info (var) - "Obtain VAR metadata via a regular eval. -Used only when the info nREPL middleware is not available." - (let* ((response (cider-sync-tooling-eval (format cider-info-form var))) - (var-info (nrepl-dict-from-hash (parseedn-read-str (nrepl-dict-get response "value"))))) - var-info)) - -(defun cider-var-info (var &optional all) - "Return VAR's info as an alist with list cdrs. -When multiple matching vars are returned you'll be prompted to select one, -unless ALL is truthy." - (when (and var (not (string= var ""))) - (let ((var-info (cond - ((cider-nrepl-op-supported-p "info") (cider-sync-request:info var)) - ((cider-nrepl-op-supported-p "lookup") (cider-sync-request:lookup var)) - (t (cider-fallback-eval:info var))))) - (if all var-info (cider--var-choice var-info))))) - -(defun cider-member-info (class member) - "Return the CLASS MEMBER's info as an alist with list cdrs." - (when (and class member) - (cider-sync-request:info nil class member))) - - -;;; Requests - -(declare-function cider-load-file-handler "cider-eval") -(defun cider-request:load-file (file-contents file-path file-name &optional connection callback) - "Perform the nREPL \"load-file\" op. -FILE-CONTENTS, FILE-PATH and FILE-NAME are details of the file to be -loaded. If CONNECTION is nil, use `cider-current-repl'. If CALLBACK -is nil, use `cider-load-file-handler'." - (cider-nrepl-send-request `("op" "load-file" - "file" ,file-contents - "file-path" ,file-path - "file-name" ,file-name) - (or callback - (cider-load-file-handler (current-buffer))) - connection)) - - -;;; Sync Requests - -(defcustom cider-filtered-namespaces-regexps - '("^cider.nrepl" "^refactor-nrepl" "^nrepl") - "List of regexps used to filter out some vars/symbols/namespaces. -When nil, nothing is filtered out. Otherwise, all namespaces matching any -regexp from this list are dropped out of the \"ns-list\" op. Also, -\"apropos\" won't include vars from such namespaces. This list is passed -on to the nREPL middleware without any pre-processing. So the regexps have -to be in Clojure format (with twice the number of backslashes) and not -Emacs Lisp." - :type '(repeat string) - :safe #'listp - :group 'cider - :package-version '(cider . "0.13.0")) - -(defun cider-sync-request:apropos (query &optional search-ns docs-p privates-p case-sensitive-p) - "Send \"apropos\" request for regexp QUERY. - -Optional arguments include SEARCH-NS, DOCS-P, PRIVATES-P, CASE-SENSITIVE-P." - (let* ((query (replace-regexp-in-string "[ \t]+" ".+" query)) - (response (cider-nrepl-send-sync-request - `("op" "apropos" - "ns" ,(cider-current-ns) - "query" ,query - ,@(when search-ns `("search-ns" ,search-ns)) - ,@(when docs-p '("docs?" "t")) - ,@(when privates-p '("privates?" "t")) - ,@(when case-sensitive-p '("case-sensitive?" "t")) - "exclude-regexps" ,cider-filtered-namespaces-regexps)))) - (if (member "apropos-regexp-error" (nrepl-dict-get response "status")) - (user-error "Invalid regexp: %s" (nrepl-dict-get response "error-msg")) - (nrepl-dict-get response "apropos-matches")))) - -(defun cider-sync-request:classpath () - "Return a list of classpath entries." - (cider-ensure-op-supported "classpath") - (thread-first - '("op" "classpath") - (cider-nrepl-send-sync-request) - (nrepl-dict-get "classpath"))) - -(defun cider--get-abs-path (path project) - "Resolve PATH to an absolute path relative to PROJECT. -Do nothing if PATH is already absolute." - (if (not (file-name-absolute-p path)) - (expand-file-name path project) - path)) - -(defun cider-fallback-eval:classpath () - "Return a list of classpath entries using eval. - -Sometimes the classpath contains entries like src/main and we need to -resolve those to absolute paths." - (when (cider-runtime-clojure-p) - (let ((classpath (thread-first - "(seq (.split (System/getProperty \"java.class.path\") \":\"))" - (cider-sync-tooling-eval) - (nrepl-dict-get "value") - read)) - (project (clojure-project-dir))) - (mapcar (lambda (path) (cider--get-abs-path path project)) classpath)))) - -(defun cider-classpath-entries () - "Return a list of classpath entries." - (seq-map #'expand-file-name ; normalize filenames for e.g. Windows - (if (cider-nrepl-op-supported-p "classpath") - (cider-sync-request:classpath) - (cider-fallback-eval:classpath)))) - -(defun cider-sync-request:completion (prefix) - "Return a list of completions for PREFIX using nREPL's \"completion\" op." - (when-let* ((dict (thread-first `("op" "completions" - "ns" ,(cider-current-ns) - "prefix" ,prefix) - (cider-nrepl-send-sync-request (cider-current-repl) - 'abort-on-input)))) - (nrepl-dict-get dict "completions"))) - -(defun cider-sync-request:complete (prefix context) - "Return a list of completions for PREFIX using nREPL's \"complete\" op. -CONTEXT represents a completion context for compliment." - (when-let* ((dict (thread-first `("op" "complete" - "ns" ,(cider-current-ns) - "prefix" ,prefix - "context" ,context - ,@(when cider-enhanced-cljs-completion-p '("enhanced-cljs-completion?" "t"))) - (cider-nrepl-send-sync-request (cider-current-repl) - 'abort-on-input)))) - (nrepl-dict-get dict "completions"))) - -(defun cider-sync-request:complete-flush-caches () - "Send \"complete-flush-caches\" op to flush Compliment's caches." - (cider-nrepl-send-sync-request (list "op" "complete-flush-caches" - "session" (cider-nrepl-eval-session)) - nil - 'abort-on-input)) - -(defun cider-sync-request:info (symbol &optional class member) - "Send \"info\" op with parameters SYMBOL or CLASS and MEMBER." - (let ((var-info (thread-first `("op" "info" - "ns" ,(cider-current-ns) - ,@(when symbol `("sym" ,symbol)) - ,@(when class `("class" ,class)) - ,@(when member `("member" ,member))) - (cider-nrepl-send-sync-request (cider-current-repl))))) - (if (member "no-info" (nrepl-dict-get var-info "status")) - nil - var-info))) - -(defun cider-sync-request:lookup (symbol &optional lookup-fn) - "Send \"lookup\" op request with parameters SYMBOL and LOOKUP-FN." - (let ((var-info (thread-first `("op" "lookup" - "ns" ,(cider-current-ns) - ,@(when symbol `("sym" ,symbol)) - ,@(when lookup-fn `("lookup-fn" ,lookup-fn))) - (cider-nrepl-send-sync-request (cider-current-repl))))) - (if (member "lookup-error" (nrepl-dict-get var-info "status")) - nil - (nrepl-dict-get var-info "info")))) - -(defun cider-sync-request:eldoc (symbol &optional class member) - "Send \"eldoc\" op with parameters SYMBOL or CLASS and MEMBER." - (when-let* ((eldoc (thread-first `("op" "eldoc" - "ns" ,(cider-current-ns) - ,@(when symbol `("sym" ,symbol)) - ,@(when class `("class" ,class)) - ,@(when member `("member" ,member))) - (cider-nrepl-send-sync-request (cider-current-repl) - 'abort-on-input)))) - (if (member "no-eldoc" (nrepl-dict-get eldoc "status")) - nil - eldoc))) - -(defun cider-sync-request:eldoc-datomic-query (symbol) - "Send \"eldoc-datomic-query\" op with parameter SYMBOL." - (when-let* ((eldoc (thread-first `("op" "eldoc-datomic-query" - "ns" ,(cider-current-ns) - ,@(when symbol `("sym" ,symbol))) - (cider-nrepl-send-sync-request nil 'abort-on-input)))) - (if (member "no-eldoc" (nrepl-dict-get eldoc "status")) - nil - eldoc))) - -(defun cider-sync-request:spec-list (&optional filter-regex) - "Get a list of the available specs in the registry. -Optional argument FILTER-REGEX filters specs. By default, all specs are -returned." - (setq filter-regex (or filter-regex "")) - (thread-first `("op" "spec-list" - "filter-regex" ,filter-regex - "ns" ,(cider-current-ns)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "spec-list"))) - -(defun cider-sync-request:spec-form (spec) - "Get SPEC's form from registry." - (thread-first `("op" "spec-form" - "spec-name" ,spec - "ns" ,(cider-current-ns)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "spec-form"))) - -(defun cider-sync-request:spec-example (spec) - "Get an example for SPEC." - (thread-first `("op" "spec-example" - "spec-name" ,spec) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "spec-example"))) - -(defun cider-sync-request:ns-list () - "Get a list of the available namespaces." - (thread-first `("op" "ns-list" - "exclude-regexps" ,cider-filtered-namespaces-regexps) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "ns-list"))) - -(defun cider-sync-request:ns-vars (ns) - "Get a list of the vars in NS." - (thread-first `("op" "ns-vars" - "ns" ,ns) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "ns-vars"))) - -(defun cider-sync-request:ns-path (ns) - "Get the path to the file containing NS." - (thread-first `("op" "ns-path" - "ns" ,ns) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "path"))) - -(defun cider-sync-request:ns-vars-with-meta (ns) - "Get a map of the vars in NS to its metadata information." - (thread-first `("op" "ns-vars-with-meta" - "ns" ,ns) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "ns-vars-with-meta"))) - -(defun cider-sync-request:private-ns-vars-with-meta (ns) - "Get a map of the vars in NS to its metadata information." - (thread-first `("op" "ns-vars-with-meta" - "ns" ,ns - "var-query" ,(nrepl-dict "private?" "t" - "include-meta-key" '("private"))) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "ns-vars-with-meta"))) - -(defun cider-sync-request:ns-load-all () - "Load all project namespaces." - (thread-first '("op" "ns-load-all") - (cider-nrepl-send-sync-request) - (nrepl-dict-get "loaded-ns"))) - -(defun cider-sync-request:resource (name) - "Perform nREPL \"resource\" op with resource name NAME." - (thread-first `("op" "resource" - "name" ,name) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "resource-path"))) - -(defun cider-sync-request:resources-list () - "Return a list of all resources on the classpath. -The result entries are relative to the classpath." - (when-let* ((resources (thread-first '("op" "resources-list") - (cider-nrepl-send-sync-request) - (nrepl-dict-get "resources-list")))) - (seq-map (lambda (resource) (nrepl-dict-get resource "relpath")) resources))) - -(defun cider-sync-request:fn-refs (ns sym) - "Return a list of functions that reference the function identified by NS and SYM." - (cider-ensure-op-supported "fn-refs") - (thread-first `("op" "fn-refs" - "ns" ,ns - "sym" ,sym) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "fn-refs"))) - -(defun cider-sync-request:fn-deps (ns sym) - "Return a list of function deps for the function identified by NS and SYM." - (cider-ensure-op-supported "fn-deps") - (thread-first `("op" "fn-deps" - "ns" ,ns - "sym" ,sym) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "fn-deps"))) - -(defun cider-sync-request:format-code (code &optional format-options) - "Perform nREPL \"format-code\" op with CODE. -FORMAT-OPTIONS is an optional configuration map for cljfmt." - (let* ((request `("op" "format-code" - "options" ,(cider--nrepl-format-code-request-map format-options) - "code" ,code)) - (response (cider-nrepl-send-sync-request request)) - (err (nrepl-dict-get response "err"))) - (when err - ;; err will be a stacktrace with a first line that looks like: - ;; "clojure.lang.ExceptionInfo: Unmatched delimiter ]" - (error (car (split-string err "\n")))) - (nrepl-dict-get response "formatted-code"))) - -(defun cider-sync-request:format-edn (edn right-margin) - "Perform \"format-edn\" op with EDN and RIGHT-MARGIN." - (let* ((request (thread-last - (map-merge 'list - `(("op" "format-edn") - ("edn" ,edn)) - (cider--nrepl-print-request-map right-margin)) - (seq-mapcat #'identity))) - (response (cider-nrepl-send-sync-request request)) - (err (nrepl-dict-get response "err"))) - (when err - ;; err will be a stacktrace with a first line that looks like: - ;; "clojure.lang.ExceptionInfo: Unmatched delimiter ]" - (error (car (split-string err "\n")))) - (nrepl-dict-get response "formatted-edn"))) - -;;; Dealing with input -;; TODO: Replace this with some nil handler. -(defun cider-stdin-handler (&optional _buffer) - "Make a stdin response handler for _BUFFER." - (nrepl-make-response-handler (current-buffer) - (lambda (_buffer _value)) - (lambda (_buffer _out)) - (lambda (_buffer _err)) - nil)) - -(defun cider-need-input (buffer) - "Handle an need-input request from BUFFER." - (with-current-buffer buffer - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map (kbd "C-c C-c") #'abort-recursive-edit) - (let ((stdin (condition-case nil - (concat (read-from-minibuffer "Stdin: " nil map) "\n") - (quit nil)))) - (nrepl-request:stdin stdin - (cider-stdin-handler buffer) - (cider-current-repl)))))) - -(provide 'cider-client) - -;;; cider-client.el ends here diff --git a/elpa/cider-20230707.640/cider-clojuredocs.el b/elpa/cider-20230707.640/cider-clojuredocs.el deleted file mode 100644 index 3e51a075..00000000 --- a/elpa/cider-20230707.640/cider-clojuredocs.el +++ /dev/null @@ -1,171 +0,0 @@ -;;; cider-clojuredocs.el --- ClojureDocs integration -*- lexical-binding: t -*- - -;; Copyright © 2014-2023 Bozhidar Batsov and CIDER contributors -;; -;; Author: Bozhidar Batsov - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; A few commands for ClojureDocs documentation lookup. - -;;; Code: - -(require 'cider-client) -(require 'cider-common) -(require 'subr-x) -(require 'cider-popup) - -(require 'nrepl-dict) - -(require 'url-vars) - -(defconst cider-clojuredocs-url "https://clojuredocs.org/") - -(defconst cider-clojuredocs-buffer "*cider-clojuredocs*") - -(defun cider-sync-request:clojuredocs-lookup (ns sym) - "Perform nREPL \"resource\" op with NS and SYM." - (thread-first `("op" "clojuredocs-lookup" - "ns" ,ns - "sym" ,sym) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "clojuredocs"))) - -(defun cider-sync-request:clojuredocs-refresh () - "Refresh the ClojureDocs cache." - (thread-first '("op" "clojuredocs-refresh-cache") - (cider-nrepl-send-sync-request) - (nrepl-dict-get "status"))) - -(defun cider-clojuredocs-replace-special (name) - "Convert the dashes in NAME to a ClojureDocs friendly format. -We need to handle \"?\", \".\", \"..\" and \"/\"." - (thread-last - name - (replace-regexp-in-string "\\?" "_q") - (replace-regexp-in-string "\\(\\.+\\)" "_\\1") - (replace-regexp-in-string "/" "fs"))) - -(defun cider-clojuredocs-url (name ns) - "Generate a ClojureDocs url from NAME and NS." - (let ((base-url cider-clojuredocs-url)) - (when (and name ns) - (concat base-url ns "/" (cider-clojuredocs-replace-special name))))) - -(defun cider-clojuredocs-web-lookup (sym) - "Open the ClojureDocs documentation for SYM in a web browser." - (if-let* ((var-info (cider-var-info sym))) - (let ((name (nrepl-dict-get var-info "name")) - (ns (nrepl-dict-get var-info "ns"))) - (browse-url (cider-clojuredocs-url name ns))) - (error "Symbol %s not resolved" sym))) - -;;;###autoload -(defun cider-clojuredocs-web (&optional arg) - "Open ClojureDocs documentation in the default web browser. - -Prompts for the symbol to use, or uses the symbol at point, depending on -the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the -opposite of what that option dictates." - (interactive "P") - (funcall (cider-prompt-for-symbol-function arg) - "ClojureDocs doc for" - #'cider-clojuredocs-web-lookup)) - -;;;###autoload -(defun cider-clojuredocs-refresh-cache () - "Refresh the ClojureDocs cache." - (interactive) - (let ((result (cider-sync-request:clojuredocs-refresh))) - (if (member "ok" result) - (message "ClojureDocs cache refreshed successfully") - (message "An error occurred while trying to refresh the ClojureDocs cache")))) - -(defun cider-create-clojuredocs-buffer (content) - "Create a new ClojureDocs buffer with CONTENT." - (with-current-buffer (cider-popup-buffer cider-clojuredocs-buffer t) - (read-only-mode -1) - (set-syntax-table clojure-mode-syntax-table) - (local-set-key (kbd "C-c C-d C-c") 'cider-clojuredocs) - (insert content) - (cider-popup-buffer-mode 1) - (view-mode 1) - (goto-char (point-min)) - (current-buffer))) - -(defun cider-clojuredocs--content (dict) - "Generate a nice string from DICT." - (with-temp-buffer - (insert "= " (nrepl-dict-get dict "ns") "/" (nrepl-dict-get dict "name") "\n\n") - (let ((arglists (nrepl-dict-get dict "arglists"))) - (dolist (arglist arglists) - (insert (format " [%s]\n" arglist))) - (insert "\n") - (insert (nrepl-dict-get dict "doc")) - (insert "\n")) - (insert "\n== See Also\n\n") - (if-let ((see-alsos (nrepl-dict-get dict "see-alsos"))) - (dolist (see-also see-alsos) - (insert-text-button (format "* %s\n" see-also) - 'sym see-also - 'action (lambda (btn) - (cider-clojuredocs-lookup (button-get btn 'sym))) - 'help-echo (format "Press Enter or middle click to jump to %s" see-also))) - (insert "Not available\n")) - (insert "\n== Examples\n\n") - (if-let ((examples (nrepl-dict-get dict "examples"))) - (dolist (example examples) - (insert (cider-font-lock-as-clojure example)) - (insert "\n-------------------------------------------------\n")) - (insert "Not available\n")) - (insert "\n== Notes\n\n") - (if-let ((notes (nrepl-dict-get dict "notes"))) - (dolist (note notes) - (insert note) - (insert "\n-------------------------------------------------\n")) - (insert "Not available\n")) - (buffer-string))) - -(defun cider-clojuredocs-lookup (sym) - "Look up the ClojureDocs documentation for SYM." - (let ((docs (cider-sync-request:clojuredocs-lookup (cider-current-ns) sym))) - (pop-to-buffer (cider-create-clojuredocs-buffer (cider-clojuredocs--content docs))) - ;; highlight the symbol in question in the docs buffer - (highlight-regexp - (regexp-quote - (or (cadr (split-string sym "/")) - sym)) - 'bold))) - -;;;###autoload -(defun cider-clojuredocs (&optional arg) - "Open ClojureDocs documentation in a popup buffer. - -Prompts for the symbol to use, or uses the symbol at point, depending on -the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the -opposite of what that option dictates." - (interactive "P") - (when (derived-mode-p 'clojurescript-mode) - (user-error "`cider-clojuredocs' doesn't support ClojureScript")) - (funcall (cider-prompt-for-symbol-function arg) - "ClojureDocs doc for" - #'cider-clojuredocs-lookup)) - -(provide 'cider-clojuredocs) - -;;; cider-clojuredocs.el ends here diff --git a/elpa/cider-20230707.640/cider-common.el b/elpa/cider-20230707.640/cider-common.el deleted file mode 100644 index 90a7382a..00000000 --- a/elpa/cider-20230707.640/cider-common.el +++ /dev/null @@ -1,442 +0,0 @@ -;;; cider-common.el --- Common use functions -*- lexical-binding: t; -*- - -;; Copyright © 2015-2023 Artur Malabarba - -;; Author: Artur Malabarba - -;; 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 . - -;;; Commentary: - -;; Common functions that are useful in both Clojure buffers and REPL -;; buffers. - -;;; Code: - -(require 'subr-x) -(require 'nrepl-dict) -(require 'cider-util) -(require 'xref) -(require 'tramp) - -(defcustom cider-prompt-for-symbol nil - "Controls when to prompt for symbol when a command requires one. - -When non-nil, always prompt, and use the symbol at point as the default -value at the prompt. - -When nil, attempt to use the symbol at point for the command, and only -prompt if that throws an error." - :type '(choice (const :tag "always" t) - (const :tag "dwim" nil)) - :group 'cider - :package-version '(cider . "0.9.0")) - -(defcustom cider-special-mode-truncate-lines t - "If non-nil, contents of CIDER's special buffers will be line-truncated. -Should be set before loading CIDER." - :type 'boolean - :group 'cider - :package-version '(cider . "0.15.0")) - -(defun cider--should-prompt-for-symbol (&optional invert) - "Return the value of the variable `cider-prompt-for-symbol'. -Optionally invert the value, if INVERT is truthy." - (if invert (not cider-prompt-for-symbol) cider-prompt-for-symbol)) - -(defun cider-prompt-for-symbol-function (&optional invert) - "Prompt for symbol if funcall `cider--should-prompt-for-symbol' is truthy. -Otherwise attempt to use the symbol at point for the command, and only -prompt if that throws an error. - -INVERT inverts the semantics of the function `cider--should-prompt-for-symbol'." - (if (cider--should-prompt-for-symbol invert) - #'cider-read-symbol-name - #'cider-try-symbol-at-point)) - -(defun cider--kw-to-symbol (kw) - "Convert the keyword KW to a symbol." - (when kw - (replace-regexp-in-string "\\`:+" "" kw))) - -;;; Minibuffer -(defvar cider-minibuffer-history '() - "History list of expressions read from the minibuffer.") - -(defvar cider-minibuffer-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map (kbd "TAB") #'complete-symbol) - (define-key map (kbd "M-TAB") #'complete-symbol) - map) - "Minibuffer keymap used for reading Clojure expressions.") - -(declare-function cider-complete-at-point "cider-completion") -(declare-function cider-eldoc "cider-eldoc") -(defun cider-read-from-minibuffer (prompt &optional value) - "Read a string from the minibuffer, prompting with PROMPT. -If VALUE is non-nil, it is inserted into the minibuffer as initial-input. -PROMPT need not end with \": \". If it doesn't, VALUE is displayed on the -prompt as a default value (used if the user doesn't type anything) and is -not used as initial input (input is left empty)." - (minibuffer-with-setup-hook - (lambda () - (set-syntax-table clojure-mode-syntax-table) - (add-hook 'completion-at-point-functions - #'cider-complete-at-point nil t) - (setq-local eldoc-documentation-function #'cider-eldoc) - (run-hooks 'eval-expression-minibuffer-setup-hook)) - (let* ((has-colon (string-match ": \\'" prompt)) - (input (read-from-minibuffer (cond - (has-colon prompt) - (value (format "%s (default %s): " prompt value)) - (t (format "%s: " prompt))) - (when has-colon value) ; initial-input - cider-minibuffer-map nil - 'cider-minibuffer-history - (unless has-colon value)))) ; default-value - (if (and (equal input "") value (not has-colon)) - value - input)))) - -(defun cider-read-symbol-name (prompt callback) - "Read a symbol name using PROMPT with a default of the one at point. -Use CALLBACK as the completing read var callback." - (funcall callback (cider-read-from-minibuffer - prompt - ;; if the thing at point is a keyword we treat it as symbol - (cider--kw-to-symbol (cider-symbol-at-point 'look-back))))) - -(defun cider-try-symbol-at-point (prompt callback) - "Call CALLBACK with symbol at point. -On failure, read a symbol name using PROMPT and call CALLBACK with that." - (condition-case nil (funcall callback (cider--kw-to-symbol (cider-symbol-at-point 'look-back))) - ('error (funcall callback (cider-read-from-minibuffer prompt))))) - -(declare-function cider-mode "cider-mode") - -(defcustom cider-jump-to-pop-to-buffer-actions - '((display-buffer-reuse-window display-buffer-same-window)) - "Determines what window `cider-jump-to` uses. -The value is passed as the `action` argument to `pop-to-buffer`. - -The default value means: - -- If the target file is already visible in a window, reuse it (switch to it). -- Otherwise, open the target buffer in the current window. - -For further details, see https://docs.cider.mx/cider/config/basic_config.html#control-what-window-to-use-when-jumping-to-a-definition" - :type 'sexp - :group 'cider - :package-version '(cider . "0.24.0")) - -(defun cider-jump-to (buffer &optional pos other-window) - "Push current point onto marker ring, and jump to BUFFER and POS. -POS can be either a number, a cons, or a symbol. -If a number, it is the character position (the point). -If a cons, it specifies the position as (LINE . COLUMN). COLUMN can be nil. -If a symbol, `cider-jump-to' searches for something that looks like the -symbol's definition in the file. -If OTHER-WINDOW is non-nil don't reuse current window." - (with-no-warnings - (xref-push-marker-stack)) - (if other-window - (pop-to-buffer buffer 'display-buffer-pop-up-window) - (pop-to-buffer buffer cider-jump-to-pop-to-buffer-actions)) - (with-current-buffer buffer - (widen) - (goto-char (point-min)) - (cider-mode +1) - (let ((status - (cond - ;; Line-column specification. - ((consp pos) - (forward-line (1- (or (car pos) 1))) - (if (cdr pos) - (move-to-column (cdr pos)) - (back-to-indentation))) - ;; Point specification. - ((numberp pos) - (goto-char pos)) - ;; Symbol or string. - (pos - ;; Try to find (def full-name ...). - (if (or (save-excursion - (search-forward-regexp (format "(def.*\\s-\\(%s\\)" (regexp-quote pos)) - nil 'noerror)) - (let ((name (replace-regexp-in-string ".*/" "" pos))) - ;; Try to find (def name ...). - (or (save-excursion - (search-forward-regexp (format "(def.*\\s-\\(%s\\)" (regexp-quote name)) - nil 'noerror)) - ;; Last resort, just find the first occurrence of `name'. - (save-excursion - (search-forward name nil 'noerror))))) - (goto-char (match-beginning 0)) - (message "Can't find %s in %s" pos (buffer-file-name)) - 'not-found)) - (t 'not-found)))) - (unless (eq status 'not-found) - ;; Make sure the location we jump to is centered within the target window - (recenter))))) - -(defun cider--find-buffer-for-file (file) - "Return a buffer visiting FILE. -If FILE is a temp buffer name, return that buffer." - (if (string-prefix-p "*" file) - file - (and file - (not (cider--tooling-file-p file)) - (cider-find-file file)))) - -(defun cider--jump-to-loc-from-info (info &optional other-window) - "Jump to location give by INFO. -INFO object is returned by `cider-var-info' or `cider-member-info'. -OTHER-WINDOW is passed to `cider-jump-to'." - (let* ((line (nrepl-dict-get info "line")) - (file (nrepl-dict-get info "file")) - (name (nrepl-dict-get info "name")) - ;; the filename might actually be a REPL buffer name - (buffer (cider--find-buffer-for-file file))) - (if buffer - (cider-jump-to buffer (if line (cons line nil) name) other-window) - (error "No source location")))) - -(declare-function url-filename "url-parse" (cl-x) t) - -(defun cider--url-to-file (url) - "Return the filename from the resource URL. -Uses `url-generic-parse-url' to parse the url. The filename is extracted and -then url decoded. If the decoded filename has a Windows device letter followed -by a colon immediately after the leading '/' then the leading '/' is dropped to -create a valid path." - (let ((filename (url-unhex-string (url-filename (url-generic-parse-url url))))) - (if (string-match "^/\\([a-zA-Z]:/.*\\)" filename) - (match-string 1 filename) - filename))) - -(defun cider-make-tramp-prefix (method user host) - "Constructs a Tramp file prefix from METHOD, USER, HOST. -It originated from Tramp's `tramp-make-tramp-file-name'. The original be -forced to make full file name with `with-parsed-tramp-file-name', not providing -prefix only option." - (concat tramp-prefix-format - (unless (zerop (length method)) - (concat method tramp-postfix-method-format)) - (unless (zerop (length user)) - (concat user tramp-postfix-user-format)) - (when host - (if (string-match tramp-ipv6-regexp host) - (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) - host)) - tramp-postfix-host-format)) - -(defun cider-tramp-prefix (&optional buffer) - "Use the filename for BUFFER to determine a tramp prefix. -Defaults to the current buffer. Return the tramp prefix, or nil -if BUFFER is local." - (let* ((buffer (or buffer (current-buffer))) - (name (or (buffer-file-name buffer) - (with-current-buffer buffer - default-directory)))) - (when (tramp-tramp-file-p name) - (with-parsed-tramp-file-name name v - (with-no-warnings - (cider-make-tramp-prefix v-method v-user v-host)))))) - -(defun cider--client-tramp-filename (name &optional buffer) - "Return the tramp filename for path NAME relative to BUFFER. -If BUFFER has a tramp prefix, it will be added as a prefix to NAME. -If the resulting path is an existing tramp file, it returns the path, -otherwise, nil." - (let* ((buffer (or buffer (current-buffer))) - (name (replace-regexp-in-string "^file:" "" name)) - (name (concat (cider-tramp-prefix buffer) name))) - (if (and (tramp-tramp-file-p name) - (tramp-handle-file-exists-p name)) - name))) - -(defun cider--server-filename (name) - "Return the nREPL server-relative filename for NAME." - (if (tramp-tramp-file-p name) - (with-parsed-tramp-file-name name nil - localname) - name)) - -(defcustom cider-path-translations nil - "Alist of path prefixes to path prefixes. -Useful to intercept the location of a path in a container (or virtual -machine) and translate to the original location. If your project is located -at \"~/projects/foo\" and the src directory of foo is mounted at \"/src\" -in the container, the alist would be `((\"/src\" \"~/projects/foo/src\"))." - :type '(alist :key-type string :value-type string) - :group 'cider - :package-version '(cider . "0.23.0")) - -(defun cider--translate-path (path direction) - "Attempt to translate the PATH in the given DIRECTION. -Looks at `cider-path-translations' for (container . host) alist of path -prefixes and translates PATH from container to host or vice-versa depending on -whether DIRECTION is 'from-nrepl or 'to-nrepl." - (seq-let [from-fn to-fn path-fn] (cond ((eq direction 'from-nrepl) '(car cdr identity)) - ((eq direction 'to-nrepl) '(cdr car expand-file-name))) - (let ((path (funcall path-fn path))) - (seq-some (lambda (translation) - (let ((prefix (file-name-as-directory (expand-file-name (funcall from-fn translation))))) - (when (string-prefix-p prefix path) - (replace-regexp-in-string (format "^%s" (regexp-quote prefix)) - (file-name-as-directory - (expand-file-name (funcall to-fn translation))) - path)))) - cider-path-translations)))) - -(defun cider--translate-path-from-nrepl (path) - "Attempt to translate the nREPL PATH to a local path." - (cider--translate-path path 'from-nrepl)) - -(defun cider--translate-path-to-nrepl (path) - "Attempt to translate the local PATH to an nREPL path." - (cider--translate-path (expand-file-name path) 'to-nrepl)) - -(defvar cider-from-nrepl-filename-function - (with-no-warnings - (lambda (path) - (let ((path* (if (eq system-type 'cygwin) - (cygwin-convert-file-name-from-windows path) - path))) - (or (cider--translate-path-from-nrepl path*) path*)))) - "Function to translate nREPL namestrings to Emacs filenames.") - -(defcustom cider-prefer-local-resources nil - "Prefer local resources to remote (tramp) ones when both are available." - :type 'boolean - :group 'cider) - -(defun cider--file-path (path) - "Return PATH's local or tramp path using `cider-prefer-local-resources'. -If no local or remote file exists, return nil." - (let* ((local-path (funcall cider-from-nrepl-filename-function path)) - (tramp-path (and local-path (cider--client-tramp-filename local-path)))) - (cond ((equal local-path "") "") - ((and cider-prefer-local-resources (file-exists-p local-path)) - local-path) - ((and tramp-path (file-exists-p tramp-path)) - tramp-path) - ((and local-path (file-exists-p local-path)) - local-path)))) - -(declare-function archive-extract "arc-mode") -(declare-function archive-zip-extract "arc-mode") - -(defun cider-find-file (url) - "Return a buffer visiting the file URL if it exists, or nil otherwise. -If URL has a scheme prefix, it must represent a fully-qualified file path -or an entry within a zip/jar archive. If AVFS (archive virtual file -system; see online docs) is mounted the archive entry is opened inside the -AVFS directory, otherwise the entry is archived into a temporary read-only -buffer. If URL doesn't contain a scheme prefix and is an absolute path, it -is treated as such. Finally, if URL is relative, it is expanded within each -of the open Clojure buffers till an existing file ending with URL has been -found." - (require 'arc-mode) - (cond ((string-match "^file:\\(.+\\)" url) - (when-let* ((file (cider--url-to-file (match-string 1 url))) - (path (cider--file-path file))) - (find-file-noselect path))) - ((string-match "^\\(jar\\|zip\\):\\(file:.+\\)!/\\(.+\\)" url) - (when-let* ((entry (match-string 3 url)) - (file (cider--url-to-file (match-string 2 url))) - (path (cider--file-path file)) - (name (format "%s:%s" path entry)) - (avfs (format "%s%s#uzip/%s" - (expand-file-name (or (getenv "AVFSBASE") "~/.avfs/")) - path entry))) - (cond - ;; 1) use avfs - ((file-exists-p avfs) - (find-file-noselect avfs)) - ;; 2) already uncompressed - ((find-buffer-visiting name)) - ;; 3) on remotes use Emacs built-in archiving - ((tramp-tramp-file-p path) - (find-file path) - (goto-char (point-min)) - ;; anchor to eol to prevent eg. clj matching cljs. - (re-search-forward (concat entry "$")) - (let ((archive-buffer (current-buffer))) - (archive-extract) - (kill-buffer archive-buffer)) - (current-buffer)) - ;; 4) Use external zip program to extract a single file - (t - (with-current-buffer (generate-new-buffer - (file-name-nondirectory entry)) - ;; Use appropriate coding system for bytes read from unzip cmd to - ;; display Emacs native newlines regardless of whether the file - ;; uses unix LF or dos CRLF line endings. - ;; It's important to avoid spurious CR characters, which may - ;; appear as `^M', because they can confuse clojure-mode's symbol - ;; detection, e.g. `clojure-find-ns', and break `cider-find-var'. - ;; `clojure-find-ns' uses Emacs' (thing-at-point 'symbol) as - ;; part of identifying a file's namespace, and when a file - ;; isn't decoded properly, namespaces can be reported as - ;; `my.lib^M' which `cider-find-var' won't know what to do with. - (let ((coding-system-for-read 'prefer-utf-8)) - (archive-zip-extract path entry)) - (set-visited-file-name name) - (setq-local default-directory (file-name-directory path)) - (setq-local buffer-read-only t) - (set-buffer-modified-p nil) - (set-auto-mode) - (current-buffer)))))) - (t (if-let* ((path (cider--file-path url))) - (find-file-noselect path) - (unless (file-name-absolute-p url) - (let ((cider-buffers (cider-util--clojure-buffers)) - (url (file-name-nondirectory url))) - (or (cl-loop for bf in cider-buffers - for path = (with-current-buffer bf - (expand-file-name url)) - if (and path (file-exists-p path)) - return (find-file-noselect path)) - (cl-loop for bf in cider-buffers - if (string= (buffer-name bf) url) - return bf)))))))) - -(defun cider--open-other-window-p (arg) - "Test prefix value ARG to see if it indicates displaying results in other window." - (let ((narg (prefix-numeric-value arg))) - (pcase narg - (-1 t) ; - - (16 t) ; empty empty - (_ nil)))) - -(defun cider-abbreviate-ns (namespace) - "Return a string that abbreviates NAMESPACE." - (when namespace - (let* ((names (reverse (split-string namespace "\\."))) - (lastname (car names))) - (concat (mapconcat (lambda (s) (concat (substring s 0 1) ".")) - (reverse (cdr names)) - "") - lastname)))) - -(defun cider-last-ns-segment (namespace) - "Return the last segment of NAMESPACE." - (when namespace - (car (reverse (split-string namespace "\\."))))) - - -(provide 'cider-common) -;;; cider-common.el ends here diff --git a/elpa/cider-20230707.640/cider-completion.el b/elpa/cider-20230707.640/cider-completion.el deleted file mode 100644 index 20b75e46..00000000 --- a/elpa/cider-20230707.640/cider-completion.el +++ /dev/null @@ -1,311 +0,0 @@ -;;; cider-completion.el --- Smart REPL-powered code completion -*- lexical-binding: t -*- - -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Bozhidar Batsov -;; Artur Malabarba - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Smart REPL-powered code completion and integration with company-mode. - -;;; Code: - -(require 'subr-x) -(require 'thingatpt) - -(require 'cider-client) -(require 'cider-common) -(require 'cider-doc) -(require 'cider-eldoc) -(require 'nrepl-dict) - -(defcustom cider-completion-use-context t - "When true, uses context at point to improve completion suggestions." - :type 'boolean - :group 'cider - :package-version '(cider . "0.7.0")) - -(defcustom cider-annotate-completion-candidates t - "When true, annotate completion candidates with some extra information." - :type 'boolean - :group 'cider - :package-version '(cider . "0.8.0")) - -(defcustom cider-annotate-completion-function - #'cider-default-annotate-completion-function - "Controls how the annotations for completion candidates are formatted. -Must be a function that takes two arguments: the abbreviation of the -candidate type according to `cider-completion-annotations-alist' and the -candidate's namespace." - :type 'function - :group 'cider - :package-version '(cider . "0.9.0")) - -(defcustom cider-completion-annotations-alist - '(("class" "c") - ("field" "fi") - ("function" "f") - ("import" "i") - ("keyword" "k") - ("local" "l") - ("macro" "m") - ("method" "me") - ("namespace" "n") - ("protocol" "p") - ("protocol-function" "pf") - ("record" "r") - ("special-form" "s") - ("static-field" "sf") - ("static-method" "sm") - ("type" "t") - ("var" "v")) - "Controls the abbreviations used when annotating completion candidates. - -Must be a list of elements with the form (TYPE . ABBREVIATION), where TYPE -is a possible value of the candidate's type returned from the completion -backend, and ABBREVIATION is a short form of that type." - :type '(alist :key-type string :value-type string) - :group 'cider - :package-version '(cider . "0.9.0")) - -(defconst cider-completion-kind-alist - '(("class" class) - ("field" field) - ("function" function) - ("import" class) - ("keyword" keyword) - ("local" variable) - ("macro" macro) - ("method" method) - ("namespace" module) - ("protocol" enum) - ("protocol-function" enum-member) - ("record" struct) - ("special-form" keyword) - ("static-field" field) - ("static-method" interface) - ("type" parameter) - ("var" variable)) - "Icon mapping for company-mode.") - -(defcustom cider-completion-annotations-include-ns 'unqualified - "Controls passing of namespaces to `cider-annotate-completion-function'. - -When set to 'always, the candidate's namespace will always be passed if it -is available. When set to 'unqualified, the namespace will only be passed -if the candidate is not namespace-qualified." - :type '(choice (const always) - (const unqualified) - (const :tag "never" nil)) - :group 'cider - :package-version '(cider . "0.9.0")) - -(defvar cider-completion-last-context nil) - -(defun cider-completion-symbol-start-pos () - "Find the starting position of the symbol at point, unless inside a string." - (let ((sap (symbol-at-point))) - (when (and sap (not (nth 3 (syntax-ppss)))) - (car (bounds-of-thing-at-point 'symbol))))) - -(defun cider-completion-get-context-at-point () - "Extract the context at point. -If point is not inside the list, returns nil; otherwise return \"top-level\" -form, with symbol at point replaced by __prefix__." - (when (save-excursion - (condition-case _ - (progn - (up-list) - (check-parens) - t) - (scan-error nil) - (user-error nil))) - (save-excursion - (let* ((pref-end (point)) - (pref-start (cider-completion-symbol-start-pos)) - (context (cider-defun-at-point)) - (_ (beginning-of-defun)) - (expr-start (point))) - (concat (when pref-start (substring context 0 (- pref-start expr-start))) - "__prefix__" - (substring context (- pref-end expr-start))))))) - -(defun cider-completion-get-context () - "Extract context depending on `cider-completion-use-context' and major mode." - (let ((context (if (and cider-completion-use-context - ;; Important because `beginning-of-defun' and - ;; `ending-of-defun' work incorrectly in the REPL - ;; buffer, so context extraction fails there. - (derived-mode-p 'clojure-mode)) - ;; We use ignore-errors here since grabbing the context - ;; might fail because of unbalanced parens, or other - ;; technical reasons, yet we don't want to lose all - ;; completions and throw error to user because of that. - (or (ignore-errors (cider-completion-get-context-at-point)) - "nil") - "nil"))) - (if (string= cider-completion-last-context context) - ":same" - (setq cider-completion-last-context context) - context))) - -(defun cider-completion--parse-candidate-map (candidate-map) - "Get \"candidate\" from CANDIDATE-MAP. -Put type and ns properties on the candidate" - (let ((candidate (nrepl-dict-get candidate-map "candidate")) - (type (nrepl-dict-get candidate-map "type")) - (ns (nrepl-dict-get candidate-map "ns"))) - (put-text-property 0 1 'type type candidate) - (put-text-property 0 1 'ns ns candidate) - candidate)) - -(defun cider-complete (prefix) - "Complete PREFIX with context at point. -Completion relies on nREPL middleware. First -we check if cider-nrepl's complete op is available -and afterward we fallback on nREPL's built-in -completion functionality." - (cond - ;; if we don't have a connection, end early - ((not (cider-connected-p)) nil) - ;; next we try if cider-nrepl's completion is available - ((cider-nrepl-op-supported-p "complete") - (let* ((context (cider-completion-get-context)) - (candidates (cider-sync-request:complete prefix context))) - (mapcar #'cider-completion--parse-candidate-map candidates))) - ;; then we fallback to nREPL's built-in op (available in nREPL 0.8+) - ((cider-nrepl-op-supported-p "completions") - (mapcar #'cider-completion--parse-candidate-map (cider-sync-request:completion prefix))) - (t nil))) - -(defun cider-completion--get-candidate-type (symbol) - "Get candidate type for SYMBOL." - (let ((type (get-text-property 0 'type symbol))) - (or (cadr (assoc type cider-completion-annotations-alist)) - type))) - -(defun cider-completion--get-candidate-ns (symbol) - "Get candidate ns for SYMBOL." - (when (or (eq 'always cider-completion-annotations-include-ns) - (and (eq 'unqualified cider-completion-annotations-include-ns) - (not (cider-namespace-qualified-p symbol)))) - (get-text-property 0 'ns symbol))) - -(defun cider-default-annotate-completion-function (type ns) - "Get completion function based on TYPE and NS." - (concat (when ns (format " (%s)" ns)) - (when type (format " <%s>" type)))) - -(defun cider-company-symbol-kind (symbol) - "Get SYMBOL kind for company-mode." - (let ((type (get-text-property 0 'type symbol))) - (or (cadr (assoc type cider-completion-kind-alist)) - type))) - -(defun cider-annotate-symbol (symbol) - "Return a string suitable for annotating SYMBOL. -If SYMBOL has a text property `type` whose value is recognised, its -abbreviation according to `cider-completion-annotations-alist' will be -used. If `type` is present but not recognised, its value will be used -unaltered. If SYMBOL has a text property `ns`, then its value will be used -according to `cider-completion-annotations-include-ns'. The formatting is -performed by `cider-annotate-completion-function'." - (when cider-annotate-completion-candidates - (let* ((type (cider-completion--get-candidate-type symbol)) - (ns (cider-completion--get-candidate-ns symbol))) - (funcall cider-annotate-completion-function type ns)))) - -(defun cider-complete-at-point () - "Complete the symbol at point." - (when-let* ((bounds (bounds-of-thing-at-point 'symbol))) - (when (and (cider-connected-p) - (not (or (cider-in-string-p) (cider-in-comment-p)))) - (list (car bounds) (cdr bounds) - (lambda (prefix pred action) - ;; When the 'action is 'metadata, this lambda returns metadata about this - ;; capf, when action is (boundaries . suffix), it returns nil. With every - ;; other value of 'action (t, nil, or lambda), 'action is forwarded to - ;; (complete-with-action), together with (cider-complete), prefix and pred. - ;; And that function performs the completion based on those arguments. - ;; - ;; This api is better described in the section - ;; '21.6.7 Programmed Completion' of the elisp manual. - (cond ((eq action 'metadata) `(metadata (category . cider))) - ((eq (car-safe action) 'boundaries) nil) - (t (with-current-buffer (current-buffer) - (complete-with-action action - (cider-complete prefix) prefix pred))))) - :annotation-function #'cider-annotate-symbol - :company-kind #'cider-company-symbol-kind - :company-doc-buffer #'cider-create-doc-buffer - :company-location #'cider-company-location - :company-docsig #'cider-company-docsig)))) - -(defun cider-completion-flush-caches () - "Force Compliment to refill its caches. -This command should be used if Compliment fails to pick up new classnames -and methods from dependencies that were loaded dynamically after the REPL -has started." - (interactive) - (cider-sync-request:complete-flush-caches)) - -(defun cider-company-location (var) - "Open VAR's definition in a buffer. -Returns the cons of the buffer itself and the location of VAR's definition -in the buffer." - (when-let* ((info (cider-var-info var)) - (file (nrepl-dict-get info "file")) - (line (nrepl-dict-get info "line")) - (buffer (cider-find-file file))) - (with-current-buffer buffer - (save-excursion - (goto-char (point-min)) - (forward-line (1- line)) - (cons buffer (point)))))) - -(defun cider-company-docsig (thing) - "Return signature for THING." - (let* ((eldoc-info (cider-eldoc-info thing)) - (ns (lax-plist-get eldoc-info "ns")) - (symbol (lax-plist-get eldoc-info "symbol")) - (arglists (lax-plist-get eldoc-info "arglists"))) - (when eldoc-info - (format "%s: %s" - (cider-eldoc-format-thing ns symbol thing - (cider-eldoc-thing-type eldoc-info)) - (cider-eldoc-format-arglist arglists 0))))) - -;; Fuzzy completion for company-mode - -(defun cider-company-unfiltered-candidates (string &rest _) - "Return CIDER completion candidates for STRING as is, unfiltered." - (cider-complete string)) - -(add-to-list 'completion-styles-alist - '(cider - cider-company-unfiltered-candidates - cider-company-unfiltered-candidates - "CIDER backend-driven completion style.")) - -(defun cider-company-enable-fuzzy-completion () - "Enable backend-driven fuzzy completion in the current buffer." - (setq-local completion-styles '(cider))) - -(provide 'cider-completion) -;;; cider-completion.el ends here diff --git a/elpa/cider-20230707.640/cider-connection.el b/elpa/cider-20230707.640/cider-connection.el deleted file mode 100644 index 35fc7927..00000000 --- a/elpa/cider-20230707.640/cider-connection.el +++ /dev/null @@ -1,1092 +0,0 @@ -;;; cider-connection.el --- Connection and session life-cycle management for CIDER -*- lexical-binding: t -*- -;; -;; Copyright © 2019-2023 Artur Malabarba, Bozhidar Batsov, Vitalie Spinu and CIDER contributors -;; -;; Author: Artur Malabarba -;; Bozhidar Batsov -;; Vitalie Spinu -;; -;; Keywords: languages, clojure, cider -;; -;; 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 . -;; -;; This file is not part of GNU Emacs. -;; -;; -;;; Commentary: -;; -;; -;;; Code: - -(require 'nrepl-client) -(require 'cl-lib) -(require 'format-spec) -(require 'sesman) -(require 'sesman-browser) -(require 'spinner) -(require 'cider-popup) -(require 'cider-util) - -(defcustom cider-session-name-template "%J:%h:%p" - "Format string to use for session names. -See `cider-format-connection-params' for available format characters." - :type 'string - :group 'cider - :package-version '(cider . "0.18.0")) - -(defcustom cider-redirect-server-output-to-repl t - "Controls whether nREPL server output would be redirected to the REPL. -When non-nil the output would end up in both the nrepl-server buffer (when -available) and the matching REPL buffer." - :type 'boolean - :group 'cider - :safe #'booleanp - :package-version '(cider . "0.17.0")) - -(defcustom cider-auto-mode t - "When non-nil, automatically enable and disable CIDER in all Clojure buffers. - -After an initial connection, `cider-mode' is added to `clojure-mode-hook' and -automatically enabled on all existing Clojure buffers. After the last -connection has been closed, `cider-mode' is disabled in all Clojure buffers, and -has to be manually re-enabled via \\[cider-mode]. - -Useful for switching between alternative minor modes like `inf-clojure-mode'." - :type 'boolean - :group 'cider - :safe #'booleanp - :package-version '(cider . "0.9.0")) - -(defcustom cider-merge-sessions nil - "Controls session combination behaviour. - -Symbol `host' combines all sessions of a project associated with the same host. -Symbol `project' combines all sessions of a project. - -All other values do not combine any sessions." - :type '(choice (const :tag "Combine all sessions with the same host" host) - (const :tag "Combine all sessions from the same project" project) - (other :tag "Do not combine any sessions")) - :group 'cider - :safe #'symbolp - :package-version '(cider . "1.5")) - -(defcustom cider-reuse-dead-repls 'prompt - "How to deal with existing dead REPL buffers when initializing a connection. - -Possible choices are `prompt', `auto', `any', and nil. -- `prompt' means to always ask the user for a decision. -- `auto' means to automatically reuse a dead REPL without prompting the user - if it is the only available option. When there are multiple buffers to - choose from, the user is is prompted for a choice. -- `any' (or any other non-nil value) means to reuse any dead REPL buffer - available, by default the most relevant according to various heuristics, - and never prompt the user. -- nil means to start a new REPL each time, ignoring existing buffers." - :type '(choice (const :tag "Always prompt for what to do with dead REPLs" prompt) - (const :tag "Reuse dead REPL, prompting only for multiple choice" auto) - (const :tag "Reuse any available dead REPL and never prompt" any) - (const :tag "Never reuse dead REPLs" nil)) - :group 'cider - :safe #'symbolp - :package-version '(cider . "1.8")) - -(defconst cider-required-nrepl-version "0.6.0" - "The minimum nREPL version that's known to work properly with CIDER.") - - -;;; Connect - -(defun cider-nrepl-connect (params) - "Start nrepl client and create the REPL. -PARAMS is a plist containing :host, :port, :server and other parameters for -`cider-repl-create'." - (process-buffer - (nrepl-start-client-process - (plist-get params :host) - (plist-get params :port) - (plist-get params :server) - (lambda (_) - (cider-repl-create params)) - (plist-get params :socket-file)))) - -(defun cider-sessions () - "Return a list of all active CIDER sessions." - (sesman-sessions 'CIDER)) - -(defun cider-connected-p () - "Return t if CIDER is currently connected, nil otherwise." - (process-live-p (get-buffer-process (cider-current-repl)))) - -(defun cider-ensure-connected () - "Ensure there is a linked CIDER session." - (sesman-ensure-session 'CIDER)) - -(defun cider--session-server (session) - "Return server buffer for SESSION or nil if there is no server." - (seq-some (lambda (r) - (buffer-local-value 'nrepl-server-buffer r)) - (cdr session))) - -(defun cider--gather-session-params (session) - "Gather all params for a SESSION." - (let (params) - (dolist (repl (cdr session)) - (setq params (cider--gather-connect-params params repl))) - (when-let* ((server (cider--session-server session))) - (setq params (cider--gather-connect-params params server))) - params)) - -(defun cider--gather-connect-params (&optional params proc-buffer) - "Gather all relevant connection parameters into PARAMS plist. -PROC-BUFFER is either server or client buffer, defaults to current buffer." - (let ((proc-buffer (or proc-buffer (current-buffer)))) - (with-current-buffer proc-buffer - (unless nrepl-endpoint - (error "This is not a REPL or SERVER buffer; is there an active REPL?")) - (let ((server-buf (if (nrepl-server-p proc-buffer) - proc-buffer - nrepl-server-buffer))) - (cl-loop for l on nrepl-endpoint by #'cddr - do (setq params (plist-put params (car l) (cadr l)))) - (setq params (thread-first - params - (plist-put :project-dir nrepl-project-dir))) - (when (buffer-live-p server-buf) - (setq params (thread-first - params - (plist-put :server (get-buffer-process server-buf)) - (plist-put :server-command nrepl-server-command)))) - ;; repl-specific parameters (do not pollute server params!) - (unless (nrepl-server-p proc-buffer) - (setq params (thread-first - params - (plist-put :session-name cider-session-name) - (plist-put :repl-type cider-repl-type) - (plist-put :cljs-repl-type cider-cljs-repl-type) - (plist-put :repl-init-function cider-repl-init-function)))) - params)))) - -(defun cider--close-buffer (buffer) - "Close the BUFFER and kill its associated process (if any)." - (when (buffer-live-p buffer) - (when-let* ((proc (get-buffer-process buffer))) - (when (process-live-p proc) - (delete-process proc))) - (kill-buffer buffer))) - -(declare-function cider-repl-emit-interactive-stderr "cider-repl") -(defun cider--close-connection (repl &optional no-kill) - "Close connection associated with REPL. -When NO-KILL is non-nil stop the connection but don't kill the REPL -buffer." - (when (buffer-live-p repl) - (with-current-buffer repl - (when spinner-current (spinner-stop)) - (when nrepl-tunnel-buffer - (cider--close-buffer nrepl-tunnel-buffer)) - (when no-kill - ;; inform sentinel not to kill the server, if any - (thread-first - (get-buffer-process repl) - (process-plist) - (plist-put :keep-server t)))) - (let ((proc (get-buffer-process repl))) - (when (and (process-live-p proc) - (or (not nrepl-server-buffer) - ;; Sync request will hang if the server is dead. - (process-live-p (get-buffer-process nrepl-server-buffer)))) - (nrepl-sync-request:close repl) - ;; give a chance to the REPL to respond to the closing of the connection - (sleep-for 0.5) - (delete-process proc))) - (when-let* ((messages-buffer (and nrepl-log-messages - (nrepl-messages-buffer repl)))) - (kill-buffer messages-buffer)) - (unless no-kill - (kill-buffer repl))) - (when repl - (sesman-remove-object 'CIDER nil repl (not no-kill) t))) - -(defun cider-emit-manual-warning (section-id format &rest args) - "Emit a warning to the REPL and link to the online manual. -SECTION-ID is the section to link to. The link is added on the last line. -FORMAT is a format string to compile with ARGS and display on the REPL." - (let ((message (apply #'format format args))) - (cider-repl-emit-interactive-stderr - (concat "WARNING: " message " (" - (cider--manual-button "More information" section-id) - ")\n")))) - -(defvar cider-version) -(defun cider--check-required-nrepl-version () - "Check whether we're using a compatible nREPL version." - (if-let* ((nrepl-version (cider--nrepl-version))) - (when (version< nrepl-version cider-required-nrepl-version) - (cider-emit-manual-warning "troubleshooting.html#warning-saying-you-have-to-use-newer-nrepl" - "CIDER requires nREPL %s (or newer) to work properly" - cider-required-nrepl-version)))) - -(defvar cider-minimum-clojure-version) -(defun cider--check-clojure-version-supported () - "Ensure that we are meeting the minimum supported version of Clojure." - (if-let* ((clojure-version (cider--clojure-version)) - ;; drop all qualifiers from the version string - ;; e.g. 1.10.0-master-SNAPSHOT becomes simply 1.10.0 - (clojure-version (car (split-string clojure-version "-")))) - (when (version< clojure-version cider-minimum-clojure-version) - (cider-emit-manual-warning "basics/installation.html#prerequisites" - "Clojure version (%s) is not supported (minimum %s). CIDER will not work." - clojure-version cider-minimum-clojure-version)))) - -(defun cider--strip-version-patch (v) - "Strips everything but major.minor from the version, returning a version list. -V is the version string to strip the patch from." - (seq-take (version-to-list v) 2)) - -(defun cider--compatible-middleware-version-p (required-ver ver) - "Checks that the available middleware version is compatible with the required. -We look only at the major and minor components. When the major -version is 0, only check that the minor versions match. When the major version -is > 0, first check that the major version matches, then that the minor -version is >= the required minor version. -VER the 'installed' version, -REQUIRED-VER the version required by cider." - (let ((ver* (cider--strip-version-patch ver)) - (required-ver* (cider--strip-version-patch required-ver))) - (cond ((= 0 (car required-ver*)) (= (cadr required-ver*) - (cadr ver*))) - (t (and (= (car required-ver*) - (car ver*)) - (version-list-<= required-ver* ver*)))))) - -(defvar cider-required-middleware-version) -(defun cider--check-middleware-compatibility () - "CIDER frontend/backend compatibility check. -Retrieve the underlying connection's CIDER-nREPL version and checks if the -middleware used is compatible with CIDER. If not, will display a warning -message in the REPL area." - (let* ((version-dict (nrepl-aux-info "cider-version" (cider-current-repl))) - (middleware-version (nrepl-dict-get version-dict "version-string"))) - (cond - ((null middleware-version) - (cider-emit-manual-warning "troubleshooting.html#cider-complains-of-the-cider-nrepl-version" - "CIDER requires cider-nrepl to be fully functional. Some features will not be available without it!")) - ((not (cider--compatible-middleware-version-p cider-required-middleware-version middleware-version)) - (cider-emit-manual-warning "troubleshooting.html#cider-complains-of-the-cider-nrepl-version" - "CIDER %s requires cider-nrepl %s, but you're currently using cider-nrepl %s. The version mismatch might break some functionality!" - cider-version cider-required-middleware-version middleware-version))))) - -(declare-function cider-interactive-eval-handler "cider-eval") -(declare-function cider-nrepl-send-request "cider-client") -;; TODO: Use some null handler here -(defun cider--subscribe-repl-to-server-out () - "Subscribe to the nREPL server's *out*." - (cider-nrepl-send-request '("op" "out-subscribe") - (cider-interactive-eval-handler (current-buffer)))) - -(defvar cider-mode) -(declare-function cider-mode "cider-mode") -(defun cider-enable-on-existing-clojure-buffers () - "Enable CIDER's minor mode on existing Clojure buffers. -See command `cider-mode'." - (interactive) - (add-hook 'clojure-mode-hook #'cider-mode) - (dolist (buffer (cider-util--clojure-buffers)) - (with-current-buffer buffer - (unless cider-mode - (cider-mode +1) - ;; In global-eldoc-mode, a new file-visiting buffer calls - ;; `turn-on-eldoc-mode' which enables eldoc-mode if it's supported in that - ;; buffer as determined by `eldoc--supported-p'. Cider's eldoc support - ;; allows new buffers in cider-mode to enable eldoc-mode. As of 2021-04, - ;; however, clojure-mode itself has no eldoc support, so old clojure - ;; buffers opened before cider started aren't necessarily in eldoc-mode. - ;; Here, we've enabled cider-mode for this old clojure buffer, and now, if - ;; global-eldoc-mode is enabled, try to enable eldoc-mode as if the buffer - ;; had just been created with cider-mode. - (when global-eldoc-mode - (turn-on-eldoc-mode)))))) - -(declare-function cider--debug-mode "cider-debug") -(defun cider-disable-on-existing-clojure-buffers () - "Disable `cider-mode' and related commands on existing Clojure buffers." - (interactive) - (dolist (buffer (cider-util--clojure-buffers)) - (with-current-buffer buffer - (cider--debug-mode -1) - (cider-mode -1)))) - -(defun cider-possibly-disable-on-existing-clojure-buffers () - "Disable `cider-mode' in all Clojure buffers if all CIDER sessions are closed." - (unless (cider-sessions) - (cider-disable-on-existing-clojure-buffers))) - -(defun cider--set-connection-capabilities (&optional conn-buffer) - "Set `cider-connection-capabilities' for CONN-BUFFER during repl init. -See `cider-connection-capabilities'." - (with-current-buffer (or conn-buffer (current-buffer)) - (setf cider-connection-capabilities - (append - (pcase (cider-runtime) - ('clojure '(clojure jvm-compilation-errors)) - ('babashka '(babashka jvm-compilation-errors)) - (_ '())) - (when - (or - (eq cider-repl-type 'cljs) - ;; This check is currently basically for nbb. - ;; See `cider-sync-tooling-eval', but it is defined on a higher layer - (nrepl-dict-get - (nrepl-sync-request:eval "cljs.core/demunge" (current-buffer) nil 'tooling) - "value")) - '(cljs)))))) - -(declare-function cider--debug-init-connection "cider-debug") -(declare-function cider-repl-init "cider-repl") -(declare-function cider-nrepl-op-supported-p "cider-client") -(defun cider--connected-handler () - "Handle CIDER initialization after nREPL connection has been established. -This function is appended to `nrepl-connected-hook' in the client process -buffer." - ;; `nrepl-connected-hook' is run in the connection buffer - ;; `cider-enlighten-mode' changes eval to include the debugger, so we inhibit - ;; it here as the debugger isn't necessarily initialized yet - (let ((cider-enlighten-mode nil)) - ;; after initialization, set mode-line and buffer name. - (cider-set-repl-type cider-repl-type) - (cider-repl-init - (current-buffer) - (lambda () - ;; Init logic that's specific to Clojure's nREPL and cider-nrepl - (when (cider-runtime-clojure-p) - (cider--check-required-nrepl-version) - (cider--check-clojure-version-supported) - (cider--check-middleware-compatibility) - - ;; Redirect the nREPL's terminal output to a REPL buffer. - ;; If we don't do this the server's output will end up - ;; in the *nrepl-server* buffer. - (when (and cider-redirect-server-output-to-repl - (cider-nrepl-op-supported-p "out-subscribe")) - (cider--subscribe-repl-to-server-out)) - - ;; Middleware on cider-nrepl's side is deferred until first usage, but - ;; loading middleware concurrently can lead to occasional "require" issues - ;; (likely a Clojure bug). Thus, we load the heavy debug middleware towards - ;; the end, allowing for the faster "server-out" middleware to load - ;; first. - (cider--debug-init-connection)) - - (cider--set-connection-capabilities) - - (when cider-repl-init-function - (funcall cider-repl-init-function)) - - (when cider-auto-mode - (cider-enable-on-existing-clojure-buffers)) - - (run-hooks 'cider-connected-hook))))) - -(defun cider--disconnected-handler () - "Cleanup after nREPL connection has been lost or closed. -This function is appended to `nrepl-disconnected-hook' in the client -process buffer." - ;; `nrepl-connected-hook' is run in the connection buffer - (when cider-auto-mode - (cider-possibly-disable-on-existing-clojure-buffers)) - (run-hooks 'cider-disconnected-hook)) - - -;;; Connection Info - -(defun cider--java-version () - "Retrieve the underlying connection's Java version." - (with-current-buffer (cider-current-repl) - (when nrepl-versions - (thread-first - nrepl-versions - (nrepl-dict-get "java") - (nrepl-dict-get "version-string"))))) - -(defun cider--clojure-version () - "Retrieve the underlying connection's Clojure version." - (with-current-buffer (cider-current-repl) - (when nrepl-versions - (thread-first - nrepl-versions - (nrepl-dict-get "clojure") - (nrepl-dict-get "version-string"))))) - -(defun cider--nrepl-version () - "Retrieve the underlying connection's nREPL version." - (with-current-buffer (cider-current-repl) - (when nrepl-versions - (thread-first - nrepl-versions - (nrepl-dict-get "nrepl") - (nrepl-dict-get "version-string"))))) - -(defun cider--babashka-version () - "Retrieve the underlying connection's Babashka version." - (with-current-buffer (cider-current-repl) - (when nrepl-versions - (nrepl-dict-get nrepl-versions "babashka")))) - -(defun cider--babashka-nrepl-version () - "Retrieve the underlying connection's babashka.nrepl version." - (with-current-buffer (cider-current-repl) - (when nrepl-versions - (nrepl-dict-get nrepl-versions "babashka.nrepl")))) - -(defun cider-runtime () - "Return the runtime of the nREPl server." - (cond - ((cider--clojure-version) 'clojure) - ((cider--babashka-version) 'babashka) - (t 'generic))) - -(defun cider-runtime-clojure-p () - "Check if the current runtime is Clojure." - (eq (cider-runtime) 'clojure)) - -(defun cider--connection-info (connection-buffer &optional genericp) - "Return info about CONNECTION-BUFFER. -Info contains project name, current REPL namespace, host:port endpoint and -runtime details. When GENERICP is non-nil, don't provide specific info -about this buffer (like variable `cider-repl-type')." - (with-current-buffer connection-buffer - (cond - ((cider--clojure-version) - (format "%s%s@%s:%s (Java %s, Clojure %s, nREPL %s)" - (if genericp "" (upcase (concat (symbol-name cider-repl-type) " "))) - (or (cider--project-name nrepl-project-dir) "") - (plist-get nrepl-endpoint :host) - (plist-get nrepl-endpoint :port) - (cider--java-version) - (cider--clojure-version) - (cider--nrepl-version))) - ((cider--babashka-version) - (format "%s%s@%s:%s (Babashka %s, babashka.nrepl %s)" - (if genericp "" (upcase (concat (symbol-name cider-repl-type) " "))) - (or (cider--project-name nrepl-project-dir) "") - (plist-get nrepl-endpoint :host) - (plist-get nrepl-endpoint :port) - (cider--babashka-version) - (cider--babashka-nrepl-version))) - (t - (format "%s%s@%s:%s" - (if genericp "" (upcase (concat (symbol-name cider-repl-type) " "))) - (or (cider--project-name nrepl-project-dir) "") - (plist-get nrepl-endpoint :host) - (plist-get nrepl-endpoint :port)))))) - -(defvar-local cider-connection-capabilities '() - "A list of some of the capabilities of this connection buffer. -In other words - what assumptions we make about the runtime. -This is more general than -`cider-nrepl-op-supported-p' and `cider-library-present-p'. -But does not need to replace them.") - -(defun cider-connection-has-capability-p (capability &optional conn-buf) - "Return non nil when the cider connection has CAPABILITY for CONN-BUF. -By default it assumes the connection buffer is current." - (with-current-buffer (or conn-buf (current-buffer)) - (member capability cider-connection-capabilities))) - - -;;; Connection Management Commands - -(defun cider-quit (&optional repl) - "Quit the CIDER connection associated with REPL. -REPL defaults to the current REPL." - (interactive) - (let ((repl (or repl - (sesman-browser-get 'object) - (cider-current-repl nil 'ensure)))) - (cider--close-connection repl)) - ;; if there are no more sessions we can kill all ancillary buffers - (unless (cider-sessions) - (cider-close-ancillary-buffers)) - ;; need this to refresh sesman browser - (run-hooks 'sesman-post-command-hook)) - -(defun cider-restart (&optional repl) - "Restart CIDER connection associated with REPL. -REPL defaults to the current REPL. Don't restart the server or other -connections within the same session. Use `sesman-restart' to restart the -entire session." - (interactive) - (let* ((repl (or repl - (sesman-browser-get 'object) - (cider-current-repl nil 'ensure))) - (params (thread-first - () - (cider--gather-connect-params repl) - (plist-put :session-name (sesman-session-name-for-object 'CIDER repl)) - (plist-put :repl-buffer repl)))) - (cider--close-connection repl 'no-kill) - (cider-nrepl-connect params) - ;; need this to refresh sesman browser - (run-hooks 'sesman-post-command-hook))) - -(defun cider-close-ancillary-buffers () - "Close buffers that are shared across connections." - (interactive) - (dolist (buf-name cider-ancillary-buffers) - (when (get-buffer buf-name) - (kill-buffer buf-name)))) - -(defun cider-describe-connection (&optional repl) - "Display information about the connection associated with REPL. -REPL defaults to the current REPL." - (interactive) - (let ((repl (or repl - (sesman-browser-get 'object) - (cider-current-repl nil 'ensure)))) - (message "%s" (cider--connection-info repl)))) - -(defconst cider-nrepl-session-buffer "*cider-nrepl-session*") - -(declare-function cider-nrepl-eval-session "cider-client") -(declare-function cider-nrepl-tooling-session "cider-client") -(defun cider-describe-nrepl-session () - "Describe an nREPL session." - (interactive) - (cider-ensure-connected) - (let* ((repl (cider-current-repl nil 'ensure)) - (selected-session (completing-read "Describe nREPL session: " (nrepl-sessions repl)))) - (when (and selected-session (not (equal selected-session ""))) - (let* ((session-info (nrepl-sync-request:describe repl)) - (ops (nrepl-dict-keys (nrepl-dict-get session-info "ops"))) - (session-id (nrepl-dict-get session-info "session")) - (session-type (cond - ((equal session-id (cider-nrepl-eval-session)) "Active eval") - ((equal session-id (cider-nrepl-tooling-session)) "Active tooling") - (t "Unknown")))) - (with-current-buffer (cider-popup-buffer cider-nrepl-session-buffer 'select nil 'ancillary) - (read-only-mode -1) - (insert (format "Session: %s\n" session-id) - (format "Type: %s session\n" session-type) - (format "Supported ops:\n")) - (mapc (lambda (op) (insert (format " * %s\n" op))) ops))) - (display-buffer cider-nrepl-session-buffer)))) - -(defun cider-list-nrepl-middleware () - "List the loaded nREPL middleware." - (interactive) - (cider-ensure-connected) - (let* ((repl (cider-current-repl nil 'ensure)) - (middleware (nrepl-middleware repl))) - (with-current-buffer (cider-popup-buffer "*cider-nrepl-middleware*" 'select nil 'ancillary) - (read-only-mode -1) - (insert (format "Currently loaded middleware:\n")) - (mapc (lambda (mw) (insert (format " * %s\n" mw))) middleware)) - (display-buffer "*cider-nrepl-middleware*"))) - - -;;; Sesman's Session-Wise Management UI - -(cl-defmethod sesman-project ((_system (eql CIDER))) - "Find project directory." - (clojure-project-dir (cider-current-dir))) - -(cl-defmethod sesman-more-relevant-p ((_system (eql CIDER)) session1 session2) - "Figure out if SESSION1 or SESSION2 is more relevant." - (sesman-more-recent-p (cdr session1) (cdr session2))) - -(declare-function cider-classpath-entries "cider-client") -(cl-defmethod sesman-friendly-session-p ((_system (eql CIDER)) session) - "Check if SESSION is a friendly session." - (setcdr session (seq-filter #'buffer-live-p (cdr session))) - (when-let* ((repl (cadr session)) - (proc (get-buffer-process repl)) - (file (file-truename (or (buffer-file-name) default-directory)))) - ;; With avfs paths look like /path/to/.avfs/path/to/some.jar#uzip/path/to/file.clj - (when (string-match-p "#uzip" file) - (let ((avfs-path (directory-file-name (expand-file-name (or (getenv "AVFSBASE") "~/.avfs/"))))) - (setq file (replace-regexp-in-string avfs-path "" file t t)))) - (when (process-live-p proc) - (let* ((classpath (or (process-get proc :cached-classpath) - (let ((cp (with-current-buffer repl - (cider-classpath-entries)))) - (process-put proc :cached-classpath cp) - cp))) - (classpath-roots (or (process-get proc :cached-classpath-roots) - (let ((cp (thread-last - classpath - (seq-filter (lambda (path) (not (string-match-p "\\.jar$" path)))) - (mapcar #'file-name-directory) - (seq-remove #'null) - (seq-uniq)))) - (process-put proc :cached-classpath-roots cp) - cp)))) - (or (seq-find (lambda (path) (string-prefix-p path file)) - classpath) - (seq-find (lambda (path) (string-prefix-p path file)) - classpath-roots)))))) - -(defvar cider-sesman-browser-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "j q") #'cider-quit) - (define-key map (kbd "j k") #'cider-quit) - (define-key map (kbd "j r") #'cider-restart) - (define-key map (kbd "j d") #'cider-describe-connection) - (define-key map (kbd "j i") #'cider-describe-connection) - (define-key map (kbd "C-c C-q") #'cider-quit) - (define-key map (kbd "C-c C-q") #'cider-quit) - (define-key map (kbd "C-c C-r") #'cider-restart) - (define-key map (kbd "C-c M-r") #'cider-restart) - (define-key map (kbd "C-c C-d") #'cider-describe-connection) - (define-key map (kbd "C-c M-d") #'cider-describe-connection) - (define-key map (kbd "C-c C-i") #'cider-describe-connection) - map) - "Map active on REPL objects in sesman browser.") - -(cl-defmethod sesman-session-info ((_system (eql CIDER)) session) - "Obtain info for a CIDER SESSION." - (list :objects (cdr session) - :map cider-sesman-browser-map)) - -(declare-function cider "cider") -(cl-defmethod sesman-start-session ((_system (eql CIDER))) - "Start a connection of any type interactively. -Fallback on `cider' command." - (call-interactively #'cider)) - -(cl-defmethod sesman-quit-session ((_system (eql CIDER)) session) - "Quit a CIDER SESSION." - (mapc #'cider--close-connection (cdr session)) - ;; if there are no more session we can kill all ancillary buffers - (unless (cider-sessions) - (cider-close-ancillary-buffers))) - -(cl-defmethod sesman-restart-session ((_system (eql CIDER)) session) - "Restart a CIDER SESSION." - (let* ((ses-name (car session)) - (repls (cdr session)) - (srv-buf (cider--session-server session))) - (if srv-buf - ;; session with a server - (let ((s-params (cider--gather-connect-params nil srv-buf))) - ;; 1) kill all connections, but keep the buffers - (mapc (lambda (conn) - (cider--close-connection conn 'no-kill)) - repls) - ;; 2) kill the server - (nrepl-kill-server-buffer srv-buf) - ;; 3) start server - (nrepl-start-server-process - (plist-get s-params :project-dir) - (plist-get s-params :server-command) - (lambda (server-buf) - ;; 4) restart the repls reusing the buffer - (dolist (r repls) - (cider-nrepl-connect - (thread-first - () - (cider--gather-connect-params r) - ;; server params (:port, :project-dir etc) have precedence - (cider--gather-connect-params server-buf) - (plist-put :session-name ses-name) - (plist-put :repl-buffer r)))) - (sesman-browser-revert-all 'CIDER) - (message "Restarted CIDER %s session" ses-name)))) - ;; server-less session - (dolist (r repls) - (cider--close-connection r 'no-kill) - (cider-nrepl-connect - (thread-first - () - (cider--gather-connect-params r) - (plist-put :session-name ses-name) - (plist-put :repl-buffer r))))))) - -(defun cider-format-connection-params (template params) - "Format PARAMS with TEMPLATE string. -The following formats can be used in TEMPLATE string: - - %h - host - %H - remote host, empty for local hosts - %p - port - %j - short project name, or directory name if no project - %J - long project name including parent dir name - %r - REPL type (clj or cljs) - %S - type of the ClojureScript runtime (Browser, Node, Figwheel etc.) - %s - session name as defined by `cider-session-name-template'. - -In case some values are empty, extra separators (: and -) are automatically -removed." - (let* ((dir (directory-file-name - (abbreviate-file-name - (or (plist-get params :project-dir) - (clojure-project-dir (cider-current-dir)) - default-directory)))) - (short-proj (file-name-nondirectory (directory-file-name dir))) - (parent-dir (ignore-errors - (thread-first dir file-name-directory - directory-file-name file-name-nondirectory - file-name-as-directory))) - (long-proj (format "%s%s" (or parent-dir "") short-proj)) - ;; use `dir` if it is shorter than `long-proj` or `short-proj` - (short-proj (if (>= (length short-proj) (length dir)) - dir - short-proj)) - (long-proj (if (>= (length long-proj) (length dir)) - dir - long-proj)) - (port (or (plist-get params :port) "")) - (host (or (plist-get params :host) "localhost")) - (remote-host (if (member host '("localhost" "127.0.0.1")) - "" - host)) - (repl-type (or (plist-get params :repl-type) "unknown")) - (cljs-repl-type (or (and (eq repl-type 'cljs) - (plist-get params :cljs-repl-type)) - "")) - (specs `((?h . ,host) - (?H . ,remote-host) - (?p . ,port) - (?j . ,short-proj) - (?J . ,long-proj) - (?r . ,repl-type) - (?S . ,cljs-repl-type))) - (ses-name (or (plist-get params :session-name) - (format-spec cider-session-name-template specs))) - (specs (append `((?s . ,ses-name)) specs))) - (thread-last - (format-spec template specs) - ;; remove extraneous separators - (replace-regexp-in-string "\\([:-]\\)[:-]+" "\\1") - (replace-regexp-in-string "\\(^[:-]\\)\\|\\([:-]$\\)" "") - (replace-regexp-in-string "[:-]\\([])*]\\)" "\\1")))) - -(defun cider-make-session-name (params) - "Create new session name given plist of connection PARAMS. -Session name can be customized with `cider-session-name-template'." - (let* ((root-name (cider-format-connection-params cider-session-name-template params)) - (other-names (mapcar #'car (sesman-sessions 'CIDER))) - (name root-name) - (i 2)) - (while (member name other-names) - (setq name (concat root-name "#" (number-to-string i)) - i (+ i 1))) - name)) - - -;;; REPL Buffer Init - -(defvar-local cider-cljs-repl-type nil - "The type of the ClojureScript runtime (Browser, Node, Figwheel, etc.).") - -(defvar-local cider-repl-type nil - "The type of this REPL buffer, usually either clj or cljs.") - -(defvar-local cider-repl-cljs-upgrade-pending nil - "Is the cljs repl currently pending?") - -(defun cider-repl-type (repl-buffer) - "Get REPL-BUFFER's type." - (buffer-local-value 'cider-repl-type repl-buffer)) - -(defun cider-cljs-pending-p (repl-buffer) - "Returns non nil when REPL-BUFFER is currently a pending cljs repl." - (buffer-local-value 'cider-repl-cljs-upgrade-pending repl-buffer)) - -(defun cider-repl-type-for-buffer (&optional buffer) - "Return the matching connection type (clj or cljs) for BUFFER. -BUFFER defaults to the `current-buffer'. In cljc buffers return -multi. This function infers connection type based on the major mode. -For the REPL type use the function `cider-repl-type'." - (with-current-buffer (or buffer (current-buffer)) - (cond - ((derived-mode-p 'clojurescript-mode) 'cljs) - ((derived-mode-p 'clojurec-mode) 'multi) - ((derived-mode-p 'clojure-mode) 'clj) - (cider-repl-type)))) - -(defun cider-set-repl-type (&optional type) - "Set REPL TYPE to clj or cljs. -Assume that the current buffer is a REPL." - (interactive) - (let ((type (cider-maybe-intern (or type (completing-read - (format "Set REPL type (currently `%s') to: " - cider-repl-type) - '(clj cljs)))))) - (when (or (not (equal cider-repl-type type)) - (null mode-name)) - (setq cider-repl-type type) - (setq mode-name (format "REPL[%s]" type)) - (let ((params (cider--gather-connect-params))) - ;; We need to set current name to something else temporarily to avoid - ;; false name duplication in `nrepl-repl-buffer-name`. - (rename-buffer (generate-new-buffer-name "*dummy-cider-repl-buffer*")) - (rename-buffer (nrepl-repl-buffer-name params)) - (when (and nrepl-log-messages nrepl-messages-buffer) - (with-current-buffer nrepl-messages-buffer - (rename-buffer (nrepl-messages-buffer-name params)))))))) - -(defun cider--choose-reusable-repl-buffer (params) - "Find connection-less REPL buffer and ask the user for confirmation. -Return nil if no such buffers exists or the user has chosen not to reuse -the buffer. If multiple dead REPLs exist, ask the user to choose one. -PARAMS is a plist as received by `cider-repl-create'." - (when-let* ((repls (seq-filter (lambda (b) - (with-current-buffer b - (and (derived-mode-p 'cider-repl-mode) - (not (process-live-p (get-buffer-process b)))))) - (buffer-list)))) - (let* ((proj-dir (plist-get params :project-dir)) - (host (plist-get params :host)) - (port (plist-get params :port)) - (type (plist-get params :repl-type)) - (scored-repls - (mapcar (lambda (b) - (let ((bparams (ignore-errors (cider--gather-connect-params nil b)))) - (when (eq type (plist-get bparams :repl-type)) - (cons b (+ - (if (equal proj-dir (plist-get bparams :project-dir)) 8 0) - (if (equal host (plist-get bparams :host)) 4 0) - (if (equal port (plist-get bparams :port)) 2 0)))))) - repls)) - (sorted-repls (mapcar #'car (seq-sort-by #'cdr #'> (delq nil scored-repls))))) - (cond ((null sorted-repls) nil) - ((and (= 1 (length sorted-repls)) - (eq cider-reuse-dead-repls 'prompt)) - (if (y-or-n-p (format "A dead REPL %s exists. Reuse buffer? " (car sorted-repls))) - (car sorted-repls) - (and (y-or-n-p "Kill dead REPL buffer?") - (kill-buffer (car sorted-repls)) - nil))) - ((and (< 1 (length sorted-repls)) - (memq cider-reuse-dead-repls '(prompt auto))) - (if (y-or-n-p "Dead REPL buffers exist. Select one to reuse? ") - (get-buffer (completing-read "REPL buffer to reuse: " (mapcar #'buffer-name sorted-repls) - nil t nil nil (car sorted-repls))) - (and (y-or-n-p "Kill all dead REPL buffers?") - (mapc #'kill-buffer sorted-repls) - nil))) - (cider-reuse-dead-repls ;; fallthrough for 'auto / 'any / other non-nil values - (car sorted-repls)))))) - -(declare-function cider-default-err-handler "cider-eval") -(declare-function cider-repl-mode "cider-repl") -(declare-function cider-repl--state-handler "cider-repl") -(declare-function cider-repl-reset-markers "cider-repl") -(defvar-local cider-session-name nil) -(defvar-local cider-repl-init-function nil) -(defvar-local cider-launch-params nil) -(defun cider-repl-create (params) - "Create new repl buffer. -PARAMS is a plist which contains :repl-type, :host, :port, :project-dir, -:repl-init-function and :session-name. When non-nil, :repl-init-function -must be a function with no arguments which is called after repl creation -function with the repl buffer set as current." - ;; Connection might not have been set as yet. Please don't send requests in - ;; this function, but use cider--connected-handler instead. - (let ((buffer (or (plist-get params :repl-buffer) - (and cider-reuse-dead-repls - (cider--choose-reusable-repl-buffer params)) - (get-buffer-create (generate-new-buffer-name "*cider-uninitialized-repl*")))) - (ses-name (or (plist-get params :session-name) - (cider-make-session-name params)))) - (with-current-buffer buffer - (setq-local sesman-system 'CIDER) - (setq-local default-directory (or (plist-get params :project-dir) default-directory)) - ;; creates a new session if session with ses-name doesn't already exist - (sesman-add-object 'CIDER ses-name buffer 'allow-new) - (unless (derived-mode-p 'cider-repl-mode) - (cider-repl-mode)) - (setq nrepl-err-handler #'cider-default-err-handler - ;; used as a new-repl marker in cider-set-repl-type - mode-name nil - cider-session-name ses-name - nrepl-project-dir (plist-get params :project-dir) - ;; Cljs repls are pending until they are upgraded. See cider-repl--state-handler - cider-repl-type (plist-get params :repl-type) - cider-repl-cljs-upgrade-pending (plist-get params :cider-repl-cljs-upgrade-pending) - ;; ran at the end of cider--connected-handler - cider-repl-init-function (plist-get params :repl-init-function) - cider-launch-params params) - (cider-repl-reset-markers) - (add-hook 'nrepl-response-handler-functions #'cider-repl--state-handler nil 'local) - (add-hook 'nrepl-connected-hook #'cider--connected-handler nil 'local) - (add-hook 'nrepl-disconnected-hook #'cider--disconnected-handler nil 'local) - (current-buffer)))) - - -;;; Current/other REPLs - -(defun cider--no-repls-user-error (type) - "Throw \"No REPL\" user error customized for TYPE." - (let ((type (cond - ((or (eq type 'multi) (eq type 'any)) - "clj or cljs") - ((listp type) - (mapconcat #'identity type " or ")) - (type)))) - (user-error "No %s REPLs in current session \"%s\"" - type (car (sesman-current-session 'CIDER))))) - -(defun cider-current-repl (&optional type ensure) - "Get the most recent REPL of TYPE from the current session. -TYPE is either clj, cljs, multi or any. -When nil, infer the type from the current buffer. -If ENSURE is non-nil, throw an error if either there is -no linked session or there is no REPL of TYPE within the current session." - (let ((type (cider-maybe-intern type))) - (if (and (derived-mode-p 'cider-repl-mode) - (or (null type) - (eq 'any type) - (eq cider-repl-type type))) - ;; shortcut when in REPL buffer - (current-buffer) - (let* ((type (or type (cider-repl-type-for-buffer))) - (repls (cider-repls type ensure)) - (repl (if (<= (length repls) 1) - (car repls) - ;; pick the most recent one - (seq-find (lambda (b) - (member b repls)) - (buffer-list))))) - (if (and ensure (null repl)) - (cider--no-repls-user-error type) - repl))))) - -(defun cider--match-repl-type (type buffer) - "Return non-nil if TYPE matches BUFFER's REPL type." - (let ((buffer-repl-type (cider-repl-type buffer))) - (cond ((null buffer-repl-type) nil) - ((or (null type) (eq type 'multi) (eq type 'any)) t) - ((listp type) (member buffer-repl-type type)) - (t - (or (string= type buffer-repl-type) - (let ((capabilities - (buffer-local-value 'cider-connection-capabilities buffer))) - (cond ((listp type) - (cl-some (lambda (it) (member it capabilities)) type)) - (t (member type capabilities))))))))) - -(defun cider--get-host-from-session (session) - "Returns the host associated with SESSION." - (plist-get (cider--gather-session-params session) - :host)) - -(defun cider--make-sessions-list-with-hosts (sessions) - "Makes a list of SESSIONS and their hosts. -Returns a list of the form ((session1 host1) (session2 host2) ...)." - (mapcar (lambda (session) - (list session (cider--get-host-from-session session))) - sessions)) - -(defun cider--get-sessions-with-same-host (session sessions) - "Returns a list of SESSIONS with the same host as SESSION." - (mapcar #'car - (seq-filter (lambda (x) - (string-equal (cadr x) - (cider--get-host-from-session session))) - (cider--make-sessions-list-with-hosts sessions)))) - -(defun cider--extract-connections (sessions) - "Returns a flattened list of all session buffers in SESSIONS." - (cl-reduce (lambda (x y) - (append x (cdr y))) - sessions - :initial-value '())) - -(defun cider-repls (&optional type ensure) - "Return cider REPLs of TYPE from the current session. -If TYPE is nil or multi, return all REPLs. If TYPE is a list of types, -return only REPLs of type contained in the list. If ENSURE is non-nil, -throw an error if no linked session exists." - (let ((type (cond - ((listp type) - (mapcar #'cider-maybe-intern type)) - ((cider-maybe-intern type)))) - (repls (pcase cider-merge-sessions - ('host - (if ensure - (or (cider--extract-connections (cider--get-sessions-with-same-host - (sesman-current-session 'CIDER) - (sesman-current-sessions 'CIDER))) - (user-error "No linked %s sessions" 'CIDER)) - (cider--extract-connections (cider--get-sessions-with-same-host - (sesman-current-session 'CIDER) - (sesman-current-sessions 'CIDER))))) - ('project - (if ensure - (or (cider--extract-connections (sesman-current-sessions 'CIDER)) - (user-error "No linked %s sessions" 'CIDER)) - (cider--extract-connections (sesman-current-sessions 'CIDER)))) - (_ (cdr (if ensure - (sesman-ensure-session 'CIDER) - (sesman-current-session 'CIDER))))))) - (or (seq-filter (lambda (b) - (unless - (cider-cljs-pending-p b) - (cider--match-repl-type type b))) - repls) - (when ensure - (cider--no-repls-user-error type))))) - -(defun cider-map-repls (which function) - "Call FUNCTION once for each appropriate REPL as indicated by WHICH. -The function is called with one argument, the REPL buffer. The appropriate -connections are found by inspecting the current buffer. WHICH is one of -the following keywords: - :auto - Act on the connections whose type matches the current buffer. In - `cljc' files, mapping happens over both types of REPLs. - :clj (:cljs) - Map over clj (cljs)) REPLs only. - :clj-strict (:cljs-strict) - Map over clj (cljs) REPLs but signal a - `user-error' in `clojurescript-mode' (`clojure-mode'). Use this for - commands only supported in Clojure (ClojureScript). -Error is signaled if no REPL buffers of specified type exist in current -session." - (declare (indent 1)) - (let ((cur-type (cider-repl-type-for-buffer))) - (cl-case which - (:clj-strict (when (eq cur-type 'cljs) - (user-error "Clojure-only operation requested in a ClojureScript buffer"))) - (:cljs-strict (when (eq cur-type 'clj) - (user-error "ClojureScript-only operation requested in a Clojure buffer")))) - (let* ((type (cl-case which - ((:clj :clj-strict) 'clj) - ((:cljs :cljs-strict) 'cljs) - (:auto (if (eq cur-type 'multi) - '(clj cljs) - cur-type)))) - (ensure (cl-case which - (:auto nil) - (t 'ensure))) - (repls (cider-repls type ensure))) - (mapcar function repls)))) - -;; REPLs double as connections in CIDER, so it's useful to be able to refer to -;; them as connections in certain contexts. -(defalias 'cider-current-connection #'cider-current-repl) -(defalias 'cider-connections #'cider-repls) -(defalias 'cider-map-connections #'cider-map-repls) -(defalias 'cider-connection-type-for-buffer #'cider-repl-type-for-buffer) - -;; Deprecated after #2324 (introduction of sesman) - -(define-obsolete-function-alias 'cider-current-repl-buffer #'cider-current-repl "0.18") -(define-obsolete-function-alias 'cider-repl-buffers #'cider-repls "0.18") -(define-obsolete-function-alias 'cider-current-session #'cider-nrepl-eval-session "0.18") -(define-obsolete-function-alias 'cider-current-tooling-session #'cider-nrepl-tooling-session "0.18") -(define-obsolete-function-alias 'nrepl-connection-buffer-name #'nrepl-repl-buffer-name "0.18") - -(provide 'cider-connection) - -;;; cider-connection.el ends here diff --git a/elpa/cider-20230707.640/cider-debug.el b/elpa/cider-20230707.640/cider-debug.el deleted file mode 100644 index ec67a87a..00000000 --- a/elpa/cider-20230707.640/cider-debug.el +++ /dev/null @@ -1,796 +0,0 @@ -;;; cider-debug.el --- CIDER interaction with the cider.debug nREPL middleware -*- lexical-binding: t; -*- - -;; Copyright © 2015-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors - -;; Author: Artur Malabarba - -;; 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 . - -;;; Commentary: - -;; Instrument code with `cider-debug-defun-at-point', and when the code is -;; executed cider-debug will kick in. See this function's doc for more -;; information. - -;;; Code: - -(require 'map) -(require 'seq) -(require 'subr-x) - -(require 'spinner) - -(require 'cider-browse-ns) -(require 'cider-client) -(require 'cider-eval) -(require 'cider-inspector) -(require 'cider-util) -(require 'cider-common) -(require 'nrepl-client) ; `nrepl--mark-id-completed' -(require 'nrepl-dict) - - -;;; Customization -(defgroup cider-debug nil - "Presentation and behavior of the cider debugger." - :prefix "cider-debug-" - :group 'cider - :package-version '(cider . "0.10.0")) - -(defface cider-debug-code-overlay-face - '((((class color) (background light)) :background "grey80") - (((class color) (background dark)) :background "grey30")) - "Face used to mark code being debugged." - :package-version '(cider . "0.9.1")) - -(defface cider-debug-prompt-face - '((t :underline t :inherit font-lock-builtin-face)) - "Face used to highlight keys in the debug prompt." - :package-version '(cider . "0.10.0")) - -(defface cider-enlightened-face - '((((class color) (background light)) :inherit cider-result-overlay-face - :box (:color "darkorange" :line-width -1)) - (((class color) (background dark)) :inherit cider-result-overlay-face - ;; "#dd0" is a dimmer yellow. - :box (:color "#990" :line-width -1))) - "Face used to mark enlightened sexps and their return values." - :package-version '(cider . "0.11.0")) - -(defface cider-enlightened-local-face - '((((class color) (background light)) :weight bold :foreground "darkorange") - (((class color) (background dark)) :weight bold :foreground "yellow")) - "Face used to mark enlightened locals (not their values)." - :package-version '(cider . "0.11.0")) - -(defcustom cider-debug-prompt 'overlay - "If and where to show the keys while debugging. -If `minibuffer', show it in the minibuffer along with the return value. -If `overlay', show it in an overlay above the current function. -If t, do both. -If nil, don't list available keys at all." - :type '(choice (const :tag "Show in minibuffer" minibuffer) - (const :tag "Show above function" overlay) - (const :tag "Show in both places" t) - (const :tag "Don't list keys" nil)) - :package-version '(cider . "0.10.0")) - -(defcustom cider-debug-use-overlays t - "Whether to highlight debugging information with overlays. -Takes the same possible values as `cider-use-overlays', but only applies to -values displayed during debugging sessions. -To control the overlay that lists possible keys above the current function, -configure `cider-debug-prompt' instead." - :type '(choice (const :tag "End of line" t) - (const :tag "Bottom of screen" nil) - (const :tag "Both" both)) - :package-version '(cider . "0.9.1")) - -(make-obsolete 'cider-debug-print-length 'cider-debug-print-options "0.20") -(make-obsolete 'cider-debug-print-level 'cider-debug-print-options "0.20") -(make-obsolete-variable 'cider-debug-print-options 'cider-print-options "0.21") - - -;;; Implementation -(declare-function cider-browse-ns--combined-vars-with-meta "cider-browse-ns") - -(defun cider-browse-instrumented-defs () - "List all instrumented definitions." - (interactive) - (if-let* ((all (thread-first (cider-nrepl-send-sync-request '("op" "debug-instrumented-defs")) - (nrepl-dict-get "list")))) - (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t) - (let ((inhibit-read-only t)) - (dolist (list all) - (let* ((ns (car list)) - (ns-vars-with-meta (cider-browse-ns--combined-vars-with-meta ns)) - (instrumented-meta (nrepl-dict-filter (lambda (k _) - (member k list)) - ns-vars-with-meta))) - (cider-browse-ns--list (current-buffer) ns - instrumented-meta - ns))))) - (message "No currently instrumented definitions"))) - -(defun cider--debug-response-handler (response) - "Handles RESPONSE from the cider.debug middleware." - (nrepl-dbind-response response (status id causes) - (when (member "enlighten" status) - (cider--handle-enlighten response)) - (when (or (member "eval-error" status) - (member "stack" status)) - ;; TODO: Make the error buffer a bit friendlier when we're just printing - ;; the stack. - (cider--render-stacktrace-causes causes)) - (when (member "need-debug-input" status) - (cider--handle-debug response)) - (when (member "done" status) - (nrepl--mark-id-completed id)))) - -(defun cider--debug-init-connection () - "Initialize a connection with the cider.debug middleware." - (cider-nrepl-send-request - (thread-last - (map-merge 'list - '(("op" "init-debugger")) - (cider--nrepl-print-request-map fill-column)) - (seq-mapcat #'identity)) - #'cider--debug-response-handler)) - - -;;; Debugging overlays -(defconst cider--fringe-arrow-string - #("." 0 1 (display (left-fringe right-triangle))) - "Used as an overlay's before-string prop to place a fringe arrow.") - -(defun cider--debug-display-result-overlay (value) - "Place an overlay at point displaying VALUE." - (when cider-debug-use-overlays - ;; This is cosmetic, let's ensure it doesn't break the session no matter what. - (ignore-errors - ;; Result - (cider--make-result-overlay (cider-font-lock-as-clojure value) - :where (point-marker) - :type 'debug-result - 'before-string cider--fringe-arrow-string) - ;; Code - (cider--make-overlay (save-excursion (clojure-backward-logical-sexp 1) (point)) - (point) 'debug-code - 'face 'cider-debug-code-overlay-face - ;; Higher priority than `show-paren'. - 'priority 2000)))) - - -;;; Minor mode -(defvar-local cider--debug-mode-response nil - "Response that triggered current debug session. -Set by `cider--turn-on-debug-mode'.") - -(defcustom cider-debug-display-locals nil - "If non-nil, local variables are displayed while debugging. -Can be toggled at any time with `\\[cider-debug-toggle-locals]'." - :type 'boolean - :package-version '(cider . "0.10.0")) - -(defcustom cider-debug-prompt-commands - '((?c "continue" "continue") - (?C "continue-all" nil) - (?n "next" "next") - (?i "in" "in") - (?o "out" "out") - (?O "force-out" nil) - (?h "here" "here") - (?e "eval" "eval") - (?p "inspect" "inspect") - (?P "inspect-prompt" nil) - (?l "locals" "locals") - (?j "inject" "inject") - (?s "stacktrace" "stacktrace") - (?t "trace" "trace") - (?q "quit" "quit")) - "A list of debugger command specs. - -Specs are in the format (KEY COMMAND-NAME DISPLAY-NAME?) where KEY is a -character which is mapped to the command COMMAND-NAME is a valid debug -command to be passed to the cider-nrepl middleware DISPLAY-NAME is the -string displayed in the debugger overlay - -If DISPLAY-NAME is nil, that command is hidden from the overlay but still -callable. The rest of the commands are displayed in the same order as this -list." - :type '(alist :key-type character - :value-type (list - (string :tag "command name") - (choice (string :tag "display name") nil))) - :package-version '(cider . "0.24.0")) - -(defun cider--debug-format-locals-list (locals) - "Return a string description of list LOCALS. -Each element of LOCALS should be a list of at least two elements." - (if locals - (let ((left-col-width - ;; To right-indent the variable names. - (apply #'max (mapcar (lambda (l) (string-width (car l))) locals)))) - ;; A format string to build a format string. :-P - (mapconcat (lambda (l) (format (format " %%%ds: %%s\n" left-col-width) - (propertize (car l) 'face 'font-lock-variable-name-face) - (cider-font-lock-as-clojure (cadr l)))) - locals "")) - "")) - -(defun cider--debug-propertize-prompt-commands () - "In-place format the command display names for the `cider-debug-prompt' overlay." - (mapc (lambda (spec) - (cl-destructuring-bind (char _cmd disp-name) spec - (when-let* ((pos (cl-position char disp-name))) - (put-text-property pos (1+ pos) 'face 'cider-debug-prompt-face disp-name)))) - cider-debug-prompt-commands)) - -(defun cider--debug-prompt (commands) - "Return prompt to display for COMMANDS." - ;; Force `default' face, otherwise the overlay "inherits" the face of the text - ;; after it. - (format (propertize "%s\n" 'face 'default) - (cl-reduce - (lambda (prompt spec) - (cl-destructuring-bind (_char cmd disp) spec - (if (and disp (cl-find cmd commands :test 'string=)) - (concat prompt " " disp) - prompt))) - cider-debug-prompt-commands - :initial-value ""))) - -(defvar-local cider--debug-prompt-overlay nil) - -(defun cider--debug-mode-redisplay () - "Display the input prompt to the user." - (nrepl-dbind-response cider--debug-mode-response (debug-value input-type locals) - ;; input-type is an unsorted collection of command names, - ;; as sent by `cider.nrepl.middleware.debug/read-debug-input` - (when (or (eq cider-debug-prompt t) - (eq cider-debug-prompt 'overlay)) - (if (overlayp cider--debug-prompt-overlay) - (overlay-put cider--debug-prompt-overlay - 'before-string (cider--debug-prompt input-type)) - (setq cider--debug-prompt-overlay - (cider--make-overlay - (max (car (cider-defun-at-point 'bounds)) - (window-start)) - nil 'debug-prompt - 'before-string (cider--debug-prompt input-type))))) - (let* ((value (concat " " cider-eval-result-prefix - (cider-font-lock-as-clojure - (or debug-value "#unknown#")))) - (to-display - (concat (when cider-debug-display-locals - (cider--debug-format-locals-list locals)) - (when (or (eq cider-debug-prompt t) - (eq cider-debug-prompt 'minibuffer)) - (cider--debug-prompt input-type)) - (when (or (not cider-debug-use-overlays) - (eq cider-debug-use-overlays 'both)) - value)))) - (if (> (string-width to-display) 0) - (message "%s" to-display) - ;; If there's nothing to display in the minibuffer. Just send the value - ;; to the Messages buffer. - (message "%s" value) - (message nil))))) - -(defun cider-debug-toggle-locals () - "Toggle display of local variables." - (interactive) - (setq cider-debug-display-locals (not cider-debug-display-locals)) - (cider--debug-mode-redisplay)) - -(defun cider--debug-lexical-eval (key form &optional callback _point) - "Eval FORM in the lexical context of debug session given by KEY. -Do nothing if CALLBACK is provided. -Designed to be used as `cider-interactive-eval-override' and called instead -of `cider-interactive-eval' in debug sessions." - ;; The debugger uses its own callback, so if the caller is passing a callback - ;; we return nil and let `cider-interactive-eval' do its thing. - (unless callback - (cider-debug-mode-send-reply (format "{:response :eval, :code %s}" form) - key) - t)) - -(defvar cider--debug-mode-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - (tool-bar-add-item "right-arrow" #'cider-debug-mode-send-reply :next :label "Next step") - (tool-bar-add-item "next-node" #'cider-debug-mode-send-reply :continue :label "Continue") - (tool-bar-add-item "jump-to" #'cider-debug-mode-send-reply :out :label "Out of sexp") - (tool-bar-add-item "exit" #'cider-debug-mode-send-reply :quit :label "Quit") - tool-bar-map)) - -(defvar cider--debug-mode-map - (let ((map (make-sparse-keymap))) - ;; Bind the `:here` command to both h and H, because it behaves differently - ;; if invoked with an uppercase letter. - (define-key map "h" #'cider-debug-move-here) - (define-key map "H" #'cider-debug-move-here) - (define-key map "L" #'cider-debug-toggle-locals) - map) - "The active keymap during a debugging session.") - -(define-minor-mode cider--debug-mode - "Mode active during debug sessions. -In order to work properly, this mode must be activated by -`cider--turn-on-debug-mode'." - :init-value nil :lighter " DEBUG" :keymap '() - (if cider--debug-mode - (if cider--debug-mode-response - (nrepl-dbind-response cider--debug-mode-response (input-type) - ;; A debug session is an ongoing eval, but it's annoying to have the - ;; spinner spinning while you debug. - (when spinner-current (spinner-stop)) - (setq-local tool-bar-map cider--debug-mode-tool-bar-map) - (add-hook 'kill-buffer-hook #'cider--debug-quit nil 'local) - (add-hook 'before-revert-hook #'cider--debug-quit nil 'local) - (unless (consp input-type) - (error "Activated debug-mode on a message not asking for commands: %s" cider--debug-mode-response)) - ;; Integrate with eval commands. - (setq cider-interactive-eval-override - (apply-partially #'cider--debug-lexical-eval - (nrepl-dict-get cider--debug-mode-response "key"))) - ;; Map over the key->command alist and set the keymap - (mapc - (lambda (p) - (let ((char (car p))) - (unless (= char ?h) ; `here' needs a special command. - (define-key cider--debug-mode-map (string char) #'cider-debug-mode-send-reply)) - (when (= char ?o) - (define-key cider--debug-mode-map (string (upcase ?o)) #'cider-debug-mode-send-reply)))) - cider-debug-prompt-commands) - (cider--debug-propertize-prompt-commands) - ;; Show the prompt. - (cider--debug-mode-redisplay) - ;; If a sync request is ongoing, the user can't act normally to - ;; provide input, so we enter `recursive-edit'. - (when nrepl-ongoing-sync-request - (recursive-edit))) - (cider--debug-mode -1) - (if (called-interactively-p 'any) - (user-error (substitute-command-keys "Don't call this mode manually, use `\\[universal-argument] \\[cider-eval-defun-at-point]' instead")) - (error "Attempt to activate `cider--debug-mode' without setting `cider--debug-mode-response' first"))) - (setq cider-interactive-eval-override nil) - (setq cider--debug-mode-response nil) - ;; We wait a moment before clearing overlays and the read-onlyness, so that - ;; cider-nrepl has a chance to send the next message, and so that the user - ;; doesn't accidentally hit `n' between two messages (thus editing the code). - (when-let* ((proc (unless nrepl-ongoing-sync-request - (get-buffer-process (cider-current-repl))))) - (accept-process-output proc 1)) - (unless cider--debug-mode - (setq buffer-read-only nil) - (cider--debug-remove-overlays (current-buffer))) - (when nrepl-ongoing-sync-request - (ignore-errors (exit-recursive-edit))))) - -(defun cider--debug-remove-overlays (&optional buffer) - "Remove CIDER debug overlays from BUFFER if variable `cider--debug-mode' is nil." - (when (or (not buffer) (buffer-live-p buffer)) - (with-current-buffer (or buffer (current-buffer)) - (unless cider--debug-mode - (kill-local-variable 'tool-bar-map) - (remove-overlays nil nil 'category 'debug-result) - (remove-overlays nil nil 'category 'debug-code) - (setq cider--debug-prompt-overlay nil) - (remove-overlays nil nil 'category 'debug-prompt))))) - -(defun cider--debug-set-prompt (value) - "Set `cider-debug-prompt' to VALUE, then redisplay." - (setq cider-debug-prompt value) - (cider--debug-mode-redisplay)) - -(easy-menu-define cider-debug-mode-menu cider--debug-mode-map - "Menu for CIDER debug mode." - `("CIDER Debugger" - ["Next step" (cider-debug-mode-send-reply ":next") :keys "n"] - ["Continue" (cider-debug-mode-send-reply ":continue") :keys "c"] - ["Continue non-stop" (cider-debug-mode-send-reply ":continue-all") :keys "C"] - ["Move out of sexp" (cider-debug-mode-send-reply ":out") :keys "o"] - ["Forced move out of sexp" (cider-debug-mode-send-reply ":out" nil true) :keys "O"] - ["Move to current position" (cider-debug-mode-send-reply ":here") :keys "h"] - ["Quit" (cider-debug-mode-send-reply ":quit") :keys "q"] - "--" - ["Evaluate in current scope" (cider-debug-mode-send-reply ":eval") :keys "e"] - ["Inject value" (cider-debug-mode-send-reply ":inject") :keys "i"] - ["Inspect current value" (cider-debug-mode-send-reply ":inspect") :keys "p"] - ["Inspect expression" (cider-debug-mode-send-reply ":inspect-prompt") :keys "P"] - ["Inspect local variables" (cider-debug-mode-send-reply ":locals") :keys "l"] - "--" - ("Configure keys prompt" - ["Don't show keys" (cider--debug-set-prompt nil) :style toggle :selected (eq cider-debug-prompt nil)] - ["Show in minibuffer" (cider--debug-set-prompt 'minibuffer) :style toggle :selected (eq cider-debug-prompt 'minibuffer)] - ["Show above function" (cider--debug-set-prompt 'overlay) :style toggle :selected (eq cider-debug-prompt 'overlay)] - ["Show in both places" (cider--debug-set-prompt t) :style toggle :selected (eq cider-debug-prompt t)] - "--" - ["List locals" cider-debug-toggle-locals :style toggle :selected cider-debug-display-locals]) - ["Customize" (customize-group 'cider-debug)])) - -(defun cider--uppercase-command-p () - "Return non-nil if the last command was uppercase letter." - (ignore-errors - (let ((case-fold-search nil)) - (string-match "[[:upper:]]" (string last-command-event))))) - -(defun cider-debug-mode-send-reply (command &optional key force) - "Reply to the message that started current bufer's debugging session. -COMMAND is sent as the input option. KEY can be provided to reply to a -specific message. If FORCE is non-nil, send a \"force?\" argument in the -message." - (interactive (list - (if (symbolp last-command-event) - (symbol-name last-command-event) - (ignore-errors - (concat ":" (cadr (assoc last-command-event cider-debug-prompt-commands))))) - nil - (cider--uppercase-command-p))) - (when (and (string-prefix-p ":" command) force) - (setq command (format "{:response %s :force? true}" command))) - (cider-nrepl-send-unhandled-request - `("op" "debug-input" - "input" ,(or command ":quit") - "key" ,(or key (nrepl-dict-get cider--debug-mode-response "key")))) - (ignore-errors (cider--debug-mode -1))) - -(defun cider--debug-quit () - "Send a :quit reply to the debugger. Used in hooks." - (when cider--debug-mode - (cider-debug-mode-send-reply ":quit") - (message "Quitting debug session"))) - - -;;; Movement logic -(defconst cider--debug-buffer-format "*cider-debug %s*") - -(defun cider--debug-trim-code (code) - "Remove whitespace and reader macros from the start of the CODE. -Return trimmed CODE." - (replace-regexp-in-string "\\`#[a-z]+[\n\r[:blank:]]*" "" code)) - -(declare-function cider-set-buffer-ns "cider-mode") -(defun cider--initialize-debug-buffer (code ns id &optional reason) - "Create a new debugging buffer with CODE and namespace NS. -ID is the id of the message that instrumented CODE. -REASON is a keyword describing why this buffer was necessary." - (let ((buffer-name (format cider--debug-buffer-format id))) - (if-let* ((buffer (get-buffer buffer-name))) - (cider-popup-buffer-display buffer 'select) - (with-current-buffer (cider-popup-buffer buffer-name 'select - #'clojure-mode 'ancillary) - (cider-set-buffer-ns ns) - (setq buffer-undo-list nil) - (let ((inhibit-read-only t) - (buffer-undo-list t)) - (erase-buffer) - (insert (format "%s" (cider--debug-trim-code code))) - (when code - (insert "\n\n\n;; We had to create this temporary buffer because we couldn't find the original definition. That probably happened because " - reason - ".") - (fill-paragraph)) - (font-lock-ensure) - (set-buffer-modified-p nil)))) - (switch-to-buffer buffer-name) - (goto-char (point-min)))) - -(defun cider--debug-goto-keyval (key) - "Find KEY in current sexp or return nil." - (when-let* ((limit (ignore-errors (save-excursion (up-list) (point))))) - (search-forward-regexp (concat "\\_<" (regexp-quote key) "\\_>") - limit 'noerror))) - -(defun cider--debug-skip-ignored-forms () - "Skip past all forms ignored with #_ reader macro." - ;; Logic taken from `clojure--search-comment-macro-internal' - (while (looking-at (concat "[ ,\r\t\n]*" clojure--comment-macro-regexp)) - (let ((md (match-data)) - (start (match-beginning 1))) - (goto-char start) - ;; Count how many #_ we got and step by that many sexps - (clojure-forward-logical-sexp - (count-matches (rx "#_") (elt md 0) (elt md 1)))))) - -(defun cider--debug-move-point (coordinates) - "Place point on after the sexp specified by COORDINATES. -COORDINATES is a list of integers that specify how to navigate into the -sexp that is after point when this function is called. - -As an example, a COORDINATES list of '(1 0 2) means: - - enter next sexp then `forward-sexp' once, - - enter next sexp, - - enter next sexp then `forward-sexp' twice. - -In the following snippet, this takes us to the (* x 2) sexp (point is left -at the end of the given sexp). - - (letfn [(twice [x] - (* x 2))] - (twice 15)) - -In addition to numbers, a coordinate can be a string. This string names the -key of a map, and it means \"go to the value associated with this key\"." - (condition-case-unless-debug nil - ;; Navigate through sexps inside the sexp. - (let ((in-syntax-quote nil)) - (while coordinates - (while (clojure--looking-at-non-logical-sexp) - (forward-sexp)) - ;; An `@x` is read as (deref x), so we pop coordinates once to account - ;; for the extra depth, and move past the @ char. - (if (eq ?@ (char-after)) - (progn (forward-char 1) - (pop coordinates)) - (down-list) - ;; Are we entering a syntax-quote? - (when (looking-back "`\\(#{\\|[{[(]\\)" (line-beginning-position)) - ;; If we are, this affects all nested structures until the next `~', - ;; so we set this variable for all following steps in the loop. - (setq in-syntax-quote t)) - (when in-syntax-quote - ;; A `(. .) is read as (seq (concat (list .) (list .))). This pops - ;; the `seq', since the real coordinates are inside the `concat'. - (pop coordinates) - ;; Non-list seqs like `[] and `{} are read with - ;; an extra (apply vector ...), so pop it too. - (unless (eq ?\( (char-before)) - (pop coordinates))) - ;; #(...) is read as (fn* ([] ...)), so we patch that here. - (when (looking-back "#(" (line-beginning-position)) - (pop coordinates)) - (if coordinates - (let ((next (pop coordinates))) - (when in-syntax-quote - ;; We're inside the `concat' form, but we need to discard the - ;; actual `concat' symbol from the coordinate. - (setq next (1- next))) - ;; String coordinates are map keys. - (if (stringp next) - (cider--debug-goto-keyval next) - (clojure-forward-logical-sexp next) - (when in-syntax-quote - (clojure-forward-logical-sexp 1) - (forward-sexp -1) - ;; Here a syntax-quote is ending. - (let ((match (when (looking-at "~@?") - (match-string 0)))) - (when match - (setq in-syntax-quote nil)) - ;; A `~@' is read as the object itself, so we don't pop - ;; anything. - (unless (equal "~@" match) - ;; Anything else (including a `~') is read as a `list' - ;; form inside the `concat', so we need to pop the list - ;; from the coordinates. - (pop coordinates)))))) - ;; If that extra pop was the last coordinate, this represents the - ;; entire #(...), so we should move back out. - (backward-up-list))) - ;; Finally skip past all #_ forms - (cider--debug-skip-ignored-forms)) - ;; Place point at the end of instrumented sexp. - (clojure-forward-logical-sexp 1)) - ;; Avoid throwing actual errors, since this happens on every breakpoint. - (error (message "Can't find instrumented sexp, did you edit the source?")))) - -(defun cider--debug-position-for-code (code) - "Return non-nil if point is roughly before CODE. -This might move point one line above." - (or (looking-at-p (regexp-quote code)) - (let ((trimmed (regexp-quote (cider--debug-trim-code code)))) - (or (looking-at-p trimmed) - ;; If this is a fake #dbg injected by `C-u - ;; C-M-x', then the sexp we want is actually on - ;; the line above. - (progn (forward-line -1) - (looking-at-p trimmed)))))) - -(defun cider--debug-find-source-position (response &optional create-if-needed) - "Return a marker of the position after the sexp specified in RESPONSE. -This marker might be in a different buffer! If the sexp can't be -found (file that contains the code is no longer visited or has been -edited), return nil. However, if CREATE-IF-NEEDED is non-nil, a new buffer -is created in this situation and the return value is never nil. - -Follow the \"line\" and \"column\" entries in RESPONSE, and check whether -the code at point matches the \"code\" entry in RESPONSE. If it doesn't, -assume that the code in this file has been edited, and create a temp buffer -holding the original code. -Either way, navigate inside the code by following the \"coor\" entry which -is a coordinate measure in sexps." - (nrepl-dbind-response response (code file line column ns original-id coor) - (when (or code (and file line column)) - ;; This is for restoring current-buffer. - (save-excursion - (let ((out)) - ;; We prefer in-source debugging. - (when-let* ((buf (and file line column - (ignore-errors - (cider--find-buffer-for-file file))))) - ;; The logic here makes it hard to use `with-current-buffer'. - (with-current-buffer buf - ;; This is for restoring point inside buf. - (save-excursion - ;; Get to the proper line & column in the file - (forward-line (- line (line-number-at-pos))) - ;; Column numbers in the response start from 1. - ;; Convert to Emacs system which starts from 0 - ;; Inverse of `cider-column-number-at-pos'. - (move-to-column (max 0 (1- column))) - ;; Check if it worked - (when (cider--debug-position-for-code code) - ;; Find the desired sexp. - (cider--debug-move-point coor) - (setq out (point-marker)))))) - ;; But we can create a temp buffer if that fails. - (or out - (when create-if-needed - (cider--initialize-debug-buffer - code ns original-id - (if (and line column) - "you edited the code" - "your nREPL version is older than 0.2.11")) - (save-excursion - (cider--debug-move-point coor) - (point-marker))))))))) - -(defun cider--handle-debug (response) - "Handle debugging notification. -RESPONSE is a message received from the nrepl describing the input -needed. It is expected to contain at least \"key\", \"input-type\", and -\"prompt\", and possibly other entries depending on the input-type." - (nrepl-dbind-response response (debug-value key input-type prompt inspect) - (condition-case-unless-debug e - (progn - (pcase input-type - ("expression" (cider-debug-mode-send-reply - (condition-case nil - (cider-read-from-minibuffer - (or prompt "Expression: ")) - (quit "nil")) - key)) - ((pred sequencep) - (let* ((marker (cider--debug-find-source-position response 'create-if-needed))) - (pop-to-buffer (marker-buffer marker)) - (goto-char marker)) - ;; The overlay code relies on window boundaries, but point could have been - ;; moved outside the window by some other code. Redisplay here to ensure the - ;; visible window includes point. - (redisplay) - ;; Remove overlays AFTER redisplaying! Otherwise there's a visible - ;; flicker even if we immediately recreate the overlays. - (cider--debug-remove-overlays) - (when cider-debug-use-overlays - (cider--debug-display-result-overlay debug-value)) - (setq cider--debug-mode-response response) - (cider--debug-mode 1))) - (when inspect - (setq cider-inspector--current-repl (cider-current-repl)) - (cider-inspector--render-value inspect))) - ;; If something goes wrong, we send a "quit" or the session hangs. - (error (cider-debug-mode-send-reply ":quit" key) - (message "Error encountered while handling the debug message: %S" e))))) - -(defun cider--handle-enlighten (response) - "Handle an enlighten notification. -RESPONSE is a message received from the nrepl describing the value and -coordinates of a sexp. Create an overlay after the specified sexp -displaying its value." - (when-let* ((marker (cider--debug-find-source-position response))) - (with-current-buffer (marker-buffer marker) - (save-excursion - (goto-char marker) - (clojure-backward-logical-sexp 1) - (nrepl-dbind-response response (debug-value erase-previous) - (when erase-previous - (remove-overlays (point) marker 'category 'enlighten)) - (when debug-value - (if (memq (char-before marker) '(?\) ?\] ?})) - ;; Enlightening a sexp looks like a regular return value, except - ;; for a different border. - (cider--make-result-overlay (cider-font-lock-as-clojure debug-value) - :where (cons marker marker) - :type 'enlighten - :prepend-face 'cider-enlightened-face) - ;; Enlightening a symbol uses a more abbreviated format. The - ;; result face is the same as a regular result, but we also color - ;; the symbol with `cider-enlightened-local-face'. - (cider--make-result-overlay (cider-font-lock-as-clojure debug-value) - :format "%s" - :where (cons (point) marker) - :type 'enlighten - 'face 'cider-enlightened-local-face)))))))) - - -;;; Move here command -;; This is the inverse of `cider--debug-move-point'. However, that algorithm is -;; complicated, and trying to code its inverse would probably be insane. -;; Instead, we find the coordinate by trial and error. -(defun cider--debug-find-coordinates-for-point (target &optional list-so-far) - "Return the coordinates list for reaching TARGET. -Assumes that the next thing after point is a logical Clojure sexp and that -TARGET is inside it. The returned list is suitable for use in -`cider--debug-move-point'. LIST-SO-FAR is for internal use." - (when (looking-at (rx (or "(" "[" "#{" "{"))) - (let ((starting-point (point))) - (unwind-protect - (let ((x 0)) - ;; Keep incrementing the last coordinate until we've moved - ;; past TARGET. - (while (condition-case nil - (progn (goto-char starting-point) - (cider--debug-move-point (append list-so-far (list x))) - (< (point) target)) - ;; Not a valid coordinate. Move back a step and stop here. - (scan-error (setq x (1- x)) - nil)) - (setq x (1+ x))) - (setq list-so-far (append list-so-far (list x))) - ;; We have moved past TARGET, now determine whether we should - ;; stop, or if target is deeper inside the previous sexp. - (if (or (= target (point)) - (progn (forward-sexp -1) - (<= target (point)))) - list-so-far - (goto-char starting-point) - (cider--debug-find-coordinates-for-point target list-so-far))) - ;; `unwind-protect' clause. - (goto-char starting-point))))) - -(defun cider-debug-move-here (&optional force) - "Skip any breakpoints up to point. -The boolean value of FORCE will be sent in the reply." - (interactive (list (cider--uppercase-command-p))) - (unless cider--debug-mode - (user-error "`cider-debug-move-here' only makes sense during a debug session")) - (let ((here (point))) - (nrepl-dbind-response cider--debug-mode-response (line column) - (if (and line column (buffer-file-name)) - (progn ;; Get to the proper line & column in the file - (forward-line (1- (- line (line-number-at-pos)))) - (move-to-column column)) - (beginning-of-defun)) - ;; Is HERE inside the sexp being debugged? - (when (or (< here (point)) - (save-excursion - (forward-sexp 1) - (> here (point)))) - (user-error "Point is outside the sexp being debugged")) - ;; Move forward until start of sexp. - (comment-normalize-vars) - (comment-forward (point-max)) - ;; Find the coordinate and send it. - (cider-debug-mode-send-reply - (format "{:response :here, :coord %s :force? %s}" - (cider--debug-find-coordinates-for-point here) - (if force "true" "false")))))) - - -;;; User commands -;;;###autoload -(defun cider-debug-defun-at-point () - "Instrument the \"top-level\" expression at point. -If it is a defn, dispatch the instrumented definition. Otherwise, -immediately evaluate the instrumented expression. - -While debugged code is being evaluated, the user is taken through the -source code and displayed the value of various expressions. At each step, -a number of keys will be prompted to the user." - (interactive) - (cider-eval-defun-at-point 'debug-it)) - -(provide 'cider-debug) -;;; cider-debug.el ends here diff --git a/elpa/cider-20230707.640/cider-doc.el b/elpa/cider-20230707.640/cider-doc.el deleted file mode 100644 index 5120ecc8..00000000 --- a/elpa/cider-20230707.640/cider-doc.el +++ /dev/null @@ -1,540 +0,0 @@ -;;; cider-doc.el --- CIDER documentation functionality -*- lexical-binding: t -*- - -;; Copyright © 2014-2023 Bozhidar Batsov, Jeff Valk and CIDER contributors - -;; Author: Jeff Valk - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Mode for formatting and presenting documentation - -;;; Code: - -(require 'cider-common) -(require 'subr-x) -(require 'cider-util) -(require 'cider-popup) -(require 'cider-client) -(require 'cider-clojuredocs) -(require 'nrepl-dict) -(require 'button) -(require 'easymenu) -(require 'cider-browse-spec) - -;; we defer loading those, as org-table is a big library -(declare-function org-table-map-tables "org-table") -(declare-function org-table-align "org-table") -(declare-function org-table-begin "org-table") -(declare-function org-table-end "org-table") - - -;;; Variables - -(defgroup cider-doc nil - "Documentation for CIDER." - :prefix "cider-doc-" - :group 'cider) - -(defcustom cider-doc-auto-select-buffer t - "Controls whether to auto-select the doc popup buffer." - :type 'boolean - :group 'cider-doc - :package-version '(cider . "0.15.0")) - -(declare-function cider-apropos "cider-apropos") -(declare-function cider-apropos-select "cider-apropos") -(declare-function cider-apropos-documentation "cider-apropos") -(declare-function cider-apropos-documentation-select "cider-apropos") - -(defvar cider-doc-map - (let (cider-doc-map) - (define-prefix-command 'cider-doc-map) - (define-key cider-doc-map (kbd "a") #'cider-apropos) - (define-key cider-doc-map (kbd "C-a") #'cider-apropos) - (define-key cider-doc-map (kbd "s") #'cider-apropos-select) - (define-key cider-doc-map (kbd "C-s") #'cider-apropos-select) - (define-key cider-doc-map (kbd "f") #'cider-apropos-documentation) - (define-key cider-doc-map (kbd "C-f") #'cider-apropos-documentation) - (define-key cider-doc-map (kbd "e") #'cider-apropos-documentation-select) - (define-key cider-doc-map (kbd "C-e") #'cider-apropos-documentation-select) - (define-key cider-doc-map (kbd "d") #'cider-doc) - (define-key cider-doc-map (kbd "C-d") #'cider-doc) - (define-key cider-doc-map (kbd "c") #'cider-clojuredocs) - (define-key cider-doc-map (kbd "C-c") #'cider-clojuredocs) - (define-key cider-doc-map (kbd "w") #'cider-clojuredocs-web) - (define-key cider-doc-map (kbd "C-w") #'cider-clojuredocs-web) - (define-key cider-doc-map (kbd "j") #'cider-javadoc) - (define-key cider-doc-map (kbd "C-j") #'cider-javadoc) - cider-doc-map) - "CIDER documentation keymap.") - -(defconst cider-doc-menu - '("Documentation" - ["CiderDoc" cider-doc] - ["JavaDoc in browser" cider-javadoc] - "--" - ["Clojuredocs" cider-clojuredocs] - ["Clojuredocs in browser" cider-clojuredocs-web] - ["Refresh ClojureDocs cache" cider-clojuredocs-refresh-cache] - "--" - ["Search symbols" cider-apropos] - ["Search symbols & select" cider-apropos-select] - ["Search documentation" cider-apropos-documentation] - ["Search documentation & select" cider-apropos-documentation-select] - "--" - ["Configure Doc buffer" (customize-group 'cider-docview-mode)]) - "CIDER documentation submenu.") - - -;;; cider-docview-mode - -(defgroup cider-docview-mode nil - "Formatting/fontifying documentation viewer." - :prefix "cider-docview-" - :group 'cider) - -(defcustom cider-docview-fill-column fill-column - "Fill column for docstrings in doc buffer." - :type 'list - :group 'cider-docview-mode - :package-version '(cider . "0.7.0")) - - -;; Faces - -(defface cider-docview-emphasis-face - '((t (:inherit default :underline t))) - "Face for emphasized text." - :group 'cider-docview-mode - :package-version '(cider . "0.7.0")) - -(defface cider-docview-strong-face - '((t (:inherit default :underline t :weight bold))) - "Face for strongly emphasized text." - :group 'cider-docview-mode - :package-version '(cider . "0.7.0")) - -(defface cider-docview-literal-face - '((t (:inherit font-lock-string-face))) - "Face for literal text." - :group 'cider-docview-mode - :package-version '(cider . "0.7.0")) - -(defface cider-docview-table-border-face - '((t (:inherit shadow))) - "Face for table borders." - :group 'cider-docview-mode - :package-version '(cider . "0.7.0")) - - -;; Colors & Theme Support - -(defvar cider-docview-code-background-color - (cider-scale-background-color) - "Background color for code blocks.") - -(advice-add 'enable-theme :after #'cider--docview-adapt-to-theme) -(advice-add 'disable-theme :after #'cider--docview-adapt-to-theme) -(defun cider--docview-adapt-to-theme (&rest _) - "When theme is changed, update `cider-docview-code-background-color'." - (setq cider-docview-code-background-color (cider-scale-background-color))) - -;; Mode & key bindings - -(defvar cider-docview-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "q" #'cider-popup-buffer-quit-function) - (define-key map "g" #'cider-docview-clojuredocs) - (define-key map "G" #'cider-docview-clojuredocs-web) - (define-key map "j" #'cider-docview-javadoc) - (define-key map "s" #'cider-docview-source) - (define-key map (kbd "") #'backward-button) - (define-key map (kbd "TAB") #'forward-button) - (easy-menu-define cider-docview-mode-menu map - "Menu for CIDER's doc mode" - `("CiderDoc" - ["Look up in Clojuredocs" cider-docview-clojuredocs] - ["Look up in Clojuredocs (browser)" cider-docview-clojuredocs-web] - ["JavaDoc in browser" cider-docview-javadoc] - ["Jump to source" cider-docview-source] - "--" - ["Quit" cider-popup-buffer-quit-function] - )) - map)) - -(defvar cider-docview-symbol) -(defvar cider-docview-javadoc-url) -(defvar cider-docview-file) -(defvar cider-docview-line) - -(define-derived-mode cider-docview-mode help-mode "Doc" - "Major mode for displaying CIDER documentation. - -\\{cider-docview-mode-map}" - (setq buffer-read-only t) - (setq-local sesman-system 'CIDER) - (when cider-special-mode-truncate-lines - (setq-local truncate-lines t)) - (setq-local electric-indent-chars nil) - (setq-local cider-docview-symbol nil) - (setq-local cider-docview-javadoc-url nil) - (setq-local cider-docview-file nil) - (setq-local cider-docview-line nil)) - - -;;; Interactive functions - -(defun cider-docview-javadoc () - "Open the Javadoc for the current class, if available." - (interactive) - (if cider-docview-javadoc-url - (browse-url cider-docview-javadoc-url) - (error "No Javadoc available for %s" cider-docview-symbol))) - -(defun cider-javadoc-handler (symbol-name) - "Invoke the nREPL \"info\" op on SYMBOL-NAME if available." - (when symbol-name - (let* ((info (cider-var-info symbol-name)) - (url (nrepl-dict-get info "javadoc"))) - (if url - (browse-url url) - (user-error "No Javadoc available for %s" symbol-name))))) - -(defun cider-javadoc (arg) - "Open Javadoc documentation in a popup buffer. - -Prompts for the symbol to use, or uses the symbol at point, depending on -the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the -opposite of what that option dictates." - (interactive "P") - (cider-ensure-connected) - (cider-ensure-op-supported "info") - (funcall (cider-prompt-for-symbol-function arg) - "Javadoc for" - #'cider-javadoc-handler)) - -(defun cider-docview-source () - "Open the source for the current symbol, if available." - (interactive) - (if cider-docview-file - (if-let* ((buffer (and (not (cider--tooling-file-p cider-docview-file)) - (cider-find-file cider-docview-file)))) - (cider-jump-to buffer (if cider-docview-line - (cons cider-docview-line nil) - cider-docview-symbol) - nil) - (user-error - (substitute-command-keys - "Can't find the source because it wasn't defined with `cider-eval-buffer'"))) - (error "No source location for %s" cider-docview-symbol))) - -(defvar cider-buffer-ns) - -(declare-function cider-clojuredocs-lookup "cider-clojuredocs") - -(defun cider-docview-clojuredocs () - "Return the clojuredocs documentation for `cider-docview-symbol'." - (interactive) - (if cider-buffer-ns - (cider-clojuredocs-lookup cider-docview-symbol) - (error "%s cannot be looked up on ClojureDocs" cider-docview-symbol))) - -(declare-function cider-clojuredocs-web-lookup "cider-clojuredocs") - -(defun cider-docview-clojuredocs-web () - "Open the clojuredocs documentation for `cider-docview-symbol' in a web browser." - (interactive) - (if cider-buffer-ns - (cider-clojuredocs-web-lookup cider-docview-symbol) - (error "%s cannot be looked up on ClojureDocs" cider-docview-symbol))) - -(defconst cider-doc-buffer "*cider-doc*") - -(defun cider-create-doc-buffer (symbol) - "Populates *cider-doc* with the documentation for SYMBOL." - (when-let* ((info (cider-var-info symbol))) - (cider-docview-render (cider-make-popup-buffer cider-doc-buffer nil 'ancillary) symbol info))) - -(defun cider-doc-lookup (symbol) - "Look up documentation for SYMBOL." - (if-let* ((buffer (cider-create-doc-buffer symbol))) - (cider-popup-buffer-display buffer cider-doc-auto-select-buffer) - (user-error "Symbol %s not resolved" symbol))) - -(defun cider-doc (&optional arg) - "Open Clojure documentation in a popup buffer. - -Prompts for the symbol to use, or uses the symbol at point, depending on -the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the -opposite of what that option dictates." - (interactive "P") - (cider-ensure-connected) - (funcall (cider-prompt-for-symbol-function arg) - "Doc for" - #'cider-doc-lookup)) - - -;;; Font Lock and Formatting - -(defun cider-docview-fontify-code-blocks (buffer mode) - "Font lock BUFFER code blocks using MODE and remove markdown characters. -This processes the triple backtick GFM markdown extension. An overlay is used -to shade the background. Blocks are marked to be ignored by other fonification -and line wrap." - (with-current-buffer buffer - (save-excursion - (while (search-forward-regexp "```\n" nil t) - (replace-match "") - (let ((beg (point)) - (bg `(:background ,cider-docview-code-background-color))) - (when (search-forward-regexp "```\n" nil t) - (replace-match "") - (cider-font-lock-region-as mode beg (point)) - (overlay-put (make-overlay beg (point)) 'font-lock-face bg) - (put-text-property beg (point) 'block 'code))))))) - -(defun cider-docview-fontify-literals (buffer) - "Font lock BUFFER literal text and remove backtick markdown characters. -Preformatted code text blocks are ignored." - (with-current-buffer buffer - (save-excursion - (while (search-forward "`" nil t) - (if (eq (get-text-property (point) 'block) 'code) - (forward-char) - (progn - (replace-match "") - (let ((beg (point))) - (when (search-forward "`" (line-end-position) t) - (replace-match "") - (put-text-property beg (point) 'font-lock-face 'cider-docview-literal-face))))))))) - -(defun cider-docview-fontify-emphasis (buffer) - "Font lock BUFFER emphasized text and remove markdown characters. -One '*' represents emphasis, multiple '**'s represent strong emphasis. -Preformatted code text blocks are ignored." - (with-current-buffer buffer - (save-excursion - (while (search-forward-regexp "\\(*+\\)\\(\\w\\)" nil t) - (if (eq (get-text-property (point) 'block) 'code) - (forward-char) - (progn - (replace-match "\\2") - (let ((beg (1- (point))) - (face (if (> (length (match-string 1)) 1) - 'cider-docview-strong-face - 'cider-docview-emphasis-face))) - (when (search-forward-regexp "\\(\\w\\)\\*+" (line-end-position) t) - (replace-match "\\1") - (put-text-property beg (point) 'font-lock-face face))))))))) - -(defun cider-docview-format-tables (buffer) - "Align BUFFER tables and dim borders. -This processes the GFM table markdown extension using `org-table'. -Tables are marked to be ignored by line wrap." - (require 'org-table) - (with-current-buffer buffer - (save-excursion - (let ((border 'cider-docview-table-border-face)) - (org-table-map-tables - (lambda () - (org-table-align) - (goto-char (org-table-begin)) - (while (search-forward-regexp "[+|-]" (org-table-end) t) - (put-text-property (match-beginning 0) (match-end 0) 'font-lock-face border)) - (put-text-property (org-table-begin) (org-table-end) 'block 'table))))))) - -(defun cider-docview-wrap-text (buffer) - "For text in BUFFER not propertized as 'block', apply line wrap." - (with-current-buffer buffer - (save-excursion - (while (not (eobp)) - (unless (get-text-property (point) 'block) - (fill-region (point) (line-end-position))) - (forward-line))))) - - -;;; Rendering - -(defun cider-docview-render-java-doc (buffer text) - "Emit into BUFFER formatted doc TEXT for a Java class or member." - (with-current-buffer buffer - (let ((beg (point))) - (insert text) - (save-excursion - (goto-char beg) - (cider-docview-fontify-code-blocks buffer 'java-mode) ; left alone hereafter - (cider-docview-fontify-literals buffer) - (cider-docview-fontify-emphasis buffer) - (cider-docview-format-tables buffer) ; may contain literals, emphasis - (cider-docview-wrap-text buffer))))) ; ignores code, table blocks - -(defun cider--abbreviate-file-protocol (file-with-protocol) - "Abbreviate the file-path in `file:/path/to/file' of FILE-WITH-PROTOCOL." - (if (string-match "\\`file:\\(.*\\)" file-with-protocol) - (let ((file (match-string 1 file-with-protocol)) - (proj-dir (clojure-project-dir))) - (if (and proj-dir - (file-in-directory-p file proj-dir)) - (file-relative-name file proj-dir) - file)) - file-with-protocol)) - -(defun cider-docview-render-info (buffer info) - "Emit into BUFFER formatted INFO for the Clojure or Java symbol." - (let* ((ns (nrepl-dict-get info "ns")) - (name (nrepl-dict-get info "name")) - (added (nrepl-dict-get info "added")) - (depr (nrepl-dict-get info "deprecated")) - (macro (nrepl-dict-get info "macro")) - (special (nrepl-dict-get info "special-form")) - (builtin (nrepl-dict-get info "built-in")) ;; babashka specific - (forms (when-let* ((str (nrepl-dict-get info "forms-str"))) - (split-string str "\n"))) - (args (when-let* ((str (nrepl-dict-get info "arglists-str"))) - (split-string str "\n"))) - (doc (or (nrepl-dict-get info "doc") - "Not documented.")) - (url (nrepl-dict-get info "url")) - (class (nrepl-dict-get info "class")) - (member (nrepl-dict-get info "member")) - (javadoc (nrepl-dict-get info "javadoc")) - (super (nrepl-dict-get info "super")) - (ifaces (nrepl-dict-get info "interfaces")) - (spec (nrepl-dict-get info "spec")) - (clj-name (if ns (concat ns "/" name) name)) - (java-name (if member (concat class "/" member) class)) - (see-also (nrepl-dict-get info "see-also"))) - (cider--help-setup-xref (list #'cider-doc-lookup (format "%s/%s" ns name)) nil buffer) - (with-current-buffer buffer - (cl-flet ((emit (text &optional face) - (insert (if face - (propertize text 'font-lock-face face) - text) - "\n"))) - (emit (if class java-name clj-name) 'font-lock-function-name-face) - (when super - (emit (concat " Extends: " (cider-font-lock-as 'java-mode super)))) - (when ifaces - (emit (concat "Implements: " (cider-font-lock-as 'java-mode (car ifaces)))) - (dolist (iface (cdr ifaces)) - (emit (concat " "(cider-font-lock-as 'java-mode iface))))) - (when (or super ifaces) - (insert "\n")) - (when-let* ((forms (or forms args))) - (dolist (form forms) - (insert " ") - (emit (cider-font-lock-as-clojure form)))) - (when special - (emit "Special Form" 'font-lock-keyword-face)) - (when macro - (emit "Macro" 'font-lock-variable-name-face)) - (when builtin - (emit "Built-in" 'font-lock-keyword-face)) - (when added - (emit (concat "Added in " added) 'font-lock-comment-face)) - (when depr - (emit (concat "Deprecated in " depr) 'font-lock-keyword-face)) - (if class - (cider-docview-render-java-doc (current-buffer) doc) - (emit (concat " " doc))) - (when url - (insert "\n Please see ") - (insert-text-button url - 'url url - 'follow-link t - 'action (lambda (x) - (browse-url (button-get x 'url)))) - (insert "\n")) - (when javadoc - (insert "\n\nFor additional documentation, see the ") - (insert-text-button "Javadoc" - 'url javadoc - 'follow-link t - 'action (lambda (x) - (browse-url (button-get x 'url)))) - (insert ".\n")) - (insert "\n") - (when spec - (emit "Spec:" 'font-lock-function-name-face) - (insert (cider-browse-spec--pprint-indented spec)) - (insert "\n\n") - (insert-text-button "Browse spec" - 'follow-link t - 'action (lambda (_) - (cider-browse-spec (format "%s/%s" ns name)))) - (insert "\n\n")) - (if (and cider-docview-file (not (string= cider-docview-file ""))) - (progn - (insert (propertize (if class java-name clj-name) - 'font-lock-face 'font-lock-function-name-face) - " is defined in ") - (insert-text-button (cider--abbreviate-file-protocol cider-docview-file) - 'follow-link t - 'action (lambda (_x) - (cider-docview-source))) - (insert ".")) - (insert "Definition location unavailable.")) - (when see-also - (insert "\n\n Also see: ") - (mapc (lambda (ns-sym) - (let* ((ns-sym-split (split-string ns-sym "/")) - (see-also-ns (car ns-sym-split)) - (see-also-sym (cadr ns-sym-split)) - ;; if the var belongs to the same namespace, - ;; we omit the namespace to save some screen space - (symbol (if (equal ns see-also-ns) see-also-sym ns-sym))) - (insert-text-button symbol - 'type 'help-xref - 'help-function (apply-partially #'cider-doc-lookup symbol))) - (insert " ")) - see-also)) - (cider--doc-make-xrefs) - (let ((beg (point-min)) - (end (point-max))) - (nrepl-dict-map (lambda (k v) - (put-text-property beg end k v)) - info))) - (current-buffer)))) - -(declare-function cider-set-buffer-ns "cider-mode") -(defun cider-docview-render (buffer symbol info) - "Emit into BUFFER formatted documentation for SYMBOL's INFO." - (with-current-buffer buffer - (let ((javadoc (nrepl-dict-get info "javadoc")) - (file (nrepl-dict-get info "file")) - (line (nrepl-dict-get info "line")) - (ns (nrepl-dict-get info "ns")) - (inhibit-read-only t)) - (cider-docview-mode) - - (cider-set-buffer-ns ns) - (setq-local cider-docview-symbol symbol) - (setq-local cider-docview-javadoc-url javadoc) - (setq-local cider-docview-file file) - (setq-local cider-docview-line line) - - (remove-overlays) - (cider-docview-render-info buffer info) - - (goto-char (point-min)) - (current-buffer)))) - - -(provide 'cider-doc) - -;;; cider-doc.el ends here diff --git a/elpa/cider-20230707.640/cider-eldoc.el b/elpa/cider-20230707.640/cider-eldoc.el deleted file mode 100644 index 0a43203b..00000000 --- a/elpa/cider-20230707.640/cider-eldoc.el +++ /dev/null @@ -1,509 +0,0 @@ -;;; cider-eldoc.el --- eldoc support for Clojure -*- lexical-binding: t -*- - -;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Tim King -;; Phil Hagelberg -;; Bozhidar Batsov -;; Artur Malabarba -;; Hugo Duncan -;; Steve Purcell - -;; 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 . - -;; 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 - "Max 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-eldoc-format-special-form (thing pos eldoc-info) - "Return the formatted eldoc string for a special-form. -THING is the special form's name. POS is the argument index of the -special-form's arglists. ELDOC-INFO is a p-list containing the eldoc -information." - (let* ((ns (lax-plist-get eldoc-info "ns")) - (special-form-symbol (lax-plist-get eldoc-info "symbol")) - (arglists (mapcar (lambda (arglist) - (if (equal (car arglist) special-form-symbol) - (cdr arglist) - arglist)) - (lax-plist-get eldoc-info "arglists")))) - (format "%s: %s" - (cider-eldoc-format-thing ns special-form-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))) - (clojure-backward-logical-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." - (or (pcase (lax-plist-get eldoc-info "type") - ("function" 'fn) - ("special-form" 'special-form) - ("macro" 'macro) - ("method" 'method) - ("variable" 'var)) - 'fn)) - -(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-point' 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 - (cond - ((eq (cider-eldoc-thing-type eldoc-info) 'var) - (cider-eldoc-format-variable thing eldoc-info)) - ((eq (cider-eldoc-thing-type eldoc-info) 'special-form) - (cider-eldoc-format-special-form thing pos eldoc-info)) - (t (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 diff --git a/elpa/cider-20230707.640/cider-eval.el b/elpa/cider-20230707.640/cider-eval.el deleted file mode 100644 index 110505bd..00000000 --- a/elpa/cider-20230707.640/cider-eval.el +++ /dev/null @@ -1,1589 +0,0 @@ -;;; cider-eval.el --- Interactive evaluation (compilation) functionality -*- lexical-binding: t -*- - -;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Tim King -;; Phil Hagelberg -;; Bozhidar Batsov -;; Artur Malabarba -;; Hugo Duncan -;; Steve Purcell -;; Arne Brasseur - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; This file contains CIDER's interactive evaluation (compilation) functionality. -;; Although Clojure doesn't really have the concept of evaluation (only -;; compilation), we're using everywhere in the code the term evaluation for -;; brevity (and to be in line with the naming employed by other similar modes). -;; -;; This files also contains all the logic related to displaying errors and -;; evaluation warnings. -;; -;; Pretty much all of the commands here are meant to be used mostly from -;; `cider-mode', but some of them might make sense in other contexts as well. - -;;; Code: - -(require 'ansi-color) -(require 'cl-lib) -(require 'compile) -(require 'map) -(require 'seq) -(require 'subr-x) - -(require 'clojure-mode) - -(require 'cider-client) -(require 'cider-common) -(require 'cider-jar) -(require 'cider-overlays) -(require 'cider-popup) -(require 'cider-repl) -(require 'cider-stacktrace) -(require 'cider-util) - -(defconst cider-read-eval-buffer "*cider-read-eval*") -(defconst cider-result-buffer "*cider-result*") - -(defcustom cider-show-error-buffer t - "Control the popup behavior of cider stacktraces. -The following values are possible t or 'always, 'except-in-repl, -'only-in-repl. Any other value, including nil, will cause the stacktrace -not to be automatically shown. - -Irrespective of the value of this variable, the `cider-error-buffer' is -always generated in the background. Use `cider-selector' to -navigate to this buffer." - :type '(choice (const :tag "always" t) - (const except-in-repl) - (const only-in-repl) - (const :tag "never" nil)) - :group 'cider) - -(defcustom cider-auto-jump-to-error t - "Control the cursor jump behavior in compilation error buffer. -When non-nil automatically jump to error location during interactive -compilation. When set to 'errors-only, don't jump to warnings. -When set to nil, don't jump at all." - :type '(choice (const :tag "always" t) - (const errors-only) - (const :tag "never" nil)) - :group 'cider - :package-version '(cider . "0.7.0")) - -(defcustom cider-auto-select-error-buffer t - "Controls whether to auto-select the error popup buffer." - :type 'boolean - :group 'cider) - -(defcustom cider-auto-track-ns-form-changes t - "Controls whether to auto-evaluate a source buffer's ns form when changed. -When non-nil CIDER will check for ns form changes before each eval command. -When nil the users are expected to take care of the re-evaluating updated -ns forms manually themselves." - :type 'boolean - :group 'cider - :package-version '(cider . "0.15.0")) - -(defcustom cider-auto-inspect-after-eval t - "Controls whether to auto-update the inspector buffer after eval. -Only applies when the *cider-inspect* buffer is currently visible." - :type 'boolean - :group 'cider - :package-version '(cider . "0.25.0")) - -(defcustom cider-save-file-on-load 'prompt - "Controls whether to prompt to save the file when loading a buffer. -If nil, files are not saved. -If 'prompt, the user is prompted to save the file if it's been modified. -If t, save the file without confirmation." - :type '(choice (const prompt :tag "Prompt to save the file if it's been modified") - (const nil :tag "Don't save the file") - (const t :tag "Save the file without confirmation")) - :group 'cider - :package-version '(cider . "0.6.0")) - -(defcustom cider-file-loaded-hook nil - "List of functions to call when a load file has completed." - :type 'hook - :group 'cider - :package-version '(cider . "0.1.7")) - -(defconst cider-output-buffer "*cider-out*") - -(defcustom cider-interactive-eval-output-destination 'repl-buffer - "The destination for stdout and stderr produced from interactive evaluation." - :type '(choice (const output-buffer) - (const repl-buffer)) - :group 'cider - :package-version '(cider . "0.7.0")) - -(defface cider-error-highlight-face - '((((supports :underline (:style wave))) - (:underline (:style wave :color "red") :inherit unspecified)) - (t (:inherit font-lock-warning-face :underline t))) - "Face used to highlight compilation errors in Clojure buffers." - :group 'cider) - -(defface cider-warning-highlight-face - '((((supports :underline (:style wave))) - (:underline (:style wave :color "yellow") :inherit unspecified)) - (t (:inherit font-lock-warning-face :underline (:color "yellow")))) - "Face used to highlight compilation warnings in Clojure buffers." - :group 'cider) - -(defcustom cider-comment-prefix ";; => " - "The prefix to insert before the first line of commented output." - :type 'string - :group 'cider - :package-version '(cider . "0.16.0")) - -(defcustom cider-comment-continued-prefix ";; " - "The prefix to use on the second and subsequent lines of commented output." - :type 'string - :group 'cider - :package-version '(cider . "0.16.0")) - -(defcustom cider-comment-postfix "" - "The postfix to be appended after the final line of commented output." - :type 'string - :group 'cider - :package-version '(cider . "0.16.0")) - -(defcustom cider-eval-register ?e - "The text register assigned to the most recent evaluation result. -When non-nil, the return value of all CIDER eval commands are -automatically written into this register." - :type '(choice character - (const nil)) - :group 'cider - :package-version '(cider . "1.4.0")) - - -;;; Utilities - -(defun cider--clear-compilation-highlights () - "Remove compilation highlights." - (remove-overlays (point-min) (point-max) 'cider-note-p t)) - -(defun cider-clear-compilation-highlights (&optional arg) - "Remove compilation highlights. -When invoked with a prefix ARG the command doesn't prompt for confirmation." - (interactive "P") - (when (or arg (y-or-n-p "Are you sure you want to clear the compilation highlights? ")) - (cider--clear-compilation-highlights))) - -(defun cider--quit-error-window () - "Buries the `cider-error-buffer' and quits its containing window." - (when-let* ((error-win (get-buffer-window cider-error-buffer))) - (save-excursion - (quit-window nil error-win)))) - - -;;; Sideloader -;; -;; nREPL includes sideloader middleware which provides a Java classloader that -;; is able to dynamically load classes and resources at runtime by interacting -;; with the nREPL client (as opposed to using the classpath of the JVM hosting -;; nREPL server). -;; -;; This performs a similar functionality as the load-file -;; operation, where we can load Clojure namespaces (as source files) or Java -;; classes (as bytecode) by simply requiring or importing them. -;; -;; See https://nrepl.org/nrepl/design/middleware.html#sideloading - -(defcustom cider-sideloader-path nil - "List of directories and jar files to scan for sideloader resources. -When not set the cider-nrepl jar will be added automatically when upgrading -an nREPL connection." - :type 'list - :group 'cider - :package-version '(cider . "1.2.0")) - -(defcustom cider-dynload-cider-nrepl-version nil - "Version of the cider-nrepl jar used for dynamically upgrading a connection. -Defaults to `cider-required-middleware-version'." - :type 'string - :group 'cider - :package-version '(cider . "1.2.0")) - -(defun cider-read-bytes (path) - "Read binary data from PATH. -Return the binary data as unibyte string." - ;; based on f-read-bytes - (with-temp-buffer - (set-buffer-multibyte nil) - (setq buffer-file-coding-system 'binary) - (insert-file-contents-literally path nil) - (buffer-substring-no-properties (point-min) (point-max)))) - -(defun cider-retrieve-resource (dirs name) - "Find a resource NAME in a list DIRS of directories or jar files. -Similar to a classpath lookup. Returns the file contents as a string." - (seq-some - (lambda (path) - (cond - ((file-directory-p path) - (let ((expanded (expand-file-name name path))) - (when (file-exists-p expanded) - (cider-read-bytes expanded)))) - ((and (file-exists-p path) (string-suffix-p ".jar" path)) - (cider-jar-retrieve-resource path name)))) - dirs)) - -(defun cider-provide-file (file) - "Provide FILE in a format suitable for sideloading." - (let ((contents (cider-retrieve-resource cider-sideloader-path file))) - (if contents - (base64-encode-string contents 'no-line-breaks) - ;; if we can't find the file we should return an empty string - (base64-encode-string "")))) - -(defun cider-sideloader-lookup-handler () - "Make a sideloader-lookup handler." - (lambda (response) - (nrepl-dbind-response response (id status type name) - (if status - (when (member "sideloader-lookup" status) - (cider-request:sideloader-provide id type name)))))) - -(defun cider-add-middleware-handler (continue) - "Make a add-middleware handler. -CONTINUE is an optional continuation function." - (lambda (response) - (nrepl-dbind-response response (status unresolved-middleware) ;; id middleware - (when unresolved-middleware - (seq-do - (lambda (mw) - (cider-repl-emit-interactive-stderr - (concat "WARNING: middleware " mw " was not found or failed to load.\n"))) - unresolved-middleware)) - (when (and status (member "done" status) continue) - (funcall continue))))) - -(defun cider-request:sideloader-start (&optional connection tooling) - "Perform the nREPL \"sideloader-start\" op. -If CONNECTION is nil, use `cider-current-repl'. -If TOOLING is truthy then the operation is performed over the tooling -session, rather than the regular session." - (cider-ensure-op-supported "sideloader-start") - (cider-nrepl-send-request `("op" "sideloader-start") - (cider-sideloader-lookup-handler) - connection - tooling)) - -(defun cider-request:sideloader-provide (id type file &optional connection) - "Perform the nREPL \"sideloader-provide\" op for ID, TYPE and FILE. -If CONNECTION is nil, use `cider-current-repl'." - (cider-nrepl-send-request `("id" ,id - "op" "sideloader-provide" - "type" ,type - "name" ,file - "content" ,(cider-provide-file file)) - (cider-sideloader-lookup-handler) - connection)) - -(defun cider-sideloader-start (&optional connection) - "Start nREPL's sideloader. -If CONNECTION is nil, use `cider-current-repl'." - (interactive) - (message "Starting nREPL's sideloader") - (cider-request:sideloader-start connection) - (cider-request:sideloader-start connection 'tooling)) - -(defvar cider-nrepl-middlewares - '("cider.nrepl/wrap-apropos" - "cider.nrepl/wrap-classpath" - "cider.nrepl/wrap-clojuredocs" - "cider.nrepl/wrap-complete" - "cider.nrepl/wrap-content-type" - "cider.nrepl/wrap-debug" - "cider.nrepl/wrap-enlighten" - "cider.nrepl/wrap-format" - "cider.nrepl/wrap-info" - "cider.nrepl/wrap-inspect" - "cider.nrepl/wrap-log" - "cider.nrepl/wrap-macroexpand" - "cider.nrepl/wrap-ns" - "cider.nrepl/wrap-out" - "cider.nrepl/wrap-slurp" - "cider.nrepl/wrap-profile" - "cider.nrepl/wrap-refresh" - "cider.nrepl/wrap-resource" - "cider.nrepl/wrap-spec" - "cider.nrepl/wrap-stacktrace" - "cider.nrepl/wrap-test" - "cider.nrepl/wrap-trace" - "cider.nrepl/wrap-tracker" - "cider.nrepl/wrap-undef" - "cider.nrepl/wrap-version" - "cider.nrepl/wrap-xref")) - -(defun cider-request:add-middleware (middlewares - &optional connection tooling continue) - "Use the nREPL dynamic loader to add MIDDLEWARES to the nREPL session. - -- If CONNECTION is nil, use `cider-current-repl'. -- If TOOLING it truthy, use the tooling session instead of the main session. -- CONTINUE is an optional continuation function, which will be called when the -add-middleware op has finished successfully." - (cider-nrepl-send-request `("op" "add-middleware" - "middleware" ,middlewares) - (cider-add-middleware-handler continue) - connection - tooling)) - -(defun cider-add-cider-nrepl-middlewares (&optional connection) - "Use dynamic loading to add the cider-nrepl middlewares to nREPL. -If CONNECTION is nil, use `cider-current-repl'." - (cider-request:add-middleware - cider-nrepl-middlewares connection nil - (lambda () - ;; When the main session is done adding middleware, then do the tooling - ;; session. At this point all the namespaces have been sideloaded so this - ;; is faster, we don't want these to race to sideload resources. - (cider-request:add-middleware - cider-nrepl-middlewares connection 'tooling - (lambda () - ;; Ask nREPL again what its capabilities are, so we know which new - ;; operations are supported. - (nrepl--init-capabilities (or connection (cider-current-repl)))))))) - -(defvar cider-required-middleware-version) -(defun cider-upgrade-nrepl-connection (&optional connection) - "Sideload cider-nrepl middleware. -If CONNECTION is nil, use `cider-current-repl'." - (interactive) - (when (not cider-sideloader-path) - (setq cider-sideloader-path (list (cider-jar-find-or-fetch - "cider" "cider-nrepl" - (or cider-dynload-cider-nrepl-version - cider-required-middleware-version))))) - (cider-sideloader-start connection) - (cider-add-cider-nrepl-middlewares connection)) - - -;;; Dealing with compilation (evaluation) errors and warnings -(defun cider-find-property (property &optional backward) - "Find the next text region which has the specified PROPERTY. -If BACKWARD is t, then search backward. -Returns the position at which PROPERTY was found, or nil if not found." - (let ((p (if backward - (previous-single-char-property-change (point) property) - (next-single-char-property-change (point) property)))) - (when (and (not (= p (point-min))) (not (= p (point-max)))) - p))) - -(defun cider-jump-to-compilation-error (&optional _arg _reset) - "Jump to the line causing the current compilation error. -_ARG and _RESET are ignored, as there is only ever one compilation error. -They exist for compatibility with `next-error'." - (interactive) - (cl-labels ((goto-next-note-boundary - () - (let ((p (or (cider-find-property 'cider-note-p) - (cider-find-property 'cider-note-p t)))) - (when p - (goto-char p) - (message "%s" (get-char-property p 'cider-note)))))) - ;; if we're already on a compilation error, first jump to the end of - ;; it, so that we find the next error. - (when (get-char-property (point) 'cider-note-p) - (goto-next-note-boundary)) - (goto-next-note-boundary))) - -(defun cider--show-error-buffer-p () - "Return non-nil if the error buffer must be shown on error. -Takes into account both the value of `cider-show-error-buffer' and the -currently selected buffer." - (let* ((selected-buffer (window-buffer (selected-window))) - (replp (with-current-buffer selected-buffer (derived-mode-p 'cider-repl-mode)))) - (memq cider-show-error-buffer - (if replp - '(t always only-in-repl) - '(t always except-in-repl))))) - -(defun cider-new-error-buffer (&optional mode error-types) - "Return an empty error buffer using MODE. - -When deciding whether to display the buffer, takes into account not only -the value of `cider-show-error-buffer' and the currently selected buffer -but also the ERROR-TYPES of the error, which is checked against the -`cider-stacktrace-suppressed-errors' set. - -When deciding whether to select the buffer, takes into account the value of -`cider-auto-select-error-buffer'." - (if (and (cider--show-error-buffer-p) - (not (cider-stacktrace-some-suppressed-errors-p error-types))) - (cider-popup-buffer cider-error-buffer cider-auto-select-error-buffer mode 'ancillary) - (cider-make-popup-buffer cider-error-buffer mode 'ancillary))) - -(defun cider-emit-into-color-buffer (buffer value) - "Emit into color BUFFER the provided VALUE." - (with-current-buffer buffer - (let ((inhibit-read-only t) - (buffer-undo-list t)) - (goto-char (point-max)) - (insert (format "%s" value)) - (ansi-color-apply-on-region (point-min) (point-max))) - (goto-char (point-min)))) - -(defun cider--handle-err-eval-response (response) - "Render eval RESPONSE into a new error buffer. - -Uses the value of the `out' slot in RESPONSE." - (nrepl-dbind-response response (out) - (when out - (let ((error-buffer (cider-new-error-buffer))) - (cider-emit-into-color-buffer error-buffer out) - (with-current-buffer error-buffer - (compilation-minor-mode +1)))))) - -(defun cider-default-err-eval-handler () - "Display the last exception without middleware support." - (cider--handle-err-eval-response - (cider-nrepl-sync-request:eval - "(clojure.stacktrace/print-cause-trace *e)"))) - -(defun cider-default-err-eval-print-handler () - "Display the last exception without middleware support. -When clojure.stracktrace is not present." - (cider--handle-err-eval-response - (cider-nrepl-sync-request:eval - "(println (ex-data *e))"))) - -(defun cider--render-stacktrace-causes (causes &optional error-types) - "If CAUSES is non-nil, render its contents into a new error buffer. -Optional argument ERROR-TYPES contains a list which should determine the -op/situation that originated this error." - (when causes - (let ((error-buffer (cider-new-error-buffer #'cider-stacktrace-mode error-types))) - (cider-stacktrace-render error-buffer (reverse causes) error-types)))) - -(defun cider--handle-stacktrace-response (response causes) - "Handle stacktrace op RESPONSE, aggregating the result into CAUSES. -If RESPONSE contains a cause, cons it onto CAUSES and return that. If -RESPONSE is the final message (i.e. it contains a status), render CAUSES -into a new error buffer." - (nrepl-dbind-response response (class msg status type) - (cond ((and (member "notification" status) causes) - (nrepl-notify msg type)) - (class (cons response causes)) - (status (cider--render-stacktrace-causes causes))))) - -(defun cider-default-err-op-handler () - "Display the last exception, with middleware support." - ;; Causes are returned as a series of messages, which we aggregate in `causes' - (let (causes) - (cider-nrepl-send-request - (thread-last - (map-merge 'list - '(("op" "analyze-last-stacktrace")) - (cider--nrepl-print-request-map fill-column)) - (seq-mapcat #'identity)) - (lambda (response) - ;; While the return value of `cider--handle-stacktrace-response' is not - ;; meaningful for the last message, we do not need the value of `causes' - ;; after it has been handled, so it's fine to set it unconditionally here - (setq causes (cider--handle-stacktrace-response response causes)))))) - -(defun cider-default-err-handler () - "This function determines how the error buffer is shown. -It delegates the actual error content to the eval or op handler." - (cond ((cider-nrepl-op-supported-p "analyze-last-stacktrace") - (cider-default-err-op-handler)) - ((cider-library-present-p "clojure.stacktrace") - (cider-default-err-eval-handler)) - (t (cider-default-err-eval-print-handler)))) - - -;; The format of the error messages emitted by Clojure's compiler changed in -;; Clojure 1.10. That's why we're trying to match error messages to both the -;; old and the new format, by utilizing a combination of two different regular -;; expressions. - -(defconst cider-clojure-1.10-error `(sequence - "Syntax error " - (minimal-match (zero-or-more anything)) - "compiling " - (minimal-match (zero-or-more anything)) - "at (" - (group-n 2 (minimal-match (zero-or-more anything))) - ":" - (group-n 3 (one-or-more digit)) - (optional ":" (group-n 4 (one-or-more digit))) - ").")) - -(defconst cider-clojure-1.9-error `(sequence - (zero-or-more anything) - ", compiling:(" - (group-n 2 (minimal-match (zero-or-more anything))) - ":" - (group-n 3 (one-or-more digit)) - (optional ":" (group-n 4 (one-or-more digit))) - ")")) - -(defconst cider-clojure-warning `(sequence - (minimal-match (zero-or-more anything)) - (group-n 1 "warning") - ", " - (group-n 2 (minimal-match (zero-or-more anything))) - ":" - (group-n 3 (one-or-more digit)) - (optional ":" (group-n 4 (one-or-more digit))) - " - ")) - - -(defconst cider-clojure-compilation-regexp - (eval - `(rx bol (or ,cider-clojure-1.9-error - ,cider-clojure-warning - ,cider-clojure-1.10-error)) - t)) - - -(defvar cider-compilation-regexp - (list cider-clojure-compilation-regexp 2 3 4 '(1)) - "Specifications for matching errors and warnings in Clojure stacktraces. -See `compilation-error-regexp-alist' for help on their format.") - -(add-to-list 'compilation-error-regexp-alist-alist - (cons 'cider cider-compilation-regexp)) -(add-to-list 'compilation-error-regexp-alist 'cider) - -(defun cider-extract-error-info (regexp message) - "Extract error information with REGEXP against MESSAGE." - (let ((file (nth 1 regexp)) - (line (nth 2 regexp)) - (col (nth 3 regexp)) - (type (nth 4 regexp)) - (pat (car regexp))) - (when (string-match pat message) - ;; special processing for type (1.2) style - (setq type (if (consp type) - (or (and (car type) (match-end (car type)) 1) - (and (cdr type) (match-end (cdr type)) 0) - 2))) - (list - (when file - (let ((val (match-string-no-properties file message))) - (unless (string= val "NO_SOURCE_PATH") val))) - (when line (string-to-number (match-string-no-properties line message))) - (when col - (let ((val (match-string-no-properties col message))) - (when (and val (not (string-blank-p val))) (string-to-number val)))) - (aref [cider-warning-highlight-face - cider-warning-highlight-face - cider-error-highlight-face] - (or type 2)) - message)))) - -(defun cider--goto-expression-start () - "Go to the beginning a list, vector, map or set outside of a string. -We do so by starting and the current position and proceeding backwards -until we find a delimiters that's not inside a string." - (if (and (looking-back "[])}]" (line-beginning-position)) - (null (nth 3 (syntax-ppss)))) - (backward-sexp) - (while (or (not (looking-at-p "[({[]")) - (nth 3 (syntax-ppss))) - (backward-char)))) - -(defun cider--find-last-error-location (message) - "Return the location (begin end buffer) from the Clojure error MESSAGE. -If location could not be found, return nil." - (save-excursion - (let ((info (cider-extract-error-info cider-compilation-regexp message))) - (when info - (let ((file (nth 0 info)) - (line (nth 1 info)) - (col (nth 2 info))) - (unless (or (not (stringp file)) - (cider--tooling-file-p file)) - (when-let* ((buffer (cider-find-file file))) - (with-current-buffer buffer - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (forward-line (1- line)) - (move-to-column (or col 0)) - (let ((begin (progn (if col (cider--goto-expression-start) (back-to-indentation)) - (point))) - (end (progn (if col (forward-list) (move-end-of-line nil)) - (point)))) - (list begin end buffer)))))))))))) - -(defun cider-handle-compilation-errors (message eval-buffer) - "Highlight and jump to compilation error extracted from MESSAGE. -EVAL-BUFFER is the buffer that was current during user's interactive -evaluation command. Honor `cider-auto-jump-to-error'." - (when-let* ((loc (cider--find-last-error-location message)) - (overlay (make-overlay (nth 0 loc) (nth 1 loc) (nth 2 loc))) - (info (cider-extract-error-info cider-compilation-regexp message))) - (let* ((face (nth 3 info)) - (note (nth 4 info)) - (auto-jump (if (eq cider-auto-jump-to-error 'errors-only) - (not (or (eq face 'cider-warning-highlight-face) - (string-match-p "warning" note))) - cider-auto-jump-to-error))) - (overlay-put overlay 'cider-note-p t) - (overlay-put overlay 'font-lock-face face) - (overlay-put overlay 'cider-note note) - (overlay-put overlay 'help-echo note) - (overlay-put overlay 'modification-hooks - (list (lambda (o &rest _args) (delete-overlay o)))) - (when auto-jump - (with-current-buffer eval-buffer - (push-mark) - ;; At this stage selected window commonly is *cider-error* and we need to - ;; re-select the original user window. If eval-buffer is not - ;; visible it was probably covered as a result of a small screen or user - ;; configuration (https://github.com/clojure-emacs/cider/issues/847). In - ;; that case we don't jump at all in order to avoid covering *cider-error* - ;; buffer. - (when-let* ((win (get-buffer-window eval-buffer))) - (with-selected-window win - (cider-jump-to (nth 2 loc) (car loc))))))))) - - -;;; Interactive evaluation handlers -(defun cider-insert-eval-handler (&optional buffer) - "Make an nREPL evaluation handler for the BUFFER. -The handler simply inserts the result value in BUFFER." - (let ((eval-buffer (current-buffer)) - (res "")) - (nrepl-make-response-handler (or buffer eval-buffer) - (lambda (_buffer value) - (with-current-buffer buffer - (insert value)) - (when cider-eval-register - (setq res (concat res value)))) - (lambda (_buffer out) - (cider-repl-emit-interactive-stdout out)) - (lambda (_buffer err) - (cider-handle-compilation-errors err eval-buffer)) - (lambda (_buffer) - (when cider-eval-register - (set-register cider-eval-register res)))))) - -(defun cider--emit-interactive-eval-output (output repl-emit-function) - "Emit output resulting from interactive code evaluation. -The OUTPUT can be sent to either a dedicated output buffer or the current -REPL buffer. This is controlled by `cider-interactive-eval-output-destination'. -REPL-EMIT-FUNCTION emits the OUTPUT." - (pcase cider-interactive-eval-output-destination - (`output-buffer (let ((output-buffer (or (get-buffer cider-output-buffer) - (cider-popup-buffer cider-output-buffer t)))) - (cider-emit-into-popup-buffer output-buffer output) - (pop-to-buffer output-buffer))) - (`repl-buffer (funcall repl-emit-function output)) - (_ (error "Unsupported value %s for `cider-interactive-eval-output-destination'" - cider-interactive-eval-output-destination)))) - -(defun cider-emit-interactive-eval-output (output) - "Emit OUTPUT resulting from interactive code evaluation. -The output can be send to either a dedicated output buffer or the current -REPL buffer. This is controlled via -`cider-interactive-eval-output-destination'." - (cider--emit-interactive-eval-output output 'cider-repl-emit-interactive-stdout)) - -(defun cider-emit-interactive-eval-err-output (output) - "Emit err OUTPUT resulting from interactive code evaluation. -The output can be send to either a dedicated output buffer or the current -REPL buffer. This is controlled via -`cider-interactive-eval-output-destination'." - (cider--emit-interactive-eval-output output 'cider-repl-emit-interactive-stderr)) - -(defun cider--make-fringe-overlays-for-region (beg end) - "Place eval indicators on all sexps between BEG and END." - (with-current-buffer (if (markerp end) - (marker-buffer end) - (current-buffer)) - (save-excursion - (goto-char beg) - (remove-overlays beg end 'category 'cider-fringe-indicator) - (condition-case nil - (while (progn (clojure-forward-logical-sexp) - (and (<= (point) end) - (not (eobp)))) - (cider--make-fringe-overlay (point))) - (scan-error nil))))) - -(declare-function cider-inspect-last-result "cider-inspector") -(defun cider-interactive-eval-handler (&optional buffer place) - "Make an interactive eval handler for BUFFER. -PLACE is used to display the evaluation result. -If non-nil, it can be the position where the evaluated sexp ends, -or it can be a list with (START END) of the evaluated region. -Update the cider-inspector buffer with the evaluation result -when `cider-auto-inspect-after-eval' is non-nil." - - (let* ((eval-buffer (current-buffer)) - (beg (car-safe place)) - (end (or (car-safe (cdr-safe place)) place)) - (beg (when beg (copy-marker beg))) - (end (when end (copy-marker end))) - (fringed nil) - (res "")) - (nrepl-make-response-handler (or buffer eval-buffer) - (lambda (_buffer value) - (setq res (concat res value)) - (cider--display-interactive-eval-result res end)) - (lambda (_buffer out) - (cider-emit-interactive-eval-output out)) - (lambda (_buffer err) - (cider-emit-interactive-eval-err-output err) - - (when (or (not cider-show-error-buffer) - (not (cider-connection-has-capability-p 'jvm-compilation-errors))) - - ;; Display errors as temporary overlays - (let ((cider-result-use-clojure-font-lock nil)) - (cider--display-interactive-eval-result - err end 'cider-error-overlay-face))) - (cider-handle-compilation-errors err eval-buffer)) - (lambda (buffer) - (if beg - (unless fringed - (cider--make-fringe-overlays-for-region beg end) - (setq fringed t)) - (cider--make-fringe-overlay end)) - (when (and cider-auto-inspect-after-eval - (boundp 'cider-inspector-buffer) - (windowp (get-buffer-window cider-inspector-buffer 'visible))) - (cider-inspect-last-result) - (select-window (get-buffer-window buffer))) - (when cider-eval-register - (set-register cider-eval-register res)))))) - - -(defun cider-load-file-handler (&optional buffer done-handler) - "Make a load file handler for BUFFER. -Optional argument DONE-HANDLER lambda will be run once load is complete." - (let ((eval-buffer (current-buffer)) - (res "")) - (nrepl-make-response-handler (or buffer eval-buffer) - (lambda (buffer value) - (cider--display-interactive-eval-result value) - (when cider-eval-register - (setq res (concat res value))) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (cider--make-fringe-overlays-for-region (point-min) (point-max)) - (run-hooks 'cider-file-loaded-hook)))) - (lambda (_buffer value) - (cider-emit-interactive-eval-output value)) - (lambda (_buffer err) - (cider-emit-interactive-eval-err-output err) - (cider-handle-compilation-errors err eval-buffer)) - (lambda (buffer) - (when cider-eval-register - (set-register cider-eval-register res)) - (when done-handler - (funcall done-handler buffer))) - (lambda () - (funcall nrepl-err-handler))))) - -(defun cider-eval-print-handler (&optional buffer) - "Make a handler for evaluating and printing result in BUFFER." - ;; NOTE: cider-eval-register behavior is not implemented here for performance reasons. - ;; See https://github.com/clojure-emacs/cider/pull/3162 - (nrepl-make-response-handler (or buffer (current-buffer)) - (lambda (buffer value) - (with-current-buffer buffer - (insert - (if (derived-mode-p 'cider-clojure-interaction-mode) - (format "\n%s\n" value) - value)))) - (lambda (_buffer out) - (cider-emit-interactive-eval-output out)) - (lambda (_buffer err) - (cider-emit-interactive-eval-err-output err)) - ())) - -(defun cider-eval-print-with-comment-handler (buffer location comment-prefix) - "Make a handler for evaluating and printing commented results in BUFFER. -LOCATION is the location marker at which to insert. COMMENT-PREFIX is the -comment prefix to use." - (let ((res "")) - (nrepl-make-response-handler buffer - (lambda (_buffer value) - (setq res (concat res value))) - (lambda (_buffer out) - (cider-emit-interactive-eval-output out)) - (lambda (_buffer err) - (cider-emit-interactive-eval-err-output err)) - (lambda (buffer) - (with-current-buffer buffer - (save-excursion - (goto-char (marker-position location)) - (insert (concat comment-prefix - res "\n")))) - (when cider-eval-register - (set-register cider-eval-register res)))))) - -(defun cider-maybe-insert-multiline-comment (result comment-prefix continued-prefix comment-postfix) - "Insert eval RESULT at current location if RESULT is not empty. -RESULT will be preceded by COMMENT-PREFIX. -CONTINUED-PREFIX is inserted for each additional line of output. -COMMENT-POSTFIX is inserted after final text output." - (unless (string= result "") - (clojure-indent-line) - (let ((lines (split-string result "[\n]+" t)) - (beg (point)) - (col (current-indentation))) - ;; only the first line gets the normal comment-prefix - (insert (concat comment-prefix (pop lines))) - (dolist (elem lines) - (insert (concat "\n" continued-prefix elem))) - (indent-rigidly beg (point) col) - (unless (string= comment-postfix "") - (insert comment-postfix))))) - -(defun cider-eval-pprint-with-multiline-comment-handler (buffer location comment-prefix continued-prefix comment-postfix) - "Make a handler for evaluating and inserting results in BUFFER. -The inserted text is pretty-printed and region will be commented. -LOCATION is the location marker at which to insert. -COMMENT-PREFIX is the comment prefix for the first line of output. -CONTINUED-PREFIX is the comment prefix to use for the remaining lines. -COMMENT-POSTFIX is the text to output after the last line." - (let ((res "")) - (nrepl-make-response-handler - buffer - (lambda (_buffer value) - (setq res (concat res value))) - nil - (lambda (_buffer err) - (setq res (concat res err))) - (lambda (buffer) - (with-current-buffer buffer - (save-excursion - (goto-char (marker-position location)) - ;; edge case: defun at eob - (unless (bolp) (insert "\n")) - (cider-maybe-insert-multiline-comment res comment-prefix continued-prefix comment-postfix))) - (when cider-eval-register - (set-register cider-eval-register res))) - nil - nil - (lambda (_buffer warning) - (setq res (concat res warning)))))) - -(defun cider-popup-eval-handler (&optional buffer) - "Make a handler for printing evaluation results in popup BUFFER. -This is used by pretty-printing commands." - ;; NOTE: cider-eval-register behavior is not implemented here for performance reasons. - ;; See https://github.com/clojure-emacs/cider/pull/3162 - (nrepl-make-response-handler - (or buffer (current-buffer)) - (lambda (buffer value) - (cider-emit-into-popup-buffer buffer (ansi-color-apply value) nil t)) - (lambda (_buffer out) - (cider-emit-interactive-eval-output out)) - (lambda (_buffer err) - (cider-emit-interactive-eval-err-output err)) - nil - nil - nil - (lambda (buffer warning) - (cider-emit-into-popup-buffer buffer warning 'font-lock-warning-face t)))) - - -;;; Interactive valuation commands - -(defvar cider-to-nrepl-filename-function - (with-no-warnings - (lambda (path) - (let ((path* (if (eq system-type 'cygwin) - (cygwin-convert-file-name-to-windows path) - path))) - (or (cider--translate-path-to-nrepl path*) path*)))) - "Function to translate Emacs filenames to nREPL namestrings.") - -(defun cider--prep-interactive-eval (form connection) - "Prepare the environment for an interactive eval of FORM in CONNECTION. -Ensure the current ns declaration has been evaluated (so that the ns -containing FORM exists). Cache ns-form in the current buffer unless FORM is -ns declaration itself. Clear any compilation highlights and kill the error -window." - (cider--clear-compilation-highlights) - (cider--quit-error-window) - (let ((cur-ns-form (cider-ns-form))) - (when (and cur-ns-form - (not (cider-ns-form-p form)) - (cider-repl--ns-form-changed-p cur-ns-form connection)) - (when cider-auto-track-ns-form-changes - ;; The first interactive eval on a file can load a lot of libs. This can - ;; easily lead to more than 10 sec. - (let ((nrepl-sync-request-timeout 30)) - ;; TODO: check for evaluation errors - (cider-nrepl-sync-request:eval cur-ns-form connection))) - ;; cache at the end, in case of errors - (cider-repl--cache-ns-form cur-ns-form connection)))) - -(defvar-local cider-interactive-eval-override nil - "Function to call instead of `cider-interactive-eval'.") - -(defun cider-interactive-eval (form &optional callback bounds additional-params) - "Evaluate FORM and dispatch the response to CALLBACK. -If the code to be evaluated comes from a buffer, it is preferred to use a -nil FORM, and specify the code via the BOUNDS argument instead. - -This function is the main entry point in CIDER's interactive evaluation -API. Most other interactive eval functions should rely on this function. -If CALLBACK is nil use `cider-interactive-eval-handler'. -BOUNDS, if non-nil, is a list of two numbers marking the start and end -positions of FORM in its buffer. -ADDITIONAL-PARAMS is a map to be merged into the request message. - -If `cider-interactive-eval-override' is a function, call it with the same -arguments and only proceed with evaluation if it returns nil." - (let ((form (or form (apply #'buffer-substring-no-properties bounds))) - (start (car-safe bounds)) - (end (car-safe (cdr-safe bounds)))) - (when (and start end) - ;; NOTE: don't use `remove-overlays' as it splits and leaves behind - ;; partial overlays, leading to duplicate eval results in some situations. - (dolist (ov (overlays-in start end)) - (when (eq (overlay-get ov 'cider-temporary) t) - (delete-overlay ov)))) - (unless (and cider-interactive-eval-override - (functionp cider-interactive-eval-override) - (funcall cider-interactive-eval-override form callback bounds)) - (cider-map-repls :auto - (lambda (connection) - (cider--prep-interactive-eval form connection) - (cider-nrepl-request:eval - form - (or callback (cider-interactive-eval-handler nil bounds)) - ;; always eval ns forms in the user namespace - ;; otherwise trying to eval ns form for the first time will produce an error - (if (cider-ns-form-p form) "user" (cider-current-ns)) - (when start (line-number-at-pos start)) - (when start (cider-column-number-at-pos start)) - (seq-mapcat #'identity additional-params) - connection)))))) - -(defun cider-eval-region (start end) - "Evaluate the region between START and END." - (interactive "r") - (cider-interactive-eval nil - nil - (list start end) - (cider--nrepl-pr-request-map))) - -(defun cider-eval-last-sexp (&optional output-to-current-buffer) - "Evaluate the expression preceding point. -If invoked with OUTPUT-TO-CURRENT-BUFFER, print the result in the current -buffer." - (interactive "P") - (cider-interactive-eval nil - (when output-to-current-buffer (cider-eval-print-handler)) - (cider-last-sexp 'bounds) - (cider--nrepl-pr-request-map))) - -(defun cider-eval-last-sexp-and-replace () - "Evaluate the expression preceding point and replace it with its result." - (interactive) - (let ((last-sexp (cider-last-sexp))) - ;; we have to be sure the evaluation won't result in an error - (cider-nrepl-sync-request:eval last-sexp) - ;; seems like the sexp is valid, so we can safely kill it - (let ((opoint (point))) - (clojure-backward-logical-sexp) - (kill-region (point) opoint)) - (cider-interactive-eval last-sexp - (cider-eval-print-handler) - nil - (cider--nrepl-pr-request-map)))) - -(defun cider-eval-list-at-point (&optional output-to-current-buffer) - "Evaluate the list (eg. a function call, surrounded by parens) around point. -If invoked with OUTPUT-TO-CURRENT-BUFFER, output the result to current buffer." - (interactive "P") - (save-excursion - (goto-char (cadr (cider-list-at-point 'bounds))) - (cider-eval-last-sexp output-to-current-buffer))) - -(defun cider-eval-sexp-at-point (&optional output-to-current-buffer) - "Evaluate the expression around point. -If invoked with OUTPUT-TO-CURRENT-BUFFER, output the result to current buffer." - (interactive "P") - (save-excursion - (goto-char (cadr (cider-sexp-at-point 'bounds))) - (cider-eval-last-sexp output-to-current-buffer))) - -(defun cider-tap-last-sexp (&optional output-to-current-buffer) - "Evaluate and tap the expression preceding point. -If invoked with OUTPUT-TO-CURRENT-BUFFER, print the result in the current -buffer." - (interactive "P") - (let ((tapped-form (concat "(clojure.core/doto " (cider-last-sexp) " (clojure.core/tap>))"))) - (cider-interactive-eval tapped-form - (when output-to-current-buffer (cider-eval-print-handler)) - nil - (cider--nrepl-pr-request-map)))) - -(defun cider-tap-sexp-at-point (&optional output-to-current-buffer) - "Evaluate and tap the expression around point. -If invoked with OUTPUT-TO-CURRENT-BUFFER, output the result to current buffer." - (interactive "P") - (save-excursion - (goto-char (cadr (cider-sexp-at-point 'bounds))) - (cider-tap-last-sexp output-to-current-buffer))) - -(defvar-local cider-previous-eval-context nil - "The previous evaluation context if any. -That's set by commands like `cider-eval-last-sexp-in-context'.") - - -(defun cider--guess-eval-context () - "Return context for `cider--eval-in-context'. -This is done by extracting all parent let bindings." - (save-excursion - (let ((res "")) - (condition-case nil - (while t - (backward-up-list) - (when (looking-at (rx "(" (or "when-let" "if-let" "let") (opt "*") - symbol-end (* space) - (group "["))) ;; binding vector - (let ((beg (match-end 1)) - (end (save-excursion - (goto-char (match-beginning 1)) - (forward-sexp 1) - (1- (point))))) - (setq res (concat (buffer-substring-no-properties beg end) ", " res))))) - (scan-error res))))) - -(defun cider--eval-in-context (bounds &optional guess) - "Evaluate code at BOUNDS in user-provided evaluation context. -When GUESS is non-nil, attempt to extract the context from parent let-bindings." - (let* ((code (string-trim-right - (buffer-substring-no-properties (car bounds) (cadr bounds)))) - (eval-context - (minibuffer-with-setup-hook (if guess #'beginning-of-buffer #'ignore) - (read-string "Evaluation context (let-style): " - (if guess (cider--guess-eval-context) - cider-previous-eval-context)))) - (code (concat "(let [" eval-context "]\n " code ")"))) - (setq-local cider-previous-eval-context eval-context) - (cider-interactive-eval code - nil - bounds - (cider--nrepl-pr-request-map)))) - -(defun cider-eval-last-sexp-in-context (guess) - "Evaluate the preceding sexp in user-supplied context. -The context is just a let binding vector (without the brackets). -The context is remembered between command invocations. - -When GUESS is non-nil, or called interactively with \\[universal-argument], -attempt to extract the context from parent let-bindings." - (interactive "P") - (cider--eval-in-context (cider-last-sexp 'bounds) guess)) - -(defun cider-eval-sexp-at-point-in-context (guess) - "Evaluate the sexp around point in user-supplied context. - -The context is just a let binding vector (without the brackets). -The context is remembered between command invocations. - -When GUESS is non-nil, or called interactively with \\[universal-argument], -attempt to extract the context from parent let-bindings." - (interactive "P") - (cider--eval-in-context (cider-sexp-at-point 'bounds) guess)) - -(defun cider-eval-defun-to-comment (&optional insert-before) - "Evaluate the \"top-level\" form and insert result as comment. - -The formatting of the comment is defined in `cider-comment-prefix' -which, by default, is \";; => \" and can be customized. - -With the prefix arg INSERT-BEFORE, insert before the form, otherwise afterwards." - (interactive "P") - (let* ((bounds (cider-defun-at-point 'bounds)) - (insertion-point (nth (if insert-before 0 1) bounds))) - (cider-interactive-eval nil - (cider-eval-print-with-comment-handler - (current-buffer) - (set-marker (make-marker) insertion-point) - cider-comment-prefix) - bounds - (cider--nrepl-pr-request-map)))) - -(defun cider-pprint-form-to-comment (form-fn insert-before) - "Evaluate the form selected by FORM-FN and insert result as comment. -FORM-FN can be either `cider-last-sexp' or `cider-defun-at-point'. - -The formatting of the comment is controlled via three options: - `cider-comment-prefix' \";; => \" - `cider-comment-continued-prefix' \";; \" - `cider-comment-postfix' \"\" - -so that with customization you can optionally wrap the output -in the reader macro \"#_( .. )\", or \"(comment ... )\", or any -other desired formatting. - -If INSERT-BEFORE is non-nil, insert before the form, otherwise afterwards." - (let* ((bounds (funcall form-fn 'bounds)) - (insertion-point (nth (if insert-before 0 1) bounds)) - ;; when insert-before, we need a newline after the output to - ;; avoid commenting the first line of the form - (comment-postfix (concat cider-comment-postfix - (if insert-before "\n" "")))) - (cider-interactive-eval nil - (cider-eval-pprint-with-multiline-comment-handler - (current-buffer) - (set-marker (make-marker) insertion-point) - cider-comment-prefix - cider-comment-continued-prefix - comment-postfix) - bounds - (cider--nrepl-print-request-map fill-column)))) - -(defun cider-pprint-eval-last-sexp-to-comment (&optional insert-before) - "Evaluate the last sexp and insert result as comment. - -The formatting of the comment is controlled via three options: - `cider-comment-prefix' \";; => \" - `cider-comment-continued-prefix' \";; \" - `cider-comment-postfix' \"\" - -so that with customization you can optionally wrap the output -in the reader macro \"#_( .. )\", or \"(comment ... )\", or any -other desired formatting. - -If INSERT-BEFORE is non-nil, insert before the form, otherwise afterwards." - (interactive "P") - (cider-pprint-form-to-comment 'cider-last-sexp insert-before)) - -(defun cider-pprint-eval-defun-to-comment (&optional insert-before) - "Evaluate the \"top-level\" form and insert result as comment. - -The formatting of the comment is controlled via three options: - `cider-comment-prefix' \";; => \" - `cider-comment-continued-prefix' \";; \" - `cider-comment-postfix' \"\" - -so that with customization you can optionally wrap the output -in the reader macro \"#_( .. )\", or \"(comment ... )\", or any -other desired formatting. - -If INSERT-BEFORE is non-nil, insert before the form, otherwise afterwards." - (interactive "P") - (cider-pprint-form-to-comment 'cider-defun-at-point insert-before)) - -(declare-function cider-switch-to-repl-buffer "cider-mode") - -(defun cider-eval-last-sexp-to-repl (&optional prefix) - "Evaluate the expression preceding point and insert its result in the REPL. -If invoked with a PREFIX argument, switch to the REPL buffer." - (interactive "P") - (cider-interactive-eval nil - (cider-insert-eval-handler (cider-current-repl)) - (cider-last-sexp 'bounds) - (cider--nrepl-pr-request-map)) - (when prefix - (cider-switch-to-repl-buffer))) - -(defun cider-pprint-eval-last-sexp-to-repl (&optional prefix) - "Evaluate expr before point and insert its pretty-printed result in the REPL. -If invoked with a PREFIX argument, switch to the REPL buffer." - (interactive "P") - (cider-interactive-eval nil - (cider-insert-eval-handler (cider-current-repl)) - (cider-last-sexp 'bounds) - (cider--nrepl-print-request-map fill-column)) - (when prefix - (cider-switch-to-repl-buffer))) - -(defun cider-eval-print-last-sexp (&optional pretty-print) - "Evaluate the expression preceding point. -Print its value into the current buffer. -With an optional PRETTY-PRINT prefix it pretty-prints the result." - (interactive "P") - (cider-interactive-eval nil - (cider-eval-print-handler) - (cider-last-sexp 'bounds) - (if pretty-print - (cider--nrepl-print-request-map fill-column) - (cider--nrepl-pr-request-map)))) - -(defun cider--pprint-eval-form (form) - "Pretty print FORM in popup buffer." - (let* ((buffer (current-buffer)) - (result-buffer (cider-popup-buffer cider-result-buffer nil 'clojure-mode 'ancillary)) - (handler (cider-popup-eval-handler result-buffer))) - (with-current-buffer buffer - (cider-interactive-eval (when (stringp form) form) - handler - (when (consp form) form) - (cider--nrepl-print-request-map fill-column))))) - -(defun cider-pprint-eval-last-sexp (&optional output-to-current-buffer) - "Evaluate the sexp preceding point and pprint its value. -If invoked with OUTPUT-TO-CURRENT-BUFFER, insert as comment in the current -buffer, else display in a popup buffer." - (interactive "P") - (if output-to-current-buffer - (cider-pprint-eval-last-sexp-to-comment) - (cider--pprint-eval-form (cider-last-sexp 'bounds)))) - -(defun cider--prompt-and-insert-inline-dbg () - "Insert a #dbg button at the current sexp." - (save-excursion - (let ((beg)) - (skip-chars-forward "\r\n[:blank:]") - (unless (looking-at-p "(") - (ignore-errors (backward-up-list))) - (setq beg (point)) - (let* ((cond (cider-read-from-minibuffer "Condition for debugging (leave empty for \"always\"): ")) - (button (propertize (concat "#dbg" - (unless (equal cond "") - (format " ^{:break/when %s}" cond))) - 'font-lock-face 'cider-fragile-button-face))) - (when (> (current-column) 30) - (insert "\n") - (indent-according-to-mode)) - (insert button) - (when (> (current-column) 40) - (insert "\n") - (indent-according-to-mode))) - (make-button beg (point) - 'help-echo "Breakpoint. Reevaluate this form to remove it." - :type 'cider-fragile)))) - -(defun cider-eval-defun-at-point (&optional debug-it) - "Evaluate the current toplevel form, and print result in the minibuffer. -With DEBUG-IT prefix argument, also debug the entire form as with the -command `cider-debug-defun-at-point'." - (interactive "P") - (let ((inline-debug (eq 16 (car-safe debug-it)))) - (when debug-it - (when (derived-mode-p 'clojurescript-mode) - (when (y-or-n-p (concat "The debugger doesn't support ClojureScript yet, and we need help with that." - " \nWould you like to read the Feature Request?")) - (browse-url "https://github.com/clojure-emacs/cider/issues/1416")) - (user-error "The debugger does not support ClojureScript")) - (when inline-debug - (cider--prompt-and-insert-inline-dbg))) - (cider-interactive-eval (when (and debug-it (not inline-debug)) - (concat "#dbg\n" (cider-defun-at-point))) - nil - (cider-defun-at-point 'bounds) - (cider--nrepl-pr-request-map)))) - -(defun cider--insert-closing-delimiters (code) - "Closes all open parenthesized or bracketed expressions of CODE." - (with-temp-buffer - (insert code) - (goto-char (point-max)) - (let ((matching-delimiter nil)) - (while (ignore-errors - (save-excursion - (backward-up-list 1) - (setq matching-delimiter (cdr (syntax-after (point))))) - t) - (insert-char matching-delimiter))) - (buffer-string))) - -(defun cider-eval-defun-up-to-point (&optional output-to-current-buffer) - "Evaluate the current toplevel form up to point. -If invoked with OUTPUT-TO-CURRENT-BUFFER, print the result in the current -buffer. It constructs an expression to eval in the following manner: - -- It find the code between the point and the start of the toplevel expression; -- It balances this bit of code by closing all open expressions; -- It evaluates the resulting code using `cider-interactive-eval'." - (interactive "P") - (let* ((beg-of-defun (save-excursion (beginning-of-defun) (point))) - (code (buffer-substring-no-properties beg-of-defun (point))) - (code (cider--insert-closing-delimiters code))) - (cider-interactive-eval code - (when output-to-current-buffer - (cider-eval-print-handler)) - (list beg-of-defun (point)) - (cider--nrepl-pr-request-map)))) - -(defun cider--matching-delimiter (delimiter) - "Get the matching (opening/closing) delimiter for DELIMITER." - (pcase delimiter - (?\( ?\)) - (?\[ ?\]) - (?\{ ?\}) - (?\) ?\() - (?\] ?\[) - (?\} ?\{))) - -(defun cider-eval-sexp-up-to-point (&optional output-to-current-buffer) - "Evaluate the current sexp form up to point. -If invoked with OUTPUT-TO-CURRENT-BUFFER, print the result in the current -buffer. It constructs an expression to eval in the following manner: - -- It finds the code between the point and the start of the sexp expression; -- It balances this bit of code by closing the expression; -- It evaluates the resulting code using `cider-interactive-eval'." - (interactive "P") - (let* ((beg-of-sexp (save-excursion (up-list) (backward-list) (point))) - (beg-delimiter (save-excursion (up-list) (backward-list) (char-after))) - (beg-set? (save-excursion (up-list) (backward-list) (char-before))) - (code (buffer-substring-no-properties beg-of-sexp (point))) - (code (if (= beg-set? ?#) (concat (list beg-set?) code) code)) - (code (concat code (list (cider--matching-delimiter beg-delimiter))))) - (cider-interactive-eval code - (when output-to-current-buffer - (cider-eval-print-handler)) - (list beg-of-sexp (point)) - (cider--nrepl-pr-request-map)))) - -(defun cider-pprint-eval-defun-at-point (&optional output-to-current-buffer) - "Evaluate the \"top-level\" form at point and pprint its value. -If invoked with OUTPUT-TO-CURRENT-BUFFER, insert as comment in the current -buffer, else display in a popup buffer." - (interactive "P") - (if output-to-current-buffer - (cider-pprint-eval-defun-to-comment) - (cider--pprint-eval-form (cider-defun-at-point 'bounds)))) - -(defun cider-eval-ns-form (&optional undef-all) - "Evaluate the current buffer's namespace form. -When UNDEF-ALL is non-nil, unmap all symbols and aliases first." - (interactive "P") - (when-let ((ns (clojure-find-ns))) - (save-excursion - (goto-char (match-beginning 0)) - (when undef-all - (cider-undef-all ns)) - (cider-eval-defun-at-point)))) - -(defun cider-read-and-eval (&optional value) - "Read a sexp from the minibuffer and output its result to the echo area. -If VALUE is non-nil, it is inserted into the minibuffer as initial input." - (interactive) - (let* ((form (cider-read-from-minibuffer "Clojure Eval: " value)) - (override cider-interactive-eval-override) - (ns-form (if (cider-ns-form-p form) "" (format "(ns %s)" (cider-current-ns))))) - (with-current-buffer (get-buffer-create cider-read-eval-buffer) - (erase-buffer) - (clojure-mode) - (unless (string= "" ns-form) - (insert ns-form "\n\n")) - (insert form) - (let ((cider-interactive-eval-override override)) - (cider-interactive-eval form - nil - nil - (cider--nrepl-pr-request-map)))))) - -(defun cider-read-and-eval-defun-at-point () - "Insert the toplevel form at point in the minibuffer and output its result. -The point is placed next to the function name in the minibuffer to allow -passing arguments." - (interactive) - (let* ((fn-name (cadr (split-string (cider-defun-at-point)))) - (form (format "(%s)" fn-name))) - (cider-read-and-eval (cons form (length form))))) - -(defun cider-kill-last-result () - "Save the last evaluated result into the kill ring." - (interactive) - (kill-new - (nrepl-dict-get (cider-nrepl-sync-request:eval "*1") "value"))) - -(defun cider-undef () - "Undefine a symbol from the current ns." - (interactive) - (cider-ensure-op-supported "undef") - (cider-read-symbol-name - "Undefine symbol: " - (lambda (sym) - (cider-nrepl-send-request - `("op" "undef" - "ns" ,(cider-current-ns) - "sym" ,sym) - (cider-interactive-eval-handler (current-buffer)))))) - -(defun cider-undef-all (&optional ns) - "Undefine all symbols and aliases from the namespace NS." - (interactive) - (cider-ensure-op-supported "undef-all") - (cider-nrepl-send-sync-request - `("op" "undef-all" - "ns" ,(or ns (cider-current-ns))))) - -;; Eval keymaps -(defvar cider-eval-pprint-commands-map - (let ((map (define-prefix-command 'cider-eval-pprint-commands-map))) - ;; single key bindings defined last for display in menu - (define-key map (kbd "e") #'cider-pprint-eval-last-sexp) - (define-key map (kbd "d") #'cider-pprint-eval-defun-at-point) - (define-key map (kbd "c e") #'cider-pprint-eval-last-sexp-to-comment) - (define-key map (kbd "c d") #'cider-pprint-eval-defun-to-comment) - - ;; duplicates with C- for convenience - (define-key map (kbd "C-e") #'cider-pprint-eval-last-sexp) - (define-key map (kbd "C-d") #'cider-pprint-eval-defun-at-point) - (define-key map (kbd "C-c e") #'cider-pprint-eval-last-sexp-to-comment) - (define-key map (kbd "C-c C-e") #'cider-pprint-eval-last-sexp-to-comment) - (define-key map (kbd "C-c d") #'cider-pprint-eval-defun-to-comment) - (define-key map (kbd "C-c C-d") #'cider-pprint-eval-defun-to-comment) - map)) - -(defvar cider-eval-commands-map - (let ((map (define-prefix-command 'cider-eval-commands-map))) - ;; single key bindings defined last for display in menu - (define-key map (kbd "w") #'cider-eval-last-sexp-and-replace) - (define-key map (kbd "r") #'cider-eval-region) - (define-key map (kbd "n") #'cider-eval-ns-form) - (define-key map (kbd "d") #'cider-eval-defun-at-point) - (define-key map (kbd "e") #'cider-eval-last-sexp) - (define-key map (kbd "q") #'cider-tap-last-sexp) - (define-key map (kbd "l") #'cider-eval-list-at-point) - (define-key map (kbd "v") #'cider-eval-sexp-at-point) - (define-key map (kbd "t") #'cider-tap-sexp-at-point) - (define-key map (kbd "o") #'cider-eval-sexp-up-to-point) - (define-key map (kbd ".") #'cider-read-and-eval-defun-at-point) - (define-key map (kbd "z") #'cider-eval-defun-up-to-point) - (define-key map (kbd "c") #'cider-eval-last-sexp-in-context) - (define-key map (kbd "b") #'cider-eval-sexp-at-point-in-context) - (define-key map (kbd "k") #'cider-kill-last-result) - (define-key map (kbd "f") 'cider-eval-pprint-commands-map) - - ;; duplicates with C- for convenience - (define-key map (kbd "C-w") #'cider-eval-last-sexp-and-replace) - (define-key map (kbd "C-r") #'cider-eval-region) - (define-key map (kbd "C-n") #'cider-eval-ns-form) - (define-key map (kbd "C-d") #'cider-eval-defun-at-point) - (define-key map (kbd "C-e") #'cider-eval-last-sexp) - (define-key map (kbd "C-q") #'cider-tap-last-sexp) - (define-key map (kbd "C-l") #'cider-eval-list-at-point) - (define-key map (kbd "C-v") #'cider-eval-sexp-at-point) - (define-key map (kbd "C-t") #'cider-tap-sexp-at-point) - (define-key map (kbd "C-o") #'cider-eval-sexp-up-to-point) - (define-key map (kbd "C-.") #'cider-read-and-eval-defun-at-point) - (define-key map (kbd "C-z") #'cider-eval-defun-up-to-point) - (define-key map (kbd "C-c") #'cider-eval-last-sexp-in-context) - (define-key map (kbd "C-b") #'cider-eval-sexp-at-point-in-context) - (define-key map (kbd "C-k") #'cider-kill-last-result) - (define-key map (kbd "C-f") 'cider-eval-pprint-commands-map) - map)) - -(defun cider--file-string (file) - "Read the contents of a FILE and return as a string." - (with-current-buffer (find-file-noselect file) - (save-restriction - (widen) - (substring-no-properties (buffer-string))))) - -(defun cider-load-buffer (&optional buffer callback undef-all) - "Load (eval) BUFFER's file in nREPL. -If no buffer is provided the command acts on the current buffer. If the -buffer is for a cljc file, and both a Clojure and ClojureScript REPL exists -for the project, it is evaluated in both REPLs. -Optional argument CALLBACK will override the default ‘cider-load-file-handler’. -When UNDEF-ALL is non-nil or called with \\[universal-argument], removes -all ns aliases and var mappings from the namespace before reloading it." - (interactive (list (current-buffer) nil (equal current-prefix-arg '(4)))) - (setq buffer (or buffer (current-buffer))) - ;; When cider-load-buffer or cider-load-file are called in programs the - ;; current context might not match the buffer's context. We use the caller - ;; context instead of the buffer's context because that's the common use - ;; case. For the other use case just let-bind the default-directory. - (let ((orig-default-directory default-directory)) - (with-current-buffer buffer - (check-parens) - (let ((default-directory orig-default-directory)) - (unless buffer-file-name - (user-error "Buffer `%s' is not associated with a file" (current-buffer))) - (when (and cider-save-file-on-load - (buffer-modified-p) - (or (eq cider-save-file-on-load t) - (y-or-n-p (format "Save file %s? " buffer-file-name)))) - (save-buffer)) - (remove-overlays nil nil 'cider-temporary t) - (when undef-all - (cider-undef-all (cider-current-ns))) - (cider--clear-compilation-highlights) - (cider--quit-error-window) - (let ((filename (buffer-file-name buffer)) - (ns-form (cider-ns-form))) - (cider-map-repls :auto - (lambda (repl) - (when ns-form - (cider-repl--cache-ns-form ns-form repl)) - (cider-request:load-file (cider--file-string filename) - (funcall cider-to-nrepl-filename-function - (cider--server-filename filename)) - (file-name-nondirectory filename) - repl - callback))) - (message "Loading %s..." filename)))))) - -(defun cider-load-file (filename &optional undef-all) - "Load (eval) the Clojure file FILENAME in nREPL. -If the file is a cljc file, and both a Clojure and ClojureScript REPL -exists for the project, it is evaluated in both REPLs. The heavy lifting -is done by `cider-load-buffer'. -When UNDEF-ALL is non-nil or called with \\[universal-argument], removes -all ns aliases and var mappings from the namespace before reloading it." - (interactive (list - (read-file-name "Load file: " nil nil nil - (when (buffer-file-name) - (file-name-nondirectory - (buffer-file-name)))) - (equal current-prefix-arg '(4)))) - (if-let* ((buffer (find-buffer-visiting filename))) - (cider-load-buffer buffer nil undef-all) - (cider-load-buffer (find-file-noselect filename) nil undef-all))) - -(defun cider-load-all-files (directory undef-all) - "Load all files in DIRECTORY (recursively). -Useful when the running nREPL on remote host. -When UNDEF-ALL is non-nil or called with \\[universal-argument], removes -all ns aliases and var mappings from the namespaces being reloaded" - (interactive "DLoad files beneath directory: \nP") - (mapcar (lambda (file) (cider-load-file file undef-all)) - (directory-files-recursively directory "\\.clj[cs]?$"))) - -(defalias 'cider-eval-file #'cider-load-file - "A convenience alias as some people are confused by the load-* names.") - -(defalias 'cider-eval-all-files #'cider-load-all-files - "A convenience alias as some people are confused by the load-* names.") - -(defalias 'cider-eval-buffer #'cider-load-buffer - "A convenience alias as some people are confused by the load-* names.") - -(defun cider-load-all-project-ns () - "Load all namespaces in the current project." - (interactive) - (cider-ensure-connected) - (cider-ensure-op-supported "ns-load-all") - (when (y-or-n-p "Are you sure you want to load all namespaces in the project? ") - (message "Loading all project namespaces...") - (let ((loaded-ns-count (length (cider-sync-request:ns-load-all)))) - (message "Loaded %d namespaces" loaded-ns-count)))) - -(provide 'cider-eval) - -;;; cider-eval.el ends here diff --git a/elpa/cider-20230707.640/cider-find.el b/elpa/cider-20230707.640/cider-find.el deleted file mode 100644 index 6e882ae3..00000000 --- a/elpa/cider-20230707.640/cider-find.el +++ /dev/null @@ -1,303 +0,0 @@ -;;; cider-find.el --- Functionality for finding things -*- lexical-binding: t -*- - -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Bozhidar Batsov -;; Artur Malabarba - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; A bunch of commands for finding resources and definitions. - -;;; Code: - -(require 'cider-client) -(require 'cider-common) -(require 'cider-resolve) - -(require 'thingatpt) - -(defun cider--find-var-other-window (var &optional line) - "Find the definition of VAR, optionally at a specific LINE. - -Display the results in a different window." - (if-let* ((info (cider-var-info var))) - (progn - (if line (setq info (nrepl-dict-put info "line" line))) - (cider--jump-to-loc-from-info info t)) - (user-error "Symbol `%s' not resolved" var))) - -(defun cider--find-var (var &optional line) - "Find the definition of VAR, optionally at a specific LINE." - (if-let* ((info (cider-var-info var))) - (progn - (if line (setq info (nrepl-dict-put info "line" line))) - (cider--jump-to-loc-from-info info)) - (user-error "Symbol `%s' not resolved" var))) - -;;;###autoload -(defun cider-find-var (&optional arg var line) - "Find definition for VAR at LINE. -Prompt according to prefix ARG and `cider-prompt-for-symbol'. -A single or double prefix argument inverts the meaning of -`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes -the results to be displayed in a different window. The default value is -thing at point." - (interactive "P") - (if var - (cider--find-var var line) - (funcall (cider-prompt-for-symbol-function arg) - "Symbol" - (if (cider--open-other-window-p arg) - #'cider--find-var-other-window - #'cider--find-var)))) - -;;;###autoload -(defun cider-find-dwim-at-mouse (event) - "Find and display variable or resource at mouse EVENT." - (interactive "e") - (if-let* ((symbol-file (save-excursion - (mouse-set-point event) - (cider-symbol-at-point 'look-back)))) - (cider-find-dwim symbol-file) - (user-error "No variable or resource here"))) - -(defun cider--find-dwim (symbol-file callback &optional other-window) - "Find the SYMBOL-FILE at point. -CALLBACK upon failure to invoke prompt if not prompted previously. -Show results in a different window if OTHER-WINDOW is true." - (if-let* ((info (cider-var-info symbol-file))) - (cider--jump-to-loc-from-info info other-window) - (progn - (cider-ensure-op-supported "resource") - (if-let* ((resource (cider-sync-request:resource symbol-file)) - (buffer (cider-find-file resource))) - (cider-jump-to buffer 0 other-window) - (if (cider--prompt-for-symbol-p current-prefix-arg) - (error "Resource or var %s not resolved" symbol-file) - (let ((current-prefix-arg (if current-prefix-arg nil '(4)))) - (call-interactively callback))))))) - -(defun cider--find-dwim-interactive (prompt) - "Get interactive arguments for jump-to functions using PROMPT as needed." - (if (cider--prompt-for-symbol-p current-prefix-arg) - (list - (cider-read-from-minibuffer prompt (thing-at-point 'filename))) - (list (or (thing-at-point 'filename) "")))) ; No prompt. - -(defun cider-find-dwim-other-window (symbol-file) - "Jump to SYMBOL-FILE at point, place results in other window." - (interactive (cider--find-dwim-interactive "Jump to: ")) - (cider--find-dwim symbol-file 'cider-find-dwim-other-window t)) - -;;;###autoload -(defun cider-find-dwim (symbol-file) - "Find and display the SYMBOL-FILE at point. -SYMBOL-FILE could be a var or a resource. If thing at point is empty then -show Dired on project. If var is not found, try to jump to resource of the -same name. When called interactively, a prompt is given according to the -variable `cider-prompt-for-symbol'. A single or double prefix argument -inverts the meaning. A prefix of `-' or a double prefix argument causes -the results to be displayed in a different window. A default value of thing -at point is given when prompted." - (interactive (cider--find-dwim-interactive "Jump to: ")) - (cider--find-dwim symbol-file `cider-find-dwim - (cider--open-other-window-p current-prefix-arg))) - -;;;###autoload -(defun cider-find-resource (path) - "Find the resource at PATH. -Prompt for input as indicated by the variable `cider-prompt-for-symbol'. -A single or double prefix argument inverts the meaning of -`cider-prompt-for-symbol'. A prefix argument of `-` or a double prefix -argument causes the results to be displayed in other window. The default -value is thing at point." - (interactive - (list - (if (cider--prompt-for-symbol-p current-prefix-arg) - (completing-read "Resource: " - (cider-sync-request:resources-list) - nil nil - (thing-at-point 'filename)) - (or (thing-at-point 'filename) "")))) - (cider-ensure-op-supported "resource") - (when (= (length path) 0) - (error "Cannot find resource for empty path")) - (if-let* ((resource (cider-sync-request:resource path)) - (buffer (cider-find-file resource))) - (cider-jump-to buffer nil (cider--open-other-window-p current-prefix-arg)) - (if (cider--prompt-for-symbol-p current-prefix-arg) - (error "Cannot find resource %s" path) - (let ((current-prefix-arg (cider--invert-prefix-arg current-prefix-arg))) - (call-interactively 'cider-find-resource))))) - -(defun cider--invert-prefix-arg (arg) - "Invert the effect of prefix value ARG on `cider-prompt-for-symbol'. -This function preserves the `other-window' meaning of ARG." - (let ((narg (prefix-numeric-value arg))) - (pcase narg - (16 -1) ; empty empty -> - - (-1 16) ; - -> empty empty - (4 nil) ; empty -> no-prefix - (_ 4)))) ; no-prefix -> empty - -(defun cider--prefix-invert-prompt-p (arg) - "Test prefix value ARG for its effect on `cider-prompt-for-symbol`." - (let ((narg (prefix-numeric-value arg))) - (pcase narg - (16 t) ; empty empty - (4 t) ; empty - (_ nil)))) - -(defun cider--prompt-for-symbol-p (&optional prefix) - "Check if cider should prompt for symbol. -Tests againsts PREFIX and the value of `cider-prompt-for-symbol'. -Invert meaning of `cider-prompt-for-symbol' if PREFIX indicates it should be." - (if (cider--prefix-invert-prompt-p prefix) - (not cider-prompt-for-symbol) cider-prompt-for-symbol)) - -(defun cider--find-ns (ns &optional other-window) - "Find the file containing NS's definition. -Optionally open it in a different window if OTHER-WINDOW is truthy." - (if-let* ((path (cider-sync-request:ns-path ns))) - (cider-jump-to (cider-find-file path) nil other-window) - (user-error "Can't find namespace `%s'" ns))) - -;;;###autoload -(defun cider-find-ns (&optional arg ns) - "Find the file containing NS. -A prefix ARG of `-` or a double prefix argument causes -the results to be displayed in a different window." - (interactive "P") - (cider-ensure-connected) - (cider-ensure-op-supported "ns-path") - (if ns - (cider--find-ns ns) - (let* ((namespaces (cider-sync-request:ns-list)) - (ns (completing-read "Find namespace: " namespaces))) - (cider--find-ns ns (cider--open-other-window-p arg))))) - -;;;###autoload -(defun cider-find-keyword (&optional arg) - "Find the namespace of the keyword at point and its first occurrence there. - -For instance - if the keyword at point is \":cider.demo/keyword\", this command -would find the namespace \"cider.demo\" and afterwards find the first mention -of \"::keyword\" there. - -Prompt according to prefix ARG and `cider-prompt-for-symbol'. -A single or double prefix argument inverts the meaning of -`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes -the results to be displayed in a different window. The default value is -thing at point." - (interactive "P") - (cider-ensure-connected) - (let* ((kw (let ((kw-at-point (cider-symbol-at-point 'look-back))) - (if (or cider-prompt-for-symbol arg) - (read-string - (format "Keyword (default %s): " kw-at-point) - nil nil kw-at-point) - kw-at-point))) - (ns-qualifier (and - (string-match "^:+\\(.+\\)/.+$" kw) - (match-string 1 kw))) - (kw-ns (if ns-qualifier - (cider-resolve-alias (cider-current-ns) ns-qualifier) - (cider-current-ns))) - (kw-to-find (concat "::" (replace-regexp-in-string "^:+\\(.+/\\)?" "" kw)))) - - (when (and ns-qualifier (string= kw-ns (cider-current-ns))) - (error "Could not resolve alias `%s' in `%s'" ns-qualifier (cider-current-ns))) - (cider--find-ns kw-ns arg) - (search-forward-regexp kw-to-find nil 'noerror))) - -;;; xref integration -;; -;; xref.el was introduced in Emacs 25.1. -;; CIDER's xref backend was added in CIDER 1.2. -(defun cider--xref-backend () - "Used for xref integration." - ;; Check if `cider-nrepl` middleware is loaded. Allows fallback to other xref - ;; backends, if cider-nrepl is not loaded. - (when (cider-nrepl-op-supported-p "ns-path" nil 'skip-ensure) - 'cider)) - -(cl-defmethod xref-backend-identifier-at-point ((_backend (eql cider))) - "Return the relevant identifier at point." - (cider-symbol-at-point 'look-back)) - -(defun cider--var-to-xref-location (var) - "Get location of definition of VAR." - (when-let* ((info (cider-var-info var)) - (line (nrepl-dict-get info "line")) - (file (nrepl-dict-get info "file")) - (buf (cider--find-buffer-for-file file))) - (xref-make-buffer-location - buf - (with-current-buffer buf - (save-excursion - (goto-char 0) - (forward-line (1- line)) - (back-to-indentation) - (point)))))) - -(cl-defmethod xref-backend-definitions ((_backend (eql cider)) var) - "Find definitions of VAR." - (cider-ensure-connected) - (cider-ensure-op-supported "ns-path") - (when-let* ((loc (cider--var-to-xref-location var))) - (list (xref-make var loc)))) - -(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql cider))) - "Return the completion table for identifiers." - (cider-ensure-connected) - (when-let* ((ns (cider-current-ns)) - (results (cider-sync-request:ns-vars ns))) - results)) - -(cl-defmethod xref-backend-references ((_backend (eql cider)) var) - "Find references of VAR." - (cider-ensure-connected) - (cider-ensure-op-supported "fn-refs") - (when-let* ((ns (cider-current-ns)) - (results (cider-sync-request:fn-refs ns var))) - (mapcar (lambda (info) - (let* ((filename (nrepl-dict-get info "file")) - (column (nrepl-dict-get info "column")) - (line (nrepl-dict-get info "line")) - (loc (xref-make-file-location filename line column))) - (xref-make filename loc))) - results))) - -(cl-defmethod xref-backend-apropos ((_backend (eql cider)) pattern) - "Find all symbols that match regexp PATTERN." - (cider-ensure-connected) - (cider-ensure-op-supported "apropos") - (when-let* ((ns (cider-current-ns)) - (results (cider-sync-request:apropos pattern ns t t completion-ignore-case))) - (mapcar (lambda (info) - (let* ((symbol (nrepl-dict-get info "name")) - (loc (cider--var-to-xref-location symbol)) - (type (nrepl-dict-get info "type")) - (doc (nrepl-dict-get info "doc"))) - (xref-make (format "[%s] %s\n %s" (propertize symbol 'face 'bold) (capitalize type) doc) - loc))) - results))) - -(provide 'cider-find) -;;; cider-find.el ends here diff --git a/elpa/cider-20230707.640/cider-format.el b/elpa/cider-20230707.640/cider-format.el deleted file mode 100644 index eeb3562c..00000000 --- a/elpa/cider-20230707.640/cider-format.el +++ /dev/null @@ -1,154 +0,0 @@ -;;; cider-format.el --- Code and EDN formatting functionality -*- lexical-binding: t -*- - -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Bozhidar Batsov -;; Artur Malabarba - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Middleware-powered code and EDN formatting functionality. - -;;; Code: - -(require 'map) -(require 'seq) -(require 'subr-x) - -(require 'cider-client) -(require 'cider-util) - - -;; Format - -(defun cider--format-reindent (formatted start) - "Reindent FORMATTED to align with buffer position START." - (let* ((start-column (save-excursion (goto-char start) (current-column))) - (indent-line (concat "\n" (make-string start-column ? )))) - (replace-regexp-in-string "\n" indent-line formatted))) - - -;;; Format region - -(defun cider--format-region (start end formatter) - "Format the contents of the given region. - -START and END represent the region's boundaries. - -FORMATTER is a function of one argument which is used to convert -the string contents of the region into a formatted string. - -Uses the following heuristic to try to maintain point position: - -- Take a snippet of text starting at current position, up to 64 chars. -- Search for the snippet, with lax whitespace, in the formatted text. - - If snippet is less than 64 chars (point was near end of buffer), search - from end instead of beginning. -- Place point at match beginning, or `point-min' if no match." - (let* ((original (buffer-substring-no-properties start end)) - (formatted (funcall formatter original)) - (indented (cider--format-reindent formatted start))) - (unless (equal original indented) - (let* ((pos (point)) - (pos-max (1+ (buffer-size))) - (l 64) - (endp (> (+ pos l) pos-max)) - (snippet (thread-last - (buffer-substring-no-properties - pos (min (+ pos l) pos-max)) - (regexp-quote) - (replace-regexp-in-string "[[:space:]\t\n\r]+" "[[:space:]\t\n\r]*")))) - (delete-region start end) - (insert indented) - (goto-char (if endp (point-max) (point-min))) - (funcall (if endp #'re-search-backward #'re-search-forward) snippet nil t) - (goto-char (or (match-beginning 0) start)) - (when (looking-at-p "\n") (forward-char)))))) - -;;;###autoload -(defun cider-format-region (start end) - "Format the Clojure code in the current region. -START and END represent the region's boundaries." - (interactive "r") - (cider-ensure-connected) - (cider--format-region start end - (lambda (buf) - (cider-sync-request:format-code buf cider-format-code-options)))) - - -;;; Format defun - -;;;###autoload -(defun cider-format-defun () - "Format the code in the current defun." - (interactive) - (cider-ensure-connected) - (let ((defun-bounds (cider-defun-at-point 't))) - (cider-format-region (car defun-bounds) (cadr defun-bounds)))) - - -;;; Format buffer - -(defun cider--format-buffer (formatter) - "Format the contents of the current buffer. - -Uses FORMATTER, a function of one argument, to convert the string contents -of the buffer into a formatted string." - (cider--format-region 1 (1+ (buffer-size)) formatter)) - -;;;###autoload -(defun cider-format-buffer () - "Format the Clojure code in the current buffer." - (interactive) - (check-parens) - (cider-ensure-connected) - (cider--format-buffer (lambda (buf) - (cider-sync-request:format-code buf cider-format-code-options)))) - - -;;; Format EDN - -;;;###autoload -(defun cider-format-edn-buffer () - "Format the EDN data in the current buffer." - (interactive) - (check-parens) - (cider-ensure-connected) - (cider--format-buffer (lambda (edn) - (cider-sync-request:format-edn edn fill-column)))) - -;;;###autoload -(defun cider-format-edn-region (start end) - "Format the EDN data in the current region. -START and END represent the region's boundaries." - (interactive "r") - (cider-ensure-connected) - (let* ((start-column (save-excursion (goto-char start) (current-column))) - (right-margin (- fill-column start-column))) - (cider--format-region start end - (lambda (edn) - (cider-sync-request:format-edn edn right-margin))))) - -;;;###autoload -(defun cider-format-edn-last-sexp () - "Format the EDN data of the last sexp." - (interactive) - (apply #'cider-format-edn-region (cider-sexp-at-point 'bounds))) - -(provide 'cider-format) -;;; cider-format.el ends here diff --git a/elpa/cider-20230707.640/cider-inspector.el b/elpa/cider-20230707.640/cider-inspector.el deleted file mode 100644 index 085e4026..00000000 --- a/elpa/cider-20230707.640/cider-inspector.el +++ /dev/null @@ -1,528 +0,0 @@ -;;; cider-inspector.el --- Object inspector -*- lexical-binding: t -*- - -;; Copyright © 2013-2014 Vital Reactor, LLC -;; Copyright © 2014-2023 Bozhidar Batsov and CIDER contributors - -;; Author: Ian Eslick -;; Bozhidar Batsov - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Clojure object inspector inspired by SLIME. - -;;; Code: - -(require 'cl-lib) -(require 'easymenu) -(require 'seq) -(require 'cider-eval) - -;; =================================== -;; Inspector Key Map and Derived Mode -;; =================================== - -(defconst cider-inspector-buffer "*cider-inspect*") - -;;; Customization -(defgroup cider-inspector nil - "Presentation and behavior of the CIDER value inspector." - :prefix "cider-inspector-" - :group 'cider - :package-version '(cider . "0.10.0")) - -(defcustom cider-inspector-page-size 32 - "Default page size in paginated inspector view. -The page size can be also changed interactively within the inspector." - :type '(integer :tag "Page size" 32) - :package-version '(cider . "0.10.0")) - -(defcustom cider-inspector-max-atom-length 150 - "Default max length of nested atoms before they are truncated. -'Atom' here means any collection member that satisfies (complement coll?). -The max length can be also changed interactively within the inspector." - :type '(integer :tag "Max atom length" 150) - :package-version '(cider . "1.1.0")) - -(defcustom cider-inspector-max-coll-size 5 - "Default number of nested collection members to display before truncating. -The max size can be also changed interactively within the inspector." - :type '(integer :tag "Max collection size" 5) - :package-version '(cider . "1.1.0")) - -(defcustom cider-inspector-fill-frame nil - "Controls whether the CIDER inspector window fills its frame." - :type 'boolean - :package-version '(cider . "0.15.0")) - -(defcustom cider-inspector-skip-uninteresting t - "Controls whether to skip over uninteresting values in the inspector. -Only applies to navigation with `cider-inspector-prev-inspectable-object' -and `cider-inspector-next-inspectable-object', values are still inspectable -by clicking or navigating to them by other means." - :type 'boolean - :package-version '(cider . "0.25.0")) - -(defcustom cider-inspector-auto-select-buffer t - "Determines if the inspector buffer should be auto selected." - :type 'boolean - :package-version '(cider . "0.27.0")) - -(defvar cider-inspector-uninteresting-regexp - (concat "nil" ; nils are not interesting - "\\|:" clojure--sym-regexp ; nor keywords - ;; FIXME: This range also matches ",", is it on purpose? - "\\|[+-.0-9]+") ; nor numbers. Note: BigInts, ratios etc. are interesting - "Regexp of uninteresting and skippable values.") - -(defvar cider-inspector-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map cider-popup-buffer-mode-map) - (define-key map (kbd "RET") #'cider-inspector-operate-on-point) - (define-key map [mouse-1] #'cider-inspector-operate-on-click) - (define-key map "l" #'cider-inspector-pop) - (define-key map "g" #'cider-inspector-refresh) - ;; Page-up/down - (define-key map [next] #'cider-inspector-next-page) - (define-key map [prior] #'cider-inspector-prev-page) - (define-key map " " #'cider-inspector-next-page) - (define-key map (kbd "M-SPC") #'cider-inspector-prev-page) - (define-key map (kbd "S-SPC") #'cider-inspector-prev-page) - (define-key map "s" #'cider-inspector-set-page-size) - (define-key map "a" #'cider-inspector-set-max-atom-length) - (define-key map "c" #'cider-inspector-set-max-coll-size) - (define-key map "d" #'cider-inspector-def-current-val) - (define-key map [tab] #'cider-inspector-next-inspectable-object) - (define-key map "\C-i" #'cider-inspector-next-inspectable-object) - (define-key map "n" #'cider-inspector-next-inspectable-object) - (define-key map [(shift tab)] #'cider-inspector-previous-inspectable-object) - (define-key map "p" #'cider-inspector-previous-inspectable-object) - (define-key map "f" #'forward-char) - (define-key map "b" #'backward-char) - ;; Emacs translates S-TAB to BACKTAB on X. - (define-key map [backtab] #'cider-inspector-previous-inspectable-object) - (easy-menu-define cider-inspector-mode-menu map - "Menu for CIDER's inspector." - `("CIDER Inspector" - ["Inspect" cider-inspector-operate-on-point] - ["Pop" cider-inspector-pop] - ["Refresh" cider-inspector-refresh] - "--" - ["Next Inspectable Object" cider-inspector-next-inspectable-object] - ["Previous Inspectable Object" cider-inspector-previous-inspectable-object] - "--" - ["Next Page" cider-inspector-next-page] - ["Previous Page" cider-inspector-prev-page] - ["Set Page Size" cider-inspector-set-page-size] - ["Set Max Atom Length" cider-inspector-set-max-atom-length] - ["Set Max Collection Size" cider-inspector-set-max-coll-size] - ["Define Var" cider-inspector-def-current-val] - "--" - ["Quit" cider-popup-buffer-quit-function] - )) - map)) - -(define-derived-mode cider-inspector-mode special-mode "Inspector" - "Major mode for inspecting Clojure data structures. - -\\{cider-inspector-mode-map}" - (set-syntax-table clojure-mode-syntax-table) - (setq-local electric-indent-chars nil) - (setq-local sesman-system 'CIDER) - (visual-line-mode 1)) - -;;;###autoload -(defun cider-inspect-last-sexp () - "Inspect the result of the the expression preceding point." - (interactive) - (cider-inspect-expr (cider-last-sexp) (cider-current-ns))) - -;;;###autoload -(defun cider-inspect-defun-at-point () - "Inspect the result of the \"top-level\" expression at point." - (interactive) - (cider-inspect-expr (cider-defun-at-point) (cider-current-ns))) - -;;;###autoload -(defun cider-inspect-last-result () - "Inspect the most recent eval result." - (interactive) - (cider-inspect-expr "*1" (cider-current-ns))) - -;;;###autoload -(defun cider-inspect (&optional arg) - "Inspect the result of the preceding sexp. - -With a prefix argument ARG it inspects the result of the \"top-level\" form. -With a second prefix argument it prompts for an expression to eval and inspect." - (interactive "p") - (pcase arg - (1 (cider-inspect-last-sexp)) - (4 (cider-inspect-defun-at-point)) - (16 (call-interactively #'cider-inspect-expr)))) - -(defvar cider-inspector-location-stack nil - "A stack used to save point locations in inspector buffers. -These locations are used to emulate `save-excursion' between -`cider-inspector-push' and `cider-inspector-pop' operations.") - -(defvar cider-inspector-page-location-stack nil - "A stack used to save point locations in inspector buffers. -These locations are used to emulate `save-excursion' between -`cider-inspector-next-page' and `cider-inspector-prev-page' operations.") - -(defvar cider-inspector-last-command nil - "Contains the value of the most recently used `cider-inspector-*' command. -This is used as an alternative to the built-in `last-command'. Whenever we -invoke any command through \\[execute-extended-command] and its variants, -the value of `last-command' is not set to the command it invokes.") - -(defvar cider-inspector--current-repl nil - "Contains the reference to the REPL where inspector was last invoked from. -This is needed for internal inspector buffer operations (push, -pop) to execute against the correct REPL session.") - -;; Operations -;;;###autoload -(defun cider-inspect-expr (expr ns) - "Evaluate EXPR in NS and inspect its value. -Interactively, EXPR is read from the minibuffer, and NS the -current buffer's namespace." - (interactive (list (cider-read-from-minibuffer "Inspect expression: " (cider-sexp-at-point)) - (cider-current-ns))) - (setq cider-inspector--current-repl (cider-current-repl)) - (when-let* ((value (cider-sync-request:inspect-expr - expr ns - cider-inspector-page-size - cider-inspector-max-atom-length - cider-inspector-max-coll-size))) - (cider-inspector--render-value value))) - -(defun cider-inspector-pop () - "Pop the last value off the inspector stack and render it. -See `cider-sync-request:inspect-pop' and `cider-inspector--render-value'." - (interactive) - (setq cider-inspector-last-command 'cider-inspector-pop) - (when-let* ((value (cider-sync-request:inspect-pop))) - (cider-inspector--render-value value))) - -(defun cider-inspector-push (idx) - "Inspect the value at IDX in the inspector stack and render it. -See `cider-sync-request:inspect-push' and `cider-inspector--render-value'" - (push (point) cider-inspector-location-stack) - (when-let* ((value (cider-sync-request:inspect-push idx))) - (cider-inspector--render-value value) - (cider-inspector-next-inspectable-object 1))) - -(defun cider-inspector-refresh () - "Re-render the currently inspected value. -See `cider-sync-request:inspect-refresh' and `cider-inspector--render-value'" - (interactive) - (when-let* ((value (cider-sync-request:inspect-refresh))) - (cider-inspector--render-value value))) - -(defun cider-inspector-next-page () - "Jump to the next page when inspecting a paginated sequence/map. - -Does nothing if already on the last page." - (interactive) - (push (point) cider-inspector-page-location-stack) - (when-let* ((value (cider-sync-request:inspect-next-page))) - (cider-inspector--render-value value))) - -(defun cider-inspector-prev-page () - "Jump to the previous page when expecting a paginated sequence/map. - -Does nothing if already on the first page." - (interactive) - (setq cider-inspector-last-command 'cider-inspector-prev-page) - (when-let* ((value (cider-sync-request:inspect-prev-page))) - (cider-inspector--render-value value))) - -(defun cider-inspector-set-page-size (page-size) - "Set the page size in pagination mode to the specified PAGE-SIZE. - -Current page will be reset to zero." - (interactive (list (read-number "Page size: " cider-inspector-page-size))) - (when-let ((value (cider-sync-request:inspect-set-page-size page-size))) - (cider-inspector--render-value value))) - -(defun cider-inspector-set-max-atom-length (max-length) - "Set the max length of nested atoms to MAX-LENGTH." - (interactive (list (read-number "Max atom length: " cider-inspector-max-atom-length))) - (when-let ((value (cider-sync-request:inspect-set-max-atom-length max-length))) - (cider-inspector--render-value value))) - -(defun cider-inspector-set-max-coll-size (max-size) - "Set the number of nested collection members to display before truncating. -MAX-SIZE is the new value." - (interactive (list (read-number "Max collection size: " cider-inspector-max-coll-size))) - (when-let ((value (cider-sync-request:inspect-set-max-coll-size max-size))) - (cider-inspector--render-value value))) - -(defun cider-inspector-def-current-val (var-name ns) - "Defines a var with VAR-NAME in current namespace. - -Doesn't modify current page. When called interactively NS defaults to -current-namespace." - (interactive (let ((ns (cider-current-ns))) - (list (read-from-minibuffer (concat "Var name: " ns "/")) - ns))) - (setq cider-inspector--current-repl (cider-current-repl)) - (when-let* ((value (cider-sync-request:inspect-def-current-val ns var-name))) - (cider-inspector--render-value value) - (message "%s#'%s/%s = %s" cider-eval-result-prefix ns var-name value))) - -;; nREPL interactions -(defun cider-sync-request:inspect-pop () - "Move one level up in the inspector stack." - (thread-first '("op" "inspect-pop") - (cider-nrepl-send-sync-request cider-inspector--current-repl) - (nrepl-dict-get "value"))) - -(defun cider-sync-request:inspect-push (idx) - "Inspect the inside value specified by IDX." - (thread-first `("op" "inspect-push" - "idx" ,idx) - (cider-nrepl-send-sync-request cider-inspector--current-repl) - (nrepl-dict-get "value"))) - -(defun cider-sync-request:inspect-refresh () - "Re-render the currently inspected value." - (thread-first '("op" "inspect-refresh") - (cider-nrepl-send-sync-request cider-inspector--current-repl) - (nrepl-dict-get "value"))) - -(defun cider-sync-request:inspect-next-page () - "Jump to the next page in paginated collection view." - (thread-first '("op" "inspect-next-page") - (cider-nrepl-send-sync-request cider-inspector--current-repl) - (nrepl-dict-get "value"))) - -(defun cider-sync-request:inspect-prev-page () - "Jump to the previous page in paginated collection view." - (thread-first '("op" "inspect-prev-page") - (cider-nrepl-send-sync-request cider-inspector--current-repl) - (nrepl-dict-get "value"))) - -(defun cider-sync-request:inspect-set-page-size (page-size) - "Set the page size in paginated view to PAGE-SIZE." - (thread-first `("op" "inspect-set-page-size" - "page-size" ,page-size) - (cider-nrepl-send-sync-request cider-inspector--current-repl) - (nrepl-dict-get "value"))) - -(defun cider-sync-request:inspect-set-max-atom-length (max-length) - "Set the max length of nested atoms to MAX-LENGTH." - (thread-first `("op" "inspect-set-max-atom-length" - "max-atom-length" ,max-length) - (cider-nrepl-send-sync-request cider-inspector--current-repl) - (nrepl-dict-get "value"))) - -(defun cider-sync-request:inspect-set-max-coll-size (max-size) - "Set the number of nested collection members to display before truncating. -MAX-SIZE is the new value." - (thread-first `("op" "inspect-set-max-coll-size" - "max-coll-size" ,max-size) - (cider-nrepl-send-sync-request cider-inspector--current-repl) - (nrepl-dict-get "value"))) - -(defun cider-sync-request:inspect-def-current-val (ns var-name) - "Defines a var with VAR-NAME in NS with the current inspector value." - (thread-first `("op" "inspect-def-current-value" - "ns" ,ns - "var-name" ,var-name) - (cider-nrepl-send-sync-request cider-inspector--current-repl) - (nrepl-dict-get "value"))) - -(defun cider-sync-request:inspect-expr (expr ns page-size max-atom-length max-coll-size) - "Evaluate EXPR in context of NS and inspect its result. -Set the page size in paginated view to PAGE-SIZE, maximum length of atomic -collection members to MAX-ATOM-LENGTH, and maximum size of nested collections to -MAX-COLL-SIZE if non nil." - (thread-first (append (nrepl--eval-request expr ns) - `("inspect" "true" - ,@(when page-size - `("page-size" ,page-size)) - ,@(when max-atom-length - `("max-atom-length" ,max-atom-length)) - ,@(when max-coll-size - `("max-coll-size" ,max-coll-size)))) - (cider-nrepl-send-sync-request cider-inspector--current-repl) - (nrepl-dict-get "value"))) - -;; Render Inspector from Structured Values -(defun cider-inspector--render-value (value) - "Render VALUE." - (cider-make-popup-buffer cider-inspector-buffer 'cider-inspector-mode 'ancillary) - (cider-inspector-render cider-inspector-buffer value) - (cider-popup-buffer-display cider-inspector-buffer cider-inspector-auto-select-buffer) - (when cider-inspector-fill-frame (delete-other-windows)) - (ignore-errors (cider-inspector-next-inspectable-object 1)) - (with-current-buffer cider-inspector-buffer - (when (eq cider-inspector-last-command 'cider-inspector-pop) - (setq cider-inspector-last-command nil) - ;; Prevents error message being displayed when we try to pop - ;; from the top-level of a data structure - (when cider-inspector-location-stack - (goto-char (pop cider-inspector-location-stack)))) - - (when (eq cider-inspector-last-command 'cider-inspector-prev-page) - (setq cider-inspector-last-command nil) - ;; Prevents error message being displayed when we try to - ;; go to a prev-page from the first page - (when cider-inspector-page-location-stack - (goto-char (pop cider-inspector-page-location-stack)))))) - -(defun cider-inspector-render (buffer str) - "Render STR in BUFFER." - (with-current-buffer buffer - (cider-inspector-mode) - (let ((inhibit-read-only t)) - (condition-case nil - (cider-inspector-render* (car (read-from-string str))) - (error (insert "\nInspector error for: " str)))) - (goto-char (point-min)))) - -(defun cider-inspector-render* (elements) - "Render ELEMENTS." - (dolist (el elements) - (cider-inspector-render-el* el))) - -(defun cider-inspector-render-el* (el) - "Render EL." - (cond ((symbolp el) (insert (symbol-name el))) - ((stringp el) (insert (propertize el 'font-lock-face 'font-lock-keyword-face))) - ((and (consp el) (eq (car el) :newline)) - (insert "\n")) - ((and (consp el) (eq (car el) :value)) - (cider-inspector-render-value (cadr el) (cl-caddr el))) - (t (message "Unrecognized inspector object: %s" el)))) - -(defun cider-inspector-render-value (value idx) - "Render VALUE at IDX." - (cider-propertize-region - (list 'cider-value-idx idx - 'mouse-face 'highlight) - (cider-inspector-render-el* (cider-font-lock-as-clojure value)))) - - -;; =================================================== -;; Inspector Navigation (lifted from SLIME inspector) -;; =================================================== - -(defun cider-find-inspectable-object (direction limit) - "Find the next/previous inspectable object. -DIRECTION can be either 'next or 'prev. -LIMIT is the maximum or minimum position in the current buffer. - -Return a list of two values: If an object could be found, the -starting position of the found object and T is returned; -otherwise LIMIT and NIL is returned." - (let ((finder (cl-ecase direction - (next 'next-single-property-change) - (prev 'previous-single-property-change)))) - (let ((prop nil) (curpos (point))) - (while (and (not prop) (not (= curpos limit))) - (let ((newpos (funcall finder curpos 'cider-value-idx nil limit))) - (setq prop (get-text-property newpos 'cider-value-idx)) - (setq curpos newpos))) - (list curpos (and prop t))))) - -(defun cider-inspector-next-inspectable-object (arg) - "Move point to the next inspectable object. -With optional ARG, move across that many objects. -If ARG is negative, move backwards." - (interactive "p") - (let ((maxpos (point-max)) (minpos (point-min)) - (previously-wrapped-p nil)) - ;; Forward. - (while (> arg 0) - (seq-let (pos foundp) (cider-find-inspectable-object 'next maxpos) - (if foundp - (progn (goto-char pos) - (unless (and cider-inspector-skip-uninteresting - (looking-at-p cider-inspector-uninteresting-regexp)) - (setq arg (1- arg)) - (setq previously-wrapped-p nil))) - (if (not previously-wrapped-p) ; cycle detection - (progn (goto-char minpos) (setq previously-wrapped-p t)) - (error "No inspectable objects"))))) - ;; Backward. - (while (< arg 0) - (seq-let (pos foundp) (cider-find-inspectable-object 'prev minpos) - ;; CIDER-OPEN-INSPECTOR inserts the title of an inspector page - ;; as a presentation at the beginning of the buffer; skip - ;; that. (Notice how this problem can not arise in ``Forward.'') - (if (and foundp (/= pos minpos)) - (progn (goto-char pos) - (unless (and cider-inspector-skip-uninteresting - (looking-at-p cider-inspector-uninteresting-regexp)) - (setq arg (1+ arg)) - (setq previously-wrapped-p nil))) - (if (not previously-wrapped-p) ; cycle detection - (progn (goto-char maxpos) (setq previously-wrapped-p t)) - (error "No inspectable objects"))))))) - -(defun cider-inspector-previous-inspectable-object (arg) - "Move point to the previous inspectable object. -With optional ARG, move across that many objects. -If ARG is negative, move forwards." - (interactive "p") - (cider-inspector-next-inspectable-object (- arg))) - -(defun cider-inspector-property-at-point () - "Return property at point." - (let* ((properties '(cider-value-idx cider-range-button - cider-action-number)) - (find-property - (lambda (point) - (cl-loop for property in properties - for value = (get-text-property point property) - when value - return (list property value))))) - (or (funcall find-property (point)) - (funcall find-property (max (point-min) (1- (point))))))) - -(defun cider-inspector-operate-on-point () - "Invoke the command for the text at point. -1. If point is on a value then recursively call the inspector on -that value. -2. If point is on an action then call that action. -3. If point is on a range-button fetch and insert the range." - (interactive) - (seq-let (property value) (cider-inspector-property-at-point) - (cl-case property - (cider-value-idx - (cider-inspector-push value)) - ;; TODO: range and action handlers - (t (error "No object at point"))))) - -(defun cider-inspector-operate-on-click (event) - "Move to EVENT's position and operate the part." - (interactive "@e") - (let ((point (posn-point (event-end event)))) - (cond ((and point - (or (get-text-property point 'cider-value-idx))) - (goto-char point) - (cider-inspector-operate-on-point)) - (t - (error "No clickable part here"))))) - -(provide 'cider-inspector) - -;;; cider-inspector.el ends here diff --git a/elpa/cider-20230707.640/cider-jar.el b/elpa/cider-20230707.640/cider-jar.el deleted file mode 100644 index 66746426..00000000 --- a/elpa/cider-20230707.640/cider-jar.el +++ /dev/null @@ -1,141 +0,0 @@ -;;; cider-jar.el --- Jar functionality for Clojure -*- lexical-binding: t -*- - -;; Copyright © 2022 Arne Brasseur -;; -;; Author: Arne Brasseur - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Dealing with JAR (Java archive) files, which are really just zip files in -;; disguise. In particular downloading and retrieving the cider-nrepl jar. - -;;; Code: - -(require 'url) -(require 'arc-mode) -(require 'map) - - -(defvar cider-jar-cache-dir (expand-file-name "cider-cache" user-emacs-directory) - "Location where we store downloaded files for later use.") - -(defvar cider-jar-content-cache (make-hash-table :test #'equal) - "Nested hash table of jar-path -> file-path -> bool. -This provides an efficient check to see if a file exists in a jar or not.") - -(defun cider-jar-clojars-url (group artifact version) - "URL to download a specific jar from Clojars. -GROUP, ARTIFACT, and VERSION are the components of the Maven coordinates." - (concat "https://repo.clojars.org/" group "/" artifact "/" - version - "/cider-nrepl-" - version - ".jar")) - -(defun cider-jar-find-or-fetch (group artifact version) - "Download the given jar off clojars and cache it. - -GROUP, ARTIFACT, and VERSION are the components of the Maven coordinates. -Returns the path to the jar." - (let* ((m2-path (expand-file-name (concat "~/.m2/repository/" group "/" artifact "/" version "/" artifact "-" version ".jar"))) - (clojars-url (cider-jar-clojars-url group artifact version)) - (cache-path (expand-file-name (replace-regexp-in-string "https://" "" clojars-url) cider-jar-cache-dir))) - (cond - ((file-exists-p m2-path) m2-path) - ((file-exists-p cache-path) cache-path) - (t - (make-directory (file-name-directory cache-path) t) - (url-copy-file clojars-url cache-path) - cache-path)))) - -(defun cider-jar--archive-zip-summarize () - "Forked version of `archive-zip-summarize'. -Only read the information we need, and be version independent." - (goto-char (- (point-max) (- 22 18))) - (search-backward-regexp "[P]K\005\006") - (let ((p (archive-l-e (+ (point) 16) 4)) - files) - (when (or (= p #xffffffff) (= p -1)) - ;; If the offset of end-of-central-directory is 0xFFFFFFFF, this - ;; is a Zip64 extended ZIP file format, and we need to glean the - ;; info from Zip64 records instead. - ;; - ;; First, find the Zip64 end-of-central-directory locator. - (search-backward "PK\006\007") - (setq p (+ (point-min) - (archive-l-e (+ (point) 8) 8))) - (goto-char p) - ;; We should be at Zip64 end-of-central-directory record now. - (or (string= "PK\006\006" (buffer-substring p (+ p 4))) - (error "Unrecognized ZIP file format")) - ;; Offset to central directory: - (setq p (archive-l-e (+ p 48) 8))) - (setq p (+ p (point-min))) - (while (string= "PK\001\002" (buffer-substring p (+ p 4))) - (let* ((fnlen (archive-l-e (+ p 28) 2)) - (exlen (archive-l-e (+ p 30) 2)) - (fclen (archive-l-e (+ p 32) 2)) - (efnname (let ((str (buffer-substring (+ p 46) (+ p 46 fnlen)))) - (decode-coding-string - str archive-file-name-coding-system)))) - (setq files (cons efnname files) - p (+ p 46 fnlen exlen fclen)))) - files)) - -(defun cider-jar-contents (jarfile) - "Get the list of filenames in a jar (or zip) file. -JARFILE is the location of the archive." - (with-temp-buffer - (set-buffer-multibyte nil) - (setq buffer-file-coding-system 'binary) - (insert-file-contents-literally jarfile nil) - (cider-jar--archive-zip-summarize))) - -(defun cider-jar-contents-cached (jarfile) - "Like cider-jar-contents, but cached. - -Instead of returning a list of strings this returns a hash table of string -keys and values `t`, for quick lookup. JARFILE is the location of the -archive." - (let ((m (map-elt cider-jar-content-cache jarfile))) - (if m - m - (let ((m (make-hash-table :test #'equal))) - (seq-do (lambda (path) - (puthash path t m)) - (cider-jar-contents jarfile)) - (puthash jarfile m cider-jar-content-cache) - m)))) - -(defun cider-jar-contains-p (jarfile name) - "Does the JARFILE contain a file with the given NAME?" - (map-elt (cider-jar-contents-cached jarfile) name)) - -(defun cider-jar-retrieve-resource (jarfile name) - "Extract a file NAME from a JARFILE as a string." - (make-directory archive-tmpdir :make-parents) - (when (cider-jar-contains-p jarfile name) - (let ((default-directory archive-tmpdir)) - (with-temp-buffer - (set-buffer-multibyte nil) - (setq buffer-file-coding-system 'binary) - (archive-zip-extract jarfile name) - (buffer-substring-no-properties (point-min) (point-max)))))) - -(provide 'cider-jar) -;;; cider-jar.el ends here diff --git a/elpa/cider-20230707.640/cider-log.el b/elpa/cider-20230707.640/cider-log.el deleted file mode 100644 index fbe0106b..00000000 --- a/elpa/cider-20230707.640/cider-log.el +++ /dev/null @@ -1,1428 +0,0 @@ -;;; cider-log.el --- Log inspection functionality for Clojure -*- lexical-binding: t -*- - -;; Copyright © 2023 Bozhidar Batsov and CIDER contributors - -;; Author: r0man - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Log inspection functionality for Clojure. -;; -;; Please, refer to the online documentation for more details -;; https://docs.cider.mx/cider/debugging/logging.html. - -;;; Code: - -(require 'cider-inspector) -(require 'cider-stacktrace) -(require 'cl-lib) -(require 'logview nil t) -(require 'org) -(require 'seq) -(require 'transient) - -(defcustom cider-log-framework-name nil - "The name of the current log framework." - :group 'cider - :package-version '(cider . "1.8.0") - :safe #'stringp - :type 'string) - -(defcustom cider-log-appender-id "cider-log" - "The name of the default log appender." - :group 'cider - :package-version '(cider . "1.8.0") - :safe #'stringp - :type 'string) - -(defcustom cider-log-buffer "*cider-log*" - "The name of the log buffer." - :group 'cider - :package-version '(cider . "1.8.0") - :safe #'stringp - :type 'string) - -(defcustom cider-log-event-buffer "*cider-log-event*" - "The name of the log event buffer." - :group 'cider - :package-version '(cider . "1.8.0") - :safe #'stringp - :type 'string) - -(defcustom cider-log-max-message-length 500 - "The maximum length of the log message to display." - :group 'cider - :package-version '(cider . "1.8.0") - :safe #'integerp - :type 'integer) - -(defcustom cider-log-pagination-limit 250 - "The maximum number of log events to return when searching events." - :group 'cider - :package-version '(cider . "1.8.0") - :safe #'integerp - :type 'integer) - -(defcustom cider-log-pagination-offset 0 - "The offset from which to return results when searching events." - :group 'cider - :package-version '(cider . "1.8.0") - :safe #'integerp - :type 'integer) - -(defcustom cider-log-use-logview (fboundp 'logview-mode) - "Whether to use `logview-mode' or not." - :group 'cider - :package-version '(cider . "1.8.0") - :safe #'booleanp - :type 'boolean) - -(defvar logview-mode-map) -(declare-function logview--guess-submode "logview" () t) -(declare-function logview-initialized-p "logview" () t) -(declare-function logview-mode "logview" () t) - -(defvar cider-log--initialized-once-p nil - "Set to t if log framework and appender have been initialized once.") - -(defvar cider-log-framework nil - "The current log framework to use.") - -(defvar cider-log-appender nil - "The current log appender.") - -(defvar cider-log-appender-size 100000 - "The size of the log appender.") - -(defvar cider-log-appender-threshold 10 - "The threshold in percent of the log appender.") - -(defvar-local cider-log-consumer nil - "The current log consumer.") - -;; Filters - -(defvar cider-log--end-time-filter nil) -(defvar cider-log--exceptions-filter nil) -(defvar cider-log--level-filter nil) -(defvar cider-log--loggers-filter nil) -(defvar cider-log--pattern-filter nil) -(defvar cider-log--start-time-filter nil) -(defvar cider-log--threads-filter nil) - -(defun cider-log--bold (s) - "Return S with a bold face." - (when s (propertize (format "%s" s) 'face 'bold))) - -(defun cider-log-buffer-clear-p (&optional buffer) - "Return non-nil if BUFFER is not empty, otherwise nil." - (when-let (buffer (get-buffer (or buffer cider-log-buffer))) - (> (buffer-size buffer) 0))) - -(defun cider-log--description-clear-events-buffer () - "Return the description for the set framework action." - (format "Clear %s buffer" - (if cider-log-buffer - (cider-log--format-value cider-log-buffer) - (propertize "n/a" 'face 'font-lock-comment-face)))) - -(defun cider-log--description-set-framework () - "Return the description for the set framework action." - (format "Select framework %s" - (if cider-log-framework-name - (cider-log--format-value cider-log-framework-name) - (propertize "n/a" 'face 'font-lock-comment-face)))) - -(defun cider-log--description-set-buffer () - "Return the description for the set buffer action." - (format "Select buffer %s" - (if cider-log-buffer - (cider-log--format-value cider-log-buffer) - (propertize "n/a" 'face 'font-lock-comment-face)))) - -(defun cider-log--buffers-in-major-mode (expected) - "Return all buffers which are in the EXPECTED major mode." - (seq-filter (lambda (buffer) - (with-current-buffer buffer - (equal expected major-mode))) - (buffer-list))) - -(defun cider-log--format-time (time) - "Format TIME in ISO8601 format." - (format-time-string "%FT%T%z" time)) - -(defun cider-log--format-value (value) - "Format the VALUE for display in a transient menu." - (cond ((null value) "") - ((or (listp value) (vectorp value)) - (string-join (seq-map #'cider-log--format-value value) - (propertize ", " 'face 'font-lock-comment-face))) - (t (propertize (format "%s" value) 'face 'transient-value)))) - -(defun cider-log--strip-whitespace (s) - "Replace multiple white space characters in S with a single one." - (replace-regexp-in-string "[\n ]+" " " s)) - -;; NREPL - -(defun cider-request:log-add-consumer (framework appender consumer &optional callback) - "Add CONSUMER to the APPENDER of FRAMEWORK and call CALLBACK on log events." - (cider-ensure-op-supported "cider/log-add-consumer") - (thread-first `("op" "cider/log-add-consumer" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender) - "filters" ,(cider-log-consumer-filters consumer)) - (cider-nrepl-send-request callback))) - -(defun cider-request:log-analyze-stacktrace (framework appender event &optional callback) - "Analyze the EVENT stacktrace of the APPENDER of FRAMEWORK and call CALLBACK." - (cider-ensure-op-supported "cider/log-analyze-stacktrace") - (thread-first `("op" "cider/log-analyze-stacktrace" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender) - "event" ,(cider-log-event-id event)) - (cider-nrepl-send-request callback))) - -(defun cider-sync-request:log-update-consumer (framework appender consumer) - "Add CONSUMER to the APPENDER of FRAMEWORK and call CALLBACK on log events." - (cider-ensure-op-supported "cider/log-update-consumer") - (thread-first `("op" "cider/log-update-consumer" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender) - "consumer" ,(cider-log-consumer-id consumer) - "filters" ,(cider-log-consumer-filters consumer)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-update-consumer"))) - -(defun cider-sync-request:log-add-appender (framework appender) - "Add the APPENDER to the log FRAMEWORK." - (cider-ensure-op-supported "cider/log-add-appender") - (thread-first `("op" "cider/log-add-appender" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender) - "filters" ,(cider-log-appender-filters appender) - "size" ,(cider-log-appender-size appender) - "threshold" ,(cider-log-appender-threshold appender)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-add-appender"))) - -(defun cider-sync-request:log-update-appender (framework appender) - "Update the APPENDER of the log FRAMEWORK." - (cider-ensure-op-supported "cider/log-update-appender") - (thread-first `("op" "cider/log-update-appender" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender) - "filters" ,(cider-log-appender-filters appender) - "size" ,(cider-log-appender-size appender) - "threshold" ,(cider-log-appender-threshold appender)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-update-appender"))) - -(defun cider-sync-request:log-clear (framework appender) - "Clear the log events for FRAMEWORK and APPENDER." - (cider-ensure-op-supported "cider/log-clear-appender") - (thread-first `("op" "cider/log-clear-appender" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-clear-appender"))) - -(defun cider-sync-request:log-inspect-event (framework appender event) - "Inspect the log event with the ID in the APPENDER of the log FRAMEWORK." - (cider-ensure-op-supported "cider/log-inspect-event") - (thread-first `("op" "cider/log-inspect-event" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender) - "event" ,(cider-log-event-id event)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "value"))) - -(defun cider-sync-request:log-format-event (framework appender event) - "Format the log EVENT from the APPENDER of the log FRAMEWORK." - (cider-ensure-op-supported "cider/log-format-event") - (thread-first - (seq-mapcat #'identity - (map-merge 'list - (cider--nrepl-print-request-map fill-column) - `(("op" "cider/log-format-event") - ("framework" ,(cider-log-framework-id framework)) - ("appender" ,(cider-log-appender-id appender)) - ("event" ,(cider-log-event-id event))))) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-format-event"))) - -(defun cider-sync-request:log-frameworks () - "Return the available log frameworks." - (cider-ensure-op-supported "cider/log-frameworks") - (thread-first `("op" "cider/log-frameworks") - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-frameworks"))) - -(cl-defun cider-sync-request:log-search (framework appender &key filters limit offset) - "Search log events of FRAMEWORK and APPENDER using FILTERS, LIMIT and OFFSET." - (cider-ensure-op-supported "cider/log-search") - (thread-first `("op" "cider/log-search" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender) - "filters" ,filters - "limit" ,limit - "offset" ,offset) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-search"))) - -(defun cider-sync-request:log-exceptions (framework appender) - "Return the Cider log exceptions for FRAMEWORK and APPENDER." - (cider-ensure-op-supported "cider/log-exceptions") - (thread-first `("op" "cider/log-exceptions" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-exceptions"))) - -(defun cider-sync-request:log-levels (framework appender) - "Return the Cider log levels for FRAMEWORK and APPENDER." - (cider-ensure-op-supported "cider/log-levels") - (thread-first `("op" "cider/log-levels" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-levels"))) - -(defun cider-sync-request:log-loggers (framework appender) - "Return the Cider loggers for FRAMEWORK and APPENDER." - (cider-ensure-op-supported "cider/log-loggers") - (thread-first `("op" "cider/log-loggers" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-loggers"))) - -(defun cider-sync-request:log-remove-appender (framework appender) - "Remove the APPENDER from the log FRAMEWORK." - (cider-ensure-op-supported "cider/log-remove-appender") - (thread-first `("op" "cider/log-remove-appender" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-remove-appender"))) - -(defun cider-sync-request:log-remove-consumer (framework appender consumer) - "Remove the CONSUMER from the APPENDER of the log FRAMEWORK." - (cider-ensure-op-supported "cider/log-remove-consumer") - (thread-first `("op" "cider/log-remove-consumer" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender) - "consumer" ,(cider-log-consumer-id consumer)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-remove-consumer"))) - -(defun cider-sync-request:log-threads (framework appender) - "Return the threads for FRAMEWORK and APPENDER." - (cider-ensure-op-supported "cider/log-threads") - (thread-first `("op" "cider/log-threads" - "framework" ,(cider-log-framework-id framework) - "appender" ,(cider-log-appender-id appender)) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "cider/log-threads"))) - -(defun cider-log--completion-extra-properties (keys &optional separator) - "Return the completion properties for NREPL dictionaries. - -The KEYS are used to lookup the values and are joined by SEPARATOR." - `(:annotation-function - ,(lambda (identifier) - (when-let (dict (cadr (assoc identifier minibuffer-completion-table))) - (let ((annotation (string-join (seq-map (lambda (key) (nrepl-dict-get dict key)) keys) - (or separator " ")))) - (unless (string-blank-p annotation) - (propertize (format " - %s" (cider-log--strip-whitespace annotation)) - 'face 'font-lock-comment-face))))))) - -(defun cider-log--read-appender-id (prompt initial-input history) - "Read a appender from the minibuffer using PROMPT, INITIAL-INPUT and HISTORY." - (let ((table (when cider-log-framework - (when-let (framework (cider-log-framework-reload cider-log-framework)) - (seq-map #'cider-log-appender-id (cider-log-framework-appenders framework)))))) - (completing-read (or prompt "Log appender: ") table nil nil - (or initial-input cider-log-appender-id) - history cider-log-appender-id))) - -(defun cider-log--read-buffer (&optional prompt initial-input history) - "Read the log buffer name using PROMPT, INITIAL-INPUT and HISTORY." - (let ((table (seq-map #'buffer-name (cider-log--buffers-in-major-mode 'cider-log-mode)))) - (completing-read (or prompt "Buffer: ") table nil nil - (or initial-input cider-log-buffer) - history cider-log-buffer))) - -(defun cider-log--read-exceptions (&optional prompt initial-input history) - "Read a list of exceptions using PROMPT, INITIAL-INPUT and HISTORY." - (let ((table (when (cider-log-appender-attached-p) - (nrepl-dict-keys (cider-sync-request:log-exceptions - cider-log-framework cider-log-appender))))) - (completing-read-multiple (or prompt "Exceptions: ") table nil nil initial-input history))) - -(defun cider-log--read-framework-name (&optional prompt initial-input history) - "Read a framework name using PROMPT, INITIAL-INPUT and HISTORY." - (let ((completion-extra-properties (cider-log--completion-extra-properties '("name"))) - (frameworks (cider-sync-request:log-frameworks))) - (completing-read (or prompt "Log framework: ") - (seq-map (lambda (framework) - (list (cider-log-framework-name framework) framework)) - frameworks) - nil nil initial-input history))) - -(defun cider-log--read-level (&optional prompt initial-input history) - "Read a log level using PROMPT, INITIAL-INPUT and HISTORY." - (let ((table (when cider-log-framework (cider-log-framework-level-names cider-log-framework)))) - (completing-read (or prompt "Level: ") table nil nil initial-input history))) - -(defun cider-log--read-loggers (&optional prompt initial-input history) - "Read a list of loggers using PROMPT, INITIAL-INPUT and HISTORY." - (let ((table (when (cider-log-appender-attached-p) - (nrepl-dict-keys (cider-sync-request:log-loggers - cider-log-framework cider-log-appender))))) - (completing-read-multiple (or "Loggers: " prompt) table nil nil initial-input history))) - -(defun cider-log--read-number-N0 (&optional prompt initial-input history) - "Read a natural number (including zero) using PROMPT, INITIAL-INPUT and HISTORY." - (when-let (value (transient-read-number-N0 (or prompt "Number: ") initial-input history)) - (string-to-number value))) - -(defun cider-log--read-number-N+ (&optional prompt initial-input history) - "Read a natural number (excluding zero) using PROMPT, INITIAL-INPUT and HISTORY." - (when-let (value (transient-read-number-N+ (or prompt "Number: ") initial-input history)) - (string-to-number value))) - -(defun cider-log--read-threads (&optional prompt initial-input history) - "Read a list of threads using PROMPT, INITIAL-INPUT and HISTORY." - (let ((table (when (cider-log-appender-attached-p) - (nrepl-dict-keys (cider-sync-request:log-threads - cider-log-framework cider-log-appender))))) - (completing-read-multiple (or prompt "Threads: ") table nil nil initial-input history))) - -(defun cider-log--read-time (&optional prompt initial-input _) - "Read a time from the minibuffer using PROMPT and INITIAL-INPUT." - (cider-log--format-time (org-read-date t 'to-time nil prompt nil initial-input))) - -;; Log Framework - -(defun cider-log-framework-appender (framework id) - "Return the appender of the log FRAMEWORK with the given ID." - (seq-find (lambda (appender) (equal id (cider-log-appender-id appender))) - (cider-log-framework-appenders framework))) - -(defun cider-log-framework-appenders (framework) - "Return the appenders of the log FRAMEWORK." - (nrepl-dict-get framework "appenders")) - -(defun cider-log-framework-id (framework) - "Return the id of the log FRAMEWORK." - (nrepl-dict-get framework "id")) - -(defun cider-log-framework-javadoc-url (framework) - "Return the Javadoc URL of the log FRAMEWORK." - (nrepl-dict-get framework "javadoc-url")) - -(defun cider-log-framework-name (framework) - "Return the name of the log FRAMEWORK." - (nrepl-dict-get framework "name")) - -(defun cider-log-framework-level-names (framework) - "Return the log level names of the log FRAMEWORK." - (seq-map (lambda (level) (nrepl-dict-get level "name")) - (nrepl-dict-get framework "levels"))) - -(defun cider-log-framework-website-url (framework) - "Return the website URL of the log FRAMEWORK." - (nrepl-dict-get framework "website-url")) - -(defun cider-log-framework-display-name (framework) - "Return the display name of the log FRAMEWORK." - (cider-log--bold (cider-log-framework-name framework))) - -(defun cider-log-framework-add-appender (framework appender) - "Add the APPENDER to the log FRAMEWORK." - (cider-sync-request:log-add-appender framework appender)) - -(defun cider-log-framework-by-id (frameworks id) - "Find the log framework in FRAMEWORKS by ID." - (seq-find (lambda (framework) (equal id (cider-log-framework-id framework))) frameworks)) - -(defun cider-log-framework-by-name (frameworks name) - "Find the log framework in FRAMEWORKS by NAME." - (seq-find (lambda (framework) (equal name (cider-log-framework-name framework))) frameworks)) - -(defun cider-log-framework-reload (framework) - "Reload the log FRAMEWORK." - (cider-log-framework-by-id - (cider-sync-request:log-frameworks) - (cider-log-framework-id framework))) - -;; Log Appender - -(defun cider-log-appender-attached-p (&optional framework appender) - "Return non-nil if the log APPENDER is attached to FRAMEWORK, otherwise nil." - (when-let ((framework (or framework - (cider-log-framework-by-name - (cider-sync-request:log-frameworks) - cider-log-framework-name))) - (appender-id (if appender - (cider-log-appender-id appender) - cider-log-appender-id))) - (cider-log-framework-appender framework appender-id))) - -(defun cider-log-appender-consumers (appender) - "Return the consumers of the log APPENDER." - (nrepl-dict-get appender "consumers")) - -(defun cider-log-appender-id (appender) - "Return the id of the log APPENDER." - (nrepl-dict-get appender "id")) - -(defun cider-log-appender-size (appender) - "Return the size of the log APPENDER." - (nrepl-dict-get appender "size")) - -(defun cider-log-appender-threshold (appender) - "Return the threshold of the log APPENDER." - (nrepl-dict-get appender "threshold")) - -(defun cider-log-appender-filters (appender) - "Return the filters of the log APPENDER." - (nrepl-dict-get appender "filters")) - -(defun cider-log-appender-display-name (appender) - "Return the display name of the log APPENDER." - (cider-log--bold (cider-log-appender-id appender))) - -(defun cider-log-appender-consumer (appender consumer) - "Find the consumer in the log APPENDER by the id slot of CONSUMER." - (let ((id (cider-log-consumer-id consumer))) - (seq-find (lambda (consumer) (equal id (cider-log-consumer-id consumer))) - (cider-log-appender-consumers appender)))) - -(defun cider-log-appender-reload (framework appender) - "Reload the APPENDER of the log FRAMEWORK." - (when-let (framework (cider-log-framework-reload framework)) - (cider-log-framework-appender framework (cider-log-appender-id appender)))) - -;; Log Consumer - -(defun cider-log-consumer-attached-p (&optional framework appender consumer) - "Return non-nil if the CONSUMER is attached to the APPENDER of FRAMEWORK." - (when-let ((framework (or framework cider-log-framework)) - (appender (or appender cider-log-appender)) - (consumer (or consumer cider-log-consumer))) - (cider-log-consumer-reload framework appender consumer))) - -(defun cider-log-consumer-id (consumer) - "Return the id of the log CONSUMER." - (nrepl-dict-get consumer "id")) - -(defun cider-log-consumer-filters (consumer) - "Return the filters of the log CONSUMER." - (nrepl-dict-get consumer "filters")) - -(defun cider-log-consumer-buffers (consumer) - "Find all buffers in which `cider-log-consumer' is bound to CONSUMER." - (seq-filter (lambda (buffer) - (with-current-buffer buffer - (and (nrepl-dict-p cider-log-consumer) - (equal (cider-log-consumer-id consumer) - (cider-log-consumer-id cider-log-consumer))))) - (buffer-list))) - -(defun cider-log-consumer-display-name (consumer) - "Return the display name of the log CONSUMER." - (cider-log--bold (cider-log-consumer-id consumer))) - -(defun cider-log-consumer-reload (framework appender consumer) - "Reload the CONSUMER attached to APPENDER of the log FRAMEWORK." - (when-let (appender (cider-log-appender-reload framework appender)) - (cider-log-appender-consumer appender consumer))) - -(defun cider-log--consumer-add (framework appender consumer buffer) - "Add the CONSUMER to the APPENDER of FRAMEWORK and write events to BUFFER." - (cider-request:log-add-consumer - framework appender consumer - (lambda (msg) - (nrepl-dbind-response msg (cider/log-add-consumer cider/log-consumer cider/log-event status) - (cond ((member "done" status) - (with-current-buffer (get-buffer-create buffer) - (setq-local cider-log-framework framework) - (setq-local cider-log-appender appender) - (setq cider-log-consumer cider/log-add-consumer) - (switch-to-buffer buffer))) - ((member "cider/log-event" status) - (let* ((consumer (nrepl-dict "id" cider/log-consumer)) - (buffers (cider-log-consumer-buffers consumer))) - (when (seq-empty-p buffers) - (message "WARNING: No buffers found for %s log consumer %s of appender %s." - (cider-log-framework-display-name framework) - (cider-log-consumer-display-name consumer) - (cider-log-appender-display-name appender)) - (cider-sync-request:log-remove-consumer framework appender consumer)) - (seq-doseq (buffer buffers) - (with-current-buffer buffer - (cider-log--insert-events buffer (list cider/log-event)) - (when (and cider-log-use-logview (not (logview-initialized-p))) - (let ((framework cider-log-framework) - (appender cider-log-appender) - (consumer cider-log-consumer)) - (logview--guess-submode) - (cider-log-mode) - ;; Restore buffer local vars reset by calling major mode. - (setq-local cider-log-framework framework - cider-log-appender appender - cider-log-consumer consumer)))))))))))) - -(defun cider-log--remove-current-buffer-consumer () - "Cleanup the log consumer of the current buffer." - (when-let ((framework cider-log-framework) - (appender cider-log-appender) - (consumer cider-log-consumer)) - (setq-local cider-log-consumer nil) - (when-let (consumer (cider-log-consumer-reload framework appender consumer)) - (cider-sync-request:log-remove-consumer framework appender consumer) - consumer))) - -;; Event - -(defun cider-log-event-id (event) - "Return the id of the log EVENT." - (nrepl-dict-get event "id")) - -(defun cider-log-event-exception (event) - "Return the exception of the log EVENT." - (nrepl-dict-get event "exception")) - -(defun cider-log-event--format-logback (event) - "Format the log EVENT in logview's Logback format." - (nrepl-dbind-response event (_exception level logger message thread timestamp) - (propertize (format "%s [%s] %s %s - %s\n" - (if (numberp timestamp) - (format-time-string "%F %T.%3N" (/ timestamp 1000)) - (format "%s" timestamp)) - thread - (upcase level) - logger - (if (and (stringp message) - (numberp cider-log-max-message-length)) - (substring message 0 (min (length message) cider-log-max-message-length)) - "")) - :cider-log-event event))) - -(defun cider-log-event--pretty-print (framework appender event) - "Format the log EVENT of FRAMEWORK and APPENDER." - (when-let (event (cider-sync-request:log-format-event framework appender event)) - (cider-popup-buffer cider-log-event-buffer cider-auto-select-error-buffer - 'clojure-mode 'ancillary) - (with-current-buffer cider-log-event-buffer - (let ((inhibit-read-only t)) - (erase-buffer) - (insert event) - (goto-char (point-min)))))) - -(defun cider-log-event--inspect (framework appender event) - "Inspect the log EVENT of FRAMEWORK and APPENDER." - (thread-last (cider-sync-request:log-inspect-event framework appender event) - (cider-inspector--render-value))) - -(defun cider-log--insert-events (buffer events) - "Insert the log EVENTS into BUFFER." - (with-current-buffer (get-buffer-create buffer) - (let ((windows (seq-filter (lambda (window) (= (window-point window) (point-max))) - (get-buffer-window-list buffer)))) - (save-excursion - (let ((inhibit-read-only t)) - (goto-char (point-max)) - (seq-doseq (event events) - (insert (cider-log-event--format-logback event))))) - (seq-doseq (window windows) - (set-window-point window (point-max)))))) - -(defun cider-log-event--show-stacktrace (framework appender event) - "Show the stacktrace of the log EVENT of FRAMEWORK and APPENDER." - (when (and framework appender event (cider-log-event-exception event)) - (let ((auto-select-buffer cider-auto-select-error-buffer) - (causes nil)) - (cider-request:log-analyze-stacktrace - framework appender event - (lambda (response) - (nrepl-dbind-response response (class status) - (cond (class (setq causes (cons response causes))) - (status (when causes - (cider-stacktrace-render - (cider-popup-buffer cider-error-buffer - auto-select-buffer - #'cider-stacktrace-mode - 'ancillary) - (reverse causes))))))))))) - -(defun cider-log-event-next-line (&optional n) - "Move N lines forward." - (interactive "p") - (let ((n (or n 1))) - (forward-line n) - (beginning-of-line) - (when-let ((framework cider-log-framework) - (appender cider-log-appender) - (event (cider-log-event-at-point))) - (let ((cider-auto-select-error-buffer nil)) - (save-window-excursion - (when (get-buffer-window cider-error-buffer) - (cider-log-event--show-stacktrace framework appender event)) - (when (get-buffer-window cider-inspector-buffer) - (cider-log-event--inspect framework appender event)) - (when (get-buffer-window cider-log-event-buffer) - (cider-log-event--pretty-print framework appender event))))))) - -(defun cider-log-event-previous-line (&optional n) - "Move N lines backward." - (interactive "p") - (cider-log-event-next-line (- (or n 1)))) - -(defun cider-log--set-filters (filters) - "Set the filter variables from the NREPL dict FILTERS." - (when filters - (setq cider-log--end-time-filter (nrepl-dict-get filters "end-time") - cider-log--exceptions-filter (nrepl-dict-get filters "exceptions") - cider-log--level-filter (nrepl-dict-get filters "level") - cider-log--loggers-filter (nrepl-dict-get filters "loggers") - cider-log--pattern-filter (nrepl-dict-get filters "pattern") - cider-log--start-time-filter (nrepl-dict-get filters "start-time") - cider-log--threads-filter (nrepl-dict-get filters "threads")))) - -(defun cider-log--ensure-initialized (framework &optional appender consumer) - "Ensure that the given FRAMEWORK, APPENDER and CONSUMER are initialized." - (setq cider-log-framework framework - cider-log-framework-name (cider-log-framework-name framework)) - (when appender - (setq cider-log-appender appender - cider-log-appender-id (cider-log-appender-id appender) - cider-log-appender-size (cider-log-appender-size appender) - cider-log-appender-threshold (cider-log-appender-threshold appender)) - (cider-log--set-filters (cider-log-appender-filters appender))) - (when consumer - (setq cider-log-consumer consumer) - (cider-log--set-filters (cider-log-consumer-filters appender))) - (when (and appender (not cider-log--initialized-once-p)) - (unless (cider-log-appender-reload framework appender) - (setq cider-log-appender (cider-sync-request:log-add-appender framework appender)) - (setq cider-log--initialized-once-p t)))) - -(defun cider-log-kill-buffer-hook-handler () - "Called from `kill-buffer-hook' to remove the consumer." - (when (eq 'cider-log-mode major-mode) - (when-let ((framework cider-log-framework) - (appender cider-log-appender) - (consumer cider-log-consumer)) - (cider-log--remove-current-buffer-consumer) - (message "Removed %s event consumer %s from appender %s." - (cider-log-framework-display-name framework) - (cider-log-consumer-display-name consumer) - (cider-log-appender-display-name appender))))) - -(defun cider-log-select-framework () - "Select the log framework." - (let ((frameworks (cider-sync-request:log-frameworks))) - (cond ((= 1 (length frameworks)) - (car frameworks)) - (t (let ((name (cider-log--read-framework-name))) - (cider-log-framework-by-name frameworks name)))))) - -(defun cider-log--current-framework () - "Return the log framework by the name bound to `cider-log-framework-name'." - (when cider-log-framework-name - (let ((frameworks (cider-sync-request:log-frameworks))) - (cider-log-framework-by-name frameworks cider-log-framework-name)))) - -(defun cider-log--framework () - "Return the current log framework, or select it." - (or (cider-log--current-framework) (cider-log-select-framework))) - -(defun cider-log--appender () - "Return the current log appender." - (when cider-log-appender-id - (nrepl-dict "id" cider-log-appender-id - "filters" (cider-log--filters) - "size" cider-log-appender-size - "threshold" cider-log-appender-threshold))) - -(defun cider-log--consumer () - "Return the current log consumer." - (let ((consumer (nrepl-dict "filters" (cider-log--filters)))) - (when cider-log-consumer - (nrepl-dict-put consumer "id" (cider-log-consumer-id cider-log-consumer))) - consumer)) - -(defun cider-log--event-options () - "Return the current log consumer." - (nrepl-dict "filters" (cider-log--filters) - "limit" cider-log-pagination-limit - "offset" cider-log-pagination-offset)) - -(defun cider-log--filters () - "Return the log event filters." - (nrepl-dict - "end-time" cider-log--end-time-filter - "exceptions" cider-log--exceptions-filter - "level" cider-log--level-filter - "loggers" cider-log--loggers-filter - "pattern" cider-log--pattern-filter - "start-time" cider-log--start-time-filter - "threads" cider-log--threads-filter)) - -(defun cider-log-event-at-point () - "Return the log event at point." - (get-text-property (point) :cider-log-event)) - -(defun cider-log-info () - "Show the current log buffer, framework, appender and consumer." - (interactive) - (message "%s" - (string-join - (list (when cider-log-buffer - (format "Buffer: %s" (cider-log--bold cider-log-buffer))) - (when cider-log-framework-name - (format "Framework: %s" (cider-log--bold cider-log-framework-name))) - (when cider-log-appender-id - (format "Appender: %s" (cider-log--bold cider-log-appender-id))) - (when-let (id (and cider-log-consumer (cider-log-consumer-id cider-log-consumer))) - (format "Consumer: %s" (cider-log--bold id)))) - " "))) - -;; Major mode - -(defvar cider-log-mode-map - (let ((map (make-sparse-keymap)) - (parent (if cider-log-use-logview logview-mode-map special-mode-map))) - (set-keymap-parent map parent) - (define-key map (kbd "C-c M-l a") #'cider-log-appender) - (define-key map (kbd "C-c M-l c") #'cider-log-consumer) - (define-key map (kbd "C-c M-l e") #'cider-log-event) - (define-key map (kbd "C-c M-l f") #'cider-log-framework) - (define-key map (kbd "C-c M-l i") #'cider-log-info) - (define-key map (kbd "C-c M-l l") #'cider-log) - (define-key map (kbd "E") 'cider-log-show-stacktrace) - (define-key map (kbd "F") 'cider-log-print-event) - (define-key map (kbd "I") 'cider-log-inspect-event) - (define-key map (kbd "RET") 'cider-log-inspect-event) - (define-key map (kbd "n") 'cider-log-event-next-line) - (define-key map (kbd "p") 'cider-log-event-previous-line) - map) - "The Cider log stream mode key map.") - -(defun cider-log--setup-mode () - "Setup CIDER log mode." - (use-local-map cider-log-mode-map) - (setq-local electric-indent-chars nil) - (setq-local logview-show-ellipses nil) - (setq-local sesman-system 'CIDER) - (setq-local truncate-lines t) - (when (fboundp 'evil-set-initial-state) - (evil-set-initial-state 'cider-log-mode 'emacs))) - -(defvar cider-log--mode-doc - "Major mode for inspecting Clojure log events. - -CIDER Log Mode allows you to capture, debug, inspect and view log events -emitted by Java logging frameworks. The captured log events can be -searched, streamed to the client, pretty printed and are integrated with -the CIDER Inspector and the CIDER stacktrace mode. - -\\{cider-log-mode-map}") - -(if cider-log-use-logview - (define-derived-mode cider-log-mode logview-mode "Cider Log" cider-log--mode-doc - (cider-log--setup-mode)) - (define-derived-mode cider-log-mode special-mode "Cider Log" cider-log--mode-doc - (cider-log--setup-mode))) - -;; Transient Lisp Variable - -(defclass cider-log--lisp-variable (transient-lisp-variable) ()) - -(cl-defmethod transient-init-value ((obj cider-log--lisp-variable)) - "Set the initial value of the object OBJ." - (let* ((prefix-value (oref transient--prefix value)) - (value (cdr (assoc (oref obj variable) prefix-value))) - (new-value (if (assoc (oref obj variable) prefix-value) - value - (symbol-value (oref obj variable))))) - (funcall (oref obj set-value) - (oref obj variable) - (oset obj value new-value)))) - -(cl-defmethod transient-infix-set ((obj cider-log--lisp-variable) value) - "Set the value of infix object OBJ to VALUE." - (funcall (oref obj set-value) - (oref obj variable) - (oset obj value value))) - -(cl-defmethod transient-infix-value ((obj cider-log--lisp-variable)) - "Return the value of the suffix object OBJ." - (cons (oref obj variable) (oref obj value))) - -(cl-defmethod transient-format-value ((obj cider-log--lisp-variable)) - "Format OBJ's value for display and return the result." - (propertize (prin1-to-string (oref obj value)) - 'face 'transient-value)) - -(cl-defmethod transient-format-value ((obj cider-log--lisp-variable)) - "Format OBJ's value for display and return the result." - (cider-log--format-value (oref obj value))) - -;; Transient options - -(transient-define-infix cider-log--appender-size-option () - :always-read t - :argument "--size=" - :class 'cider-log--lisp-variable - :description "Appender size" - :key "=s" - :prompt "Size: " - :reader #'cider-log--read-number-N+ - :variable 'cider-log-appender-size) - -(transient-define-infix cider-log--appender-threshold-option () - :always-read t - :argument "--threshold=" - :class 'cider-log--lisp-variable - :description "Appender threshold" - :key "=t" - :prompt "Threshold: " - :reader #'cider-log--read-number-N+ - :variable 'cider-log-appender-threshold) - -(transient-define-infix cider-log--buffer-option () - :always-read t - :class 'cider-log--lisp-variable - :description "Buffer" - :key "=b" - :prompt "Log buffer: " - :reader #'cider-log--read-buffer - :variable 'cider-log-buffer) - -(transient-define-infix cider-log--end-time-option () - :argument "--end-time=" - :class 'cider-log--lisp-variable - :description "Filter by end time" - :key "-e" - :prompt "End time: " - :reader #'cider-log--read-time - :variable 'cider-log--end-time-filter) - -(transient-define-infix cider-log--exceptions-option () - :argument "--exceptions=" - :class 'cider-log--lisp-variable - :description "Filter by exceptions" - :key "-E" - :multi-value t - :prompt "Exceptions: " - :reader #'cider-log--read-exceptions - :variable 'cider-log--exceptions-filter) - -(transient-define-infix cider-log--level-option () - :argument "--level=" - :class 'cider-log--lisp-variable - :description "Filter by level" - :key "-l" - :prompt "Log Level: " - :reader #'cider-log--read-level - :variable 'cider-log--level-filter) - -(transient-define-infix cider-log--limit-option () - :always-read t - :argument "--limit=" - :class 'cider-log--lisp-variable - :description "Limit" - :key "=l" - :prompt "Limit: " - :reader #'cider-log--read-number-N+ - :variable 'cider-log-pagination-limit) - -(transient-define-infix cider-log--logger-option () - :argument "--loggers=" - :class 'cider-log--lisp-variable - :description "Filter by loggers" - :key "-L" - :multi-value t - :prompt "Loggers: " - :reader #'cider-log--read-loggers - :variable 'cider-log--loggers-filter) - -(transient-define-infix cider-log--offset-option () - :always-read t - :argument "--offset=" - :class 'cider-log--lisp-variable - :description "Offset" - :key "=o" - :prompt "Offset: " - :reader #'cider-log--read-number-N0 - :variable 'cider-log-pagination-offset) - -(transient-define-infix cider-log--pattern-option () - :argument "--pattern=" - :class 'cider-log--lisp-variable - :description "Filter by regex pattern" - :key "-r" - :prompt "Regex pattern: " - :reader #'read-string - :variable 'cider-log--pattern-filter) - -(transient-define-infix cider-log--start-time-option () - :argument "--start-time=" - :class 'cider-log--lisp-variable - :description "Filter by start time" - :key "-s" - :prompt "Start time: " - :reader #'cider-log--read-time - :variable 'cider-log--start-time-filter) - -(transient-define-infix cider-log--threads-option () - :argument "--threads=" - :class 'cider-log--lisp-variable - :description "Filter by threads" - :key "-t" - :multi-value t - :prompt "Threads: " - :reader #'cider-log--read-threads - :variable 'cider-log--threads-filter) - -;; Framework actions - -(transient-define-suffix cider-log-browse-javadocs (framework) - "Browse the Javadoc of the log FRAMEWORK." - :description "Browse Java documentation" - (interactive (list (cider-log--framework))) - (browse-url (or (cider-log-framework-javadoc-url framework) - (user-error (format "The %s framework does not have Javadocs." - (cider-log-framework-name framework)))))) - -(transient-define-suffix cider-log-browse-website (framework) - "Browse the website of the log FRAMEWORK." - :description "Browse website" - (interactive (list (cider-log--framework))) - (browse-url (or (cider-log-framework-website-url framework) - (user-error (format "The %s framework does not have a website." - (cider-log-framework-name framework)))))) - -(transient-define-suffix cider-log-set-framework (framework-name) - "Set the current log framework to FRAMEWORK-NAME." - :description #'cider-log--description-set-framework - (interactive (list (cider-log--read-framework-name))) - (setq cider-log-framework-name framework-name)) - -(transient-define-suffix cider-log-set-buffer (buffer) - "Set the current log buffer to BUFFER." - :description #'cider-log--description-set-buffer - (interactive (list (cider-log--read-buffer))) - (setq cider-log-buffer buffer)) - -;; Appender actions - -(transient-define-suffix cider-log-clear-appender (framework appender) - "Clear the log events of the APPENDER of FRAMEWORK." - :description "Clear log appender" - :inapt-if-not #'cider-log-appender-attached-p - (interactive (list (cider-log--framework) (cider-log--appender))) - (cider-sync-request:log-clear framework appender) - (message "Cleared the %s log appender of the %s framework." - (cider-log-appender-display-name appender) - (cider-log-framework-display-name framework))) - -(transient-define-suffix cider-log-kill-appender (framework appender) - "Remove the log APPENDER from FRAMEWORK." - :description "Kill log appender" - :inapt-if-not #'cider-log-appender-attached-p - (interactive (list (cider-log--framework) (cider-log--appender))) - (cider-sync-request:log-remove-appender framework appender) - (setq-local cider-log-consumer nil) - (message "Log appender %s removed from the %s framework." - (cider-log-framework-display-name framework) - (cider-log-appender-display-name appender))) - -(transient-define-suffix cider-log--do-add-appender (framework appender) - "Add the APPENDER to the log FRAMEWORK." - :description "Add log appender" - :inapt-if #'cider-log-appender-attached-p - (interactive (list (cider-log--framework) (cider-log--appender))) - (setq cider-log-appender (cider-sync-request:log-add-appender framework appender)) - (message "Log appender %s added to the %s framework." - (cider-log-appender-display-name appender) - (cider-log-framework-display-name framework))) - -(transient-define-suffix cider-log--do-update-appender (framework appender) - "Update the APPENDER of the log FRAMEWORK." - :description "Update log appender" - :inapt-if-not #'cider-log-appender-attached-p - (interactive (list (cider-log--framework) (cider-log--appender))) - (setq cider-log-appender (cider-sync-request:log-update-appender framework appender)) - (message "Updated log appender %s of the %s framework." - (cider-log-appender-display-name appender) - (cider-log-framework-display-name framework))) - -;; Consumer actions - -(transient-define-suffix cider-log--do-add-consumer (framework appender consumer buffer) - "Add the CONSUMER to the APPENDER of the log FRAMEWORK and write events to BUFFER." - :description "Add log consumer" - :inapt-if #'cider-log-consumer-attached-p - (interactive (list (cider-log--framework) - (cider-log--appender) - (cider-log--consumer) - (current-buffer))) - (cider-log--consumer-add framework appender consumer buffer)) - -(transient-define-suffix cider-log-kill-consumer (framework appender consumer) - "Remove the CONSUMER listening to the APPENDER of the log FRAMEWORK." - :description "Kill log consumer" - :inapt-if-not #'cider-log-consumer-attached-p - (interactive (list (cider-log--framework) (cider-log--appender) (cider-log--consumer))) - (cider-sync-request:log-remove-consumer framework appender consumer) - (setq-local cider-log-consumer nil) - (message "Removed %s log consumer %s for appender %s." - (cider-log-framework-display-name framework) - (cider-log-consumer-display-name consumer) - (cider-log-appender-display-name appender))) - -(transient-define-suffix cider-log--do-update-consumer (framework appender consumer) - "Update the CONSUMER listening to the APPENDER of the log FRAMEWORK." - :description "Update log consumer" - :inapt-if-not #'cider-log-consumer-attached-p - (interactive (list (cider-log--framework) - (cider-log--appender) - (cider-log--consumer))) - (setq cider-log-consumer (cider-sync-request:log-update-consumer framework appender consumer)) - (message "Updated %s log consumer %s for appender %s." - (cider-log-framework-display-name framework) - (cider-log-consumer-display-name consumer) - (cider-log-appender-display-name appender))) - -;; Event actions - -(transient-define-suffix cider-log-show-stacktrace (framework appender event) - "Show the stacktrace of the log EVENT of FRAMEWORK and APPENDER." - :description "Show log event stacktrace" - :if #'cider-log-event-at-point - :inapt-if-not (lambda () - (when-let (event (cider-log-event-at-point)) - (cider-log-event-exception event))) - (interactive (list (cider-log--framework) (cider-log--appender) (cider-log-event-at-point))) - (cider-log-event--show-stacktrace framework appender event)) - -(transient-define-suffix cider-log-print-event (framework appender event) - "Format the log EVENT of FRAMEWORK and APPENDER." - :description "Pretty print log event at point" - :if #'cider-log-event-at-point - (interactive (list (cider-log--framework) (cider-log--appender) (cider-log-event-at-point))) - (if event - (cider-log-event--pretty-print framework appender event) - (user-error "No log event found at point"))) - -(transient-define-suffix cider-log-inspect-event (framework appender event) - "Inspect the log EVENT of FRAMEWORK and APPENDER." - :description "Inspect log event at point" - :if #'cider-log-event-at-point - (interactive (list (cider-log--framework) (cider-log--appender) (cider-log-event-at-point))) - (cider-log-event--inspect framework appender event)) - -(transient-define-suffix cider-log-clear-event-buffer (buffer) - "Clear the Cider log events in BUFFER." - :description #'cider-log--description-clear-events-buffer - :inapt-if-not #'cider-log-buffer-clear-p - (interactive (list cider-log-buffer)) - (when (get-buffer buffer) - (with-current-buffer buffer - (let ((inhibit-read-only t)) - (erase-buffer))))) - -(transient-define-suffix cider-log-switch-to-buffer (buffer) - "Switch to the Cider log event BUFFER." - :description "Switch to the log event buffer" - (interactive (list cider-log-buffer)) - (when (get-buffer-create buffer) - (switch-to-buffer-other-window buffer))) - -(transient-define-suffix cider-log--do-search-events (framework appender filters) - "Search the log events of FRAMEWORK and APPENDER which match FILTERS." - :description "Search log events" - :inapt-if-not #'cider-log-appender-attached-p - (interactive (list (cider-log--framework) (cider-log--appender) (cider-log--filters))) - (with-current-buffer (get-buffer-create cider-log-buffer) - (let ((consumer (nrepl-dict "filters" (cider-log--filters))) - (inhibit-read-only t)) - (cider-log--remove-current-buffer-consumer) - (erase-buffer) - (let ((events (cider-sync-request:log-search - framework appender - :filters filters - :limit cider-log-pagination-limit - :offset cider-log-pagination-offset))) - (seq-doseq (event (nreverse events)) - (insert (cider-log-event--format-logback event))) - (cider-log-mode) - (setq-local cider-log-framework framework) - (setq-local cider-log-appender appender) - (when (seq-empty-p events) - (message "No log events found.")) - (cider-log--consumer-add framework appender consumer (current-buffer)))))) - -;; Log Framework Transient - -;;;###autoload (autoload 'cider-log-framework "cider-log" "Show the Cider log framework menu." t) -(transient-define-prefix cider-log-framework (framework) - "Show the Cider log framework menu." - [["Cider Log Framework\n\nActions:" - ("b" cider-log-set-buffer) - ("j" cider-log-browse-javadocs) - ("s" cider-log-set-framework) - ("w" cider-log-browse-website)]] - (interactive (list (cider-log--framework))) - (cider-log--ensure-initialized framework) - (transient-setup 'cider-log-framework)) - -;; Log Appender Transients - -(defun cider-log--appender-interactive-list () - "Return the interactive arguments for a appender transient." - (let ((framework (cider-log--current-framework))) - (list framework (cider-log-framework-appender framework cider-log-appender-id)))) - -(transient-define-prefix cider-log-add-appender (framework appender) - "Show the menu to add a Cider log appender." - :history-key 'cider-log-appender - ["Cider Log Appender\n\nSettings:" - (cider-log--appender-size-option) - (cider-log--appender-threshold-option)] - ["Filters:" - (cider-log--end-time-option) - (cider-log--exceptions-option) - (cider-log--level-option) - (cider-log--logger-option) - (cider-log--pattern-option) - (cider-log--start-time-option) - (cider-log--threads-option)] - ["Actions" - ("a" cider-log--do-add-appender)] - (interactive (cider-log--appender-interactive-list)) - (cider-log--ensure-initialized framework appender) - (transient-setup 'cider-log-add-appender)) - -(transient-define-prefix cider-log-update-appender (framework appender) - "Show the menu to update a Cider log appender." - :history-key 'cider-log-appender - ["Cider Log Appender\n\nSettings:" - (cider-log--appender-size-option) - (cider-log--appender-threshold-option)] - ["Filters:" - (cider-log--end-time-option) - (cider-log--exceptions-option) - (cider-log--level-option) - (cider-log--logger-option) - (cider-log--pattern-option) - (cider-log--start-time-option) - (cider-log--threads-option)] - ["Actions" - ("u" cider-log--do-update-appender)] - (interactive (cider-log--appender-interactive-list)) - (cider-log--ensure-initialized framework appender) - (transient-setup 'cider-log-update-appender)) - -;;;###autoload (autoload 'cider-log-appender "cider-log" "Show the Cider log appender menu." t) -(transient-define-prefix cider-log-appender (framework appender) - "Show the Cider log appender menu." - :history-key 'cider-log-appender - ["Cider Log Appender\n\nSettings:" - (cider-log--appender-size-option) - (cider-log--appender-threshold-option)] - ["Filters:" - (cider-log--end-time-option) - (cider-log--exceptions-option) - (cider-log--level-option) - (cider-log--logger-option) - (cider-log--pattern-option) - (cider-log--start-time-option) - (cider-log--threads-option)] - ["Actions" - ("a" cider-log--do-add-appender) - ("c" cider-log-clear-appender) - ("k" cider-log-kill-appender) - ("u" cider-log--do-update-appender)] - (interactive (cider-log--appender-interactive-list)) - (cider-log--ensure-initialized framework appender) - (transient-setup 'cider-log-appender)) - -;; Log Consumer Transient Menu - -(defun cider-log--consumer-interactive-list () - "Return the interactive arguments for a consumer transient." - (let* ((framework (cider-log--current-framework)) - (appender (cider-log-framework-appender framework cider-log-appender-id))) - (list framework appender - (if (and appender cider-log-consumer) - (seq-find (lambda (consumer) - (equal (cider-log-consumer-id cider-log-consumer) - (cider-log-consumer-id consumer))) - (cider-log-appender-consumers appender)) - (nrepl-dict "filters" (cider-log--filters)))))) - -(transient-define-prefix cider-log-add-consumer (framework appender consumer) - "Show the menu to add a Cider log consumer." - :history-key 'cider-log-consumer - ["Cider Log Consumer\n\nFilters:" - (cider-log--end-time-option) - (cider-log--exceptions-option) - (cider-log--level-option) - (cider-log--logger-option) - (cider-log--pattern-option) - (cider-log--start-time-option) - (cider-log--threads-option)] - ["Actions" - ("a" cider-log--do-add-consumer)] - (interactive (cider-log--consumer-interactive-list)) - (cider-log--ensure-initialized framework appender consumer) - (transient-setup 'cider-log-add-consumer)) - -(transient-define-prefix cider-log-update-consumer (framework appender consumer) - "Show the menu to update a Cider log consumer." - :history-key 'cider-log-consumer - ["Cider Log Consumer\n\nFilters:" - (cider-log--end-time-option) - (cider-log--exceptions-option) - (cider-log--level-option) - (cider-log--logger-option) - (cider-log--pattern-option) - (cider-log--start-time-option) - (cider-log--threads-option)] - ["Actions" - ("u" cider-log--do-update-consumer)] - (interactive (cider-log--consumer-interactive-list)) - (cider-log--ensure-initialized framework appender consumer) - (transient-setup 'cider-log-update-consumer)) - -;;;###autoload (autoload 'cider-log-consumer "cider-log" "Show the Cider log consumer menu." t) -(transient-define-prefix cider-log-consumer (framework appender consumer) - "Show the Cider log consumer menu." - :history-key 'cider-log-consumer - ["Cider Log Consumer\n\nFilters:" - (cider-log--end-time-option) - (cider-log--exceptions-option) - (cider-log--level-option) - (cider-log--logger-option) - (cider-log--pattern-option) - (cider-log--start-time-option) - (cider-log--threads-option)] - ["Actions" - ("a" cider-log--do-add-consumer) - ("k" cider-log-kill-consumer) - ("u" cider-log--do-update-consumer)] - (interactive (cider-log--consumer-interactive-list)) - (cider-log--ensure-initialized framework appender consumer) - (transient-setup 'cider-log-consumer)) - -;; Log Event Transient Menu - -(transient-define-prefix cider-log-event-search (framework appender) - "Search the search log events menu." - :history-key 'cider-log-event - ["Cider Log Event\n\nPagination:" - (cider-log--limit-option) - (cider-log--offset-option)] - ["Filters:" - (cider-log--end-time-option) - (cider-log--exceptions-option) - (cider-log--level-option) - (cider-log--logger-option) - (cider-log--pattern-option) - (cider-log--start-time-option) - (cider-log--threads-option)] - ["Actions" - ("s" cider-log--do-search-events)] - (interactive (list (cider-log--framework) (cider-log--appender))) - (cider-log--ensure-initialized framework appender) - (transient-setup 'cider-log-event-search)) - -;;;###autoload (autoload 'cider-log-event "cider-log" "Show the Cider log event menu." t) -(transient-define-prefix cider-log-event (framework appender) - "Show the Cider log event menu." - :history-key 'cider-log-event - ["Cider Log Event\n\nPagination:" - (cider-log--limit-option) - (cider-log--offset-option)] - ["Filters:" - (cider-log--end-time-option) - (cider-log--exceptions-option) - (cider-log--level-option) - (cider-log--logger-option) - (cider-log--pattern-option) - (cider-log--start-time-option) - (cider-log--threads-option)] - ["Actions" - ("c" cider-log-clear-event-buffer) - ("e" cider-log-show-stacktrace) - ("i" cider-log-inspect-event) - ("p" cider-log-print-event) - ("s" cider-log--do-search-events)] - (interactive (list (cider-log--framework) (cider-log--appender))) - (cider-log--ensure-initialized framework appender) - (transient-setup 'cider-log-event)) - -;; Main Transient Menu - -;;;###autoload (autoload 'cider-log "cider-log" "Show the Cider log menu." t) -(transient-define-prefix cider-log (framework appender) - "Show the Cider log menu." - [["Framework Actions" - ("fs" cider-log-set-framework) - ("fb" cider-log-set-buffer) - ("fj" cider-log-browse-javadocs) - ("fw" cider-log-browse-website)] - ["Appender Actions" - ("aa" "Add log appender" cider-log-add-appender - :inapt-if cider-log-appender-attached-p) - ("ac" cider-log-clear-appender) - ("ak" cider-log-kill-appender) - ("am" "Manage appender" cider-log-appender) - ("au" "Update log appender" cider-log-update-appender - :inapt-if-not cider-log-appender-attached-p)] - ["Consumer Actions" - ("ca" "Add log consumer" cider-log-add-consumer - :inapt-if cider-log-consumer-attached-p) - ("ck" cider-log-kill-consumer) - ("cm" "Manage consumer" cider-log-consumer) - ("cu" "Update log consumer" cider-log-update-consumer - :inapt-if-not cider-log-consumer-attached-p)] - ["Event Actions" - ("eb" cider-log-switch-to-buffer) - ("ec" cider-log-clear-event-buffer) - ("ee" cider-log-show-stacktrace) - ("ei" cider-log-inspect-event) - ("ep" cider-log-print-event) - ("es" "Search log events" cider-log-event-search - :inapt-if-not cider-log-appender-attached-p)]] - (interactive (list (cider-log--framework) (cider-log--appender))) - (cider-log--ensure-initialized framework appender) - (transient-setup 'cider-log)) - -(add-hook 'kill-buffer-hook #'cider-log-kill-buffer-hook-handler) - -(provide 'cider-log) - -;;; cider-log.el ends here diff --git a/elpa/cider-20230707.640/cider-macroexpansion.el b/elpa/cider-20230707.640/cider-macroexpansion.el deleted file mode 100644 index 6e4c52a8..00000000 --- a/elpa/cider-20230707.640/cider-macroexpansion.el +++ /dev/null @@ -1,201 +0,0 @@ -;;; cider-macroexpansion.el --- Macro expansion support -*- lexical-binding: t -*- - -;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Tim King -;; Phil Hagelberg -;; Bozhidar Batsov -;; Artur Malabarba -;; Hugo Duncan -;; Steve Purcell - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Macro expansion support. - -;;; Code: - -(require 'cider-mode) -(require 'subr-x) - -(defconst cider-macroexpansion-buffer "*cider-macroexpansion*") - -(defcustom cider-macroexpansion-display-namespaces 'tidy - "Determines if namespaces are displayed in the macroexpansion buffer. -Possible values are: - - 'qualified ;=> Vars are fully-qualified in the expansion - 'none ;=> Vars are displayed without namespace qualification - 'tidy ;=> Vars that are :refer-ed or defined in the current namespace are - displayed with their simple name, non-referred vars from other - namespaces are referred using the alias for that namespace (if - defined), other vars are displayed fully qualified." - :type '(choice (const :tag "Suppress namespaces" none) - (const :tag "Show fully-qualified namespaces" qualified) - (const :tag "Show namespace aliases" tidy)) - :group 'cider - :package-version '(cider . "0.7.0")) - -(defcustom cider-macroexpansion-print-metadata nil - "Determines if metadata is included in macroexpansion results." - :type 'boolean - :group 'cider - :package-version '(cider . "0.9.0")) - -(defun cider-sync-request:macroexpand (expander expr &optional display-namespaces) - "Macroexpand, using EXPANDER, the given EXPR. -The default for DISPLAY-NAMESPACES is taken from -`cider-macroexpansion-display-namespaces'." - (cider-ensure-op-supported "macroexpand") - (thread-first `("op" "macroexpand" - "expander" ,expander - "code" ,expr - "ns" ,(cider-current-ns) - "display-namespaces" ,(or display-namespaces - (symbol-name cider-macroexpansion-display-namespaces))) - (nconc (when cider-macroexpansion-print-metadata - '("print-meta" "true"))) - (cider-nrepl-send-sync-request) - (nrepl-dict-get "expansion"))) - -(defun cider-macroexpand-undo (&optional arg) - "Undo the last macroexpansion, using `undo-only'. -ARG is passed along to `undo-only'." - (interactive) - (let ((inhibit-read-only t)) - (undo-only arg))) - -(defvar cider-last-macroexpand-expression nil - "Specify the last macroexpansion performed. -This variable specifies both what was expanded and the expander.") - -(defun cider-macroexpand-expr (expander expr) - "Macroexpand, use EXPANDER, the given EXPR." - (when-let* ((expansion (cider-sync-request:macroexpand expander expr))) - (setq cider-last-macroexpand-expression expr) - (cider-initialize-macroexpansion-buffer expansion (cider-current-ns)))) - -(defun cider-macroexpand-expr-inplace (expander) - "Substitute the form preceding point with its macroexpansion using EXPANDER." - (interactive) - (let* ((expansion (cider-sync-request:macroexpand expander (cider-last-sexp))) - (bounds (cons (save-excursion (clojure-backward-logical-sexp 1) (point)) (point)))) - (cider-redraw-macroexpansion-buffer - expansion (current-buffer) (car bounds) (cdr bounds)))) - -(defun cider-macroexpand-again () - "Repeat the last macroexpansion." - (interactive) - (cider-initialize-macroexpansion-buffer cider-last-macroexpand-expression (cider-current-ns))) - -;;;###autoload -(defun cider-macroexpand-1 (&optional prefix) - "Invoke \\=`macroexpand-1\\=` on the expression preceding point. -If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of -\\=`macroexpand-1\\=`." - (interactive "P") - (let ((expander (if prefix "macroexpand" "macroexpand-1"))) - (cider-macroexpand-expr expander (cider-last-sexp)))) - -(defun cider-macroexpand-1-inplace (&optional prefix) - "Perform inplace \\=`macroexpand-1\\=` on the expression preceding point. -If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of -\\=`macroexpand-1\\=`." - (interactive "P") - (let ((expander (if prefix "macroexpand" "macroexpand-1"))) - (cider-macroexpand-expr-inplace expander))) - -;;;###autoload -(defun cider-macroexpand-all () - "Invoke \\=`macroexpand-all\\=` on the expression preceding point." - (interactive) - (cider-macroexpand-expr "macroexpand-all" (cider-last-sexp))) - -(defun cider-macroexpand-all-inplace () - "Perform inplace \\=`macroexpand-all\\=` on the expression preceding point." - (interactive) - (cider-macroexpand-expr-inplace "macroexpand-all")) - -(defun cider-initialize-macroexpansion-buffer (expansion ns) - "Create a new Macroexpansion buffer with EXPANSION and namespace NS." - (pop-to-buffer (cider-create-macroexpansion-buffer)) - (setq cider-buffer-ns ns) - (setq buffer-undo-list nil) - (let ((inhibit-read-only t) - (buffer-undo-list t)) - (erase-buffer) - (insert (format "%s" expansion)) - (goto-char (point-max)) - (font-lock-ensure))) - -(defun cider-redraw-macroexpansion-buffer (expansion buffer start end) - "Redraw the macroexpansion with new EXPANSION. -Text in BUFFER from START to END is replaced with new expansion, -and point is placed after the expanded form." - (with-current-buffer buffer - (let ((buffer-read-only nil)) - (goto-char start) - (delete-region start end) - (insert (format "%s" expansion)) - (goto-char start) - (indent-sexp) - (forward-sexp)))) - -(declare-function cider-mode "cider-mode") - -(defun cider-create-macroexpansion-buffer () - "Create a new macroexpansion buffer." - (with-current-buffer (cider-popup-buffer cider-macroexpansion-buffer 'select 'clojure-mode 'ancillary) - (cider-mode -1) - (cider-macroexpansion-mode 1) - (current-buffer))) - -(declare-function cider-find-var "cider-find") - -(defvar cider-macroexpansion-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "g") #'cider-macroexpand-again) - (define-key map (kbd "q") #'cider-popup-buffer-quit-function) - (define-key map (kbd "d") #'cider-doc) - (define-key map (kbd "j") #'cider-javadoc) - (define-key map (kbd ".") #'cider-find-var) - (define-key map (kbd "m") #'cider-macroexpand-1-inplace) - (define-key map (kbd "a") #'cider-macroexpand-all-inplace) - (define-key map (kbd "u") #'cider-macroexpand-undo) - (define-key map [remap undo] #'cider-macroexpand-undo) - (easy-menu-define cider-macroexpansion-mode-menu map - "Menu for CIDER's doc mode" - '("Macroexpansion" - ["Restart expansion" cider-macroexpand-again] - ["Macroexpand-1" cider-macroexpand-1-inplace] - ["Macroexpand-all" cider-macroexpand-all-inplace] - ["Macroexpand-undo" cider-macroexpand-undo] - ["Go to source" cider-find-var] - ["Go to doc" cider-doc] - ["Go to Javadoc" cider-docview-javadoc] - ["Quit" cider-popup-buffer-quit-function])) - map)) - -(define-minor-mode cider-macroexpansion-mode - "Minor mode for CIDER macroexpansion." - :lighter " Macroexpand") - -(provide 'cider-macroexpansion) - -;;; cider-macroexpansion.el ends here diff --git a/elpa/cider-20230707.640/cider-mode.el b/elpa/cider-20230707.640/cider-mode.el deleted file mode 100644 index bfedce90..00000000 --- a/elpa/cider-20230707.640/cider-mode.el +++ /dev/null @@ -1,1098 +0,0 @@ -;;; cider-mode.el --- Minor mode for REPL interactions -*- lexical-binding: t -*- - -;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Tim King -;; Phil Hagelberg -;; Bozhidar Batsov -;; Artur Malabarba -;; Hugo Duncan -;; Steve Purcell - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Minor mode for REPL interactions. - -;;; Code: - -(require 'clojure-mode) -(require 'cider-eval) -(require 'cider-log) -(require 'cider-test) ; required only for the menu -(require 'cider-eldoc) -(require 'cider-resolve) -(require 'cider-doc) ; required only for the menu -(require 'cider-profile) ; required only for the menu -(require 'cider-completion) -(require 'cider-inspector) -(require 'cider-find) -(require 'subr-x) - -(defcustom cider-mode-line-show-connection t - "If the mode-line lighter should detail the connection." - :group 'cider - :type 'boolean - :package-version '(cider "0.10.0")) - -(defun cider--modeline-info () - "Return info for the cider mode modeline. -Info contains the connection type, project name and host:port endpoint." - (if-let* ((current-connection (ignore-errors (cider-current-repl)))) - (with-current-buffer current-connection - (concat - (symbol-name cider-repl-type) - (when cider-mode-line-show-connection - (format ":%s@%s:%s" - (or (cider--project-name nrepl-project-dir) "") - (pcase (plist-get nrepl-endpoint :host) - ("localhost" "") - (x x)) - (plist-get nrepl-endpoint :port))))) - "not connected")) - -;;;###autoload -(defcustom cider-mode-line - '(:eval (format " cider[%s]" (cider--modeline-info))) - "Mode line lighter for cider mode. - -The value of this variable is a mode line template as in -`mode-line-format'. See Info Node `(elisp)Mode Line Format' for details -about mode line templates. - -Customize this variable to change how cider mode displays its status in the -mode line. The default value displays the current connection. Set this -variable to nil to disable the mode line entirely." - :group 'cider - :type 'sexp - :risky t - :package-version '(cider "0.7.0")) - - -;;; Switching between REPL & source buffers - -(defun cider--switch-to-repl-buffer (repl-buffer &optional set-namespace) - "Select the REPL-BUFFER, when possible in an existing window. -When SET-NAMESPACE is t, sets the namespace in the REPL buffer to -that of the namespace in the Clojure source buffer." - (let ((buffer (current-buffer))) - ;; first we switch to the REPL buffer - (if cider-repl-display-in-current-window - (pop-to-buffer-same-window repl-buffer) - (pop-to-buffer repl-buffer)) - ;; then if necessary we update its namespace - (when set-namespace - (cider-repl-set-ns (with-current-buffer buffer (cider-current-ns)))) - (goto-char (point-max)))) - -(defun cider-switch-to-repl-buffer (&optional set-namespace) - "Switch to current REPL buffer, when possible in an existing window. -The type of the REPL is inferred from the mode of current buffer. With a -prefix arg SET-NAMESPACE sets the namespace in the REPL buffer to that of -the namespace in the Clojure source buffer" - (interactive "P") - (cider--switch-to-repl-buffer - (cider-current-repl nil 'ensure) - set-namespace)) - -(declare-function cider-load-buffer "cider-eval") - -(defun cider-load-buffer-and-switch-to-repl-buffer (&optional set-namespace) - "Load the current buffer into the matching REPL buffer and switch to it. -When SET-NAMESPACE is true, we'll also set the REPL's ns to match that of the -Clojure buffer." - (interactive "P") - (cider-load-buffer) - (cider-switch-to-repl-buffer set-namespace)) - -(defun cider-switch-to-last-clojure-buffer () - "Switch to the last Clojure buffer. -The default keybinding for this command is -the same as variable `cider-switch-to-repl-buffer', -so that it is very convenient to jump between a -Clojure buffer and the REPL buffer." - (interactive) - (if (derived-mode-p 'cider-repl-mode) - (let* ((a-buf) - (the-buf (let ((repl-type (cider-repl-type-for-buffer))) - (seq-find (lambda (b) - (unless (with-current-buffer b (derived-mode-p 'cider-repl-mode)) - (when-let* ((type (cider-repl-type-for-buffer b))) - (unless a-buf - (setq a-buf b)) - (or (eq type 'multi) - (eq type repl-type))))) - (buffer-list))))) - (if-let* ((buf (or the-buf a-buf))) - (if cider-repl-display-in-current-window - (pop-to-buffer-same-window buf) - (pop-to-buffer buf)) - (user-error "No Clojure buffer found"))) - (user-error "Not in a CIDER REPL buffer"))) - -(defun cider-find-and-clear-repl-output (&optional clear-repl) - "Find the current REPL buffer and clear it. -With a prefix argument CLEAR-REPL the command clears the entire REPL -buffer. Returns to the buffer in which the command was invoked. See also -the related commands `cider-repl-clear-buffer' and -`cider-repl-clear-output'." - (interactive "P") - (let ((origin-buffer (current-buffer))) - (switch-to-buffer (cider-current-repl nil 'ensure)) - (if clear-repl - (cider-repl-clear-buffer) - (cider-repl-clear-output)) - (switch-to-buffer origin-buffer))) - -;;; cider-run -(defvar cider--namespace-history nil - "History of user input for namespace prompts.") - -(defun cider--var-namespace (var) - "Return the namespace of VAR. -VAR is a fully qualified Clojure variable name as a string." - (replace-regexp-in-string "\\(?:#'\\)?\\(.*\\)/.*" "\\1" var)) - -(defun cider-run (&optional function) - "Run -main or FUNCTION, prompting for its namespace if necessary. -With a prefix argument, prompt for function to run instead of -main." - (interactive (list (when current-prefix-arg (read-string "Function name: ")))) - (cider-ensure-connected) - (let ((name (or function "-main"))) - (when-let* ((response (cider-nrepl-send-sync-request - `("op" "ns-list-vars-by-name" - "name" ,name)))) - (if-let* ((vars (split-string (substring (nrepl-dict-get response "var-list") 1 -1)))) - (cider-interactive-eval - (if (= (length vars) 1) - (concat "(" (car vars) ")") - (let* ((completions (mapcar #'cider--var-namespace vars)) - (def (or (car cider--namespace-history) - (car completions)))) - (format "(#'%s/%s)" - (completing-read (format "Namespace (%s): " def) - completions nil t nil - 'cider--namespace-history def) - name)))) - (user-error "No %s var defined in any namespace" (cider-propertize name 'fn)))))) - -;;; Insert (and eval) in REPL functionality -(defvar cider-insert-commands-map - (let ((map (define-prefix-command 'cider-insert-commands-map))) - ;; single key bindings defined last for display in menu - (define-key map (kbd "e") #'cider-insert-last-sexp-in-repl) - (define-key map (kbd "d") #'cider-insert-defun-in-repl) - (define-key map (kbd "r") #'cider-insert-region-in-repl) - (define-key map (kbd "n") #'cider-insert-ns-form-in-repl) - - ;; duplicates with C- for convenience - (define-key map (kbd "C-e") #'cider-insert-last-sexp-in-repl) - (define-key map (kbd "C-d") #'cider-insert-defun-in-repl) - (define-key map (kbd "C-r") #'cider-insert-region-in-repl) - (define-key map (kbd "C-n") #'cider-insert-ns-form-in-repl))) - -(defcustom cider-switch-to-repl-on-insert t - "Whether to switch to the REPL when inserting a form into the REPL." - :type 'boolean - :group 'cider - :package-version '(cider . "0.21.0")) - -(defcustom cider-invert-insert-eval-p nil - "Whether to invert the behavior of evaling. -Default behavior when inserting is to NOT eval the form and only eval with -a prefix. This allows to invert this so that default behavior is to insert -and eval and the prefix is required to prevent evaluation." - :type 'boolean - :group 'cider - :package-version '(cider . "0.18.0")) - -(defun cider-insert-in-repl (form eval) - "Insert FORM in the REPL buffer and switch to it. -If EVAL is non-nil the form will also be evaluated. Use -`cider-invert-insert-eval-p' to invert this behavior." - (while (string-match "\\`[ \t\n\r]+\\|[ \t\n\r]+\\'" form) - (setq form (replace-match "" t t form))) - (when cider-switch-to-repl-on-insert - (cider-switch-to-repl-buffer)) - (let ((repl (cider-current-repl))) - (with-selected-window (or (get-buffer-window repl t) - (selected-window)) - (with-current-buffer repl - (goto-char (point-max)) - (let ((beg (point))) - (insert form) - (indent-region beg (point)) - (font-lock-ensure beg (point))) - (when (if cider-invert-insert-eval-p - (not eval) - eval) - (cider-repl-return)) - (goto-char (point-max)))))) - -(defun cider-insert-last-sexp-in-repl (&optional arg) - "Insert the expression preceding point in the REPL buffer. -If invoked with a prefix ARG eval the expression after inserting it." - (interactive "P") - (cider-insert-in-repl (cider-last-sexp) arg)) - -(defun cider-insert-defun-in-repl (&optional arg) - "Insert the top level form at point in the REPL buffer. -If invoked with a prefix ARG eval the expression after inserting it." - (interactive "P") - (cider-insert-in-repl (cider-defun-at-point) arg)) - -(defun cider-insert-region-in-repl (start end &optional arg) - "Insert the current region in the REPL buffer. -START and END represent the region's boundaries. -If invoked with a prefix ARG eval the expression after inserting it." - (interactive "rP") - (cider-insert-in-repl - (buffer-substring-no-properties start end) arg)) - -(defun cider-insert-ns-form-in-repl (&optional arg) - "Insert the current buffer's ns form in the REPL buffer. -If invoked with a prefix ARG eval the expression after inserting it." - (interactive "P") - (cider-insert-in-repl (cider-ns-form) arg)) - - - -;;; The menu-bar -(defconst cider-mode-menu - `("CIDER" - ["Start or connect to any REPL" cider - :help "A simple wrapper around all commands for starting/connecting to a REPL."] - ("Clojure" - ["Start a Clojure REPL" cider-jack-in - :help "Starts an nREPL server and connects a Clojure REPL to it."] - ["Connect to a Clojure REPL" cider-connect - :help "Connects to a REPL that's already running."]) - ("ClojureScript" - ["Start a ClojureScript REPL" cider-jack-in-cljs - :help "Starts an nREPL server and connects a ClojureScript REPL to it."] - ["Connect to a ClojureScript REPL" cider-connect-clojurescript - :help "Connects to a ClojureScript REPL that's already running."] - ["Create a ClojureScript REPL from a Clojure REPL" cider-jack-in-sibling-clojurescript]) - "--" - ["Quit" cider-quit :active (cider-connected-p)] - ["Restart" cider-restart :active (cider-connected-p)] - "--" - ["Connection info" cider-describe-connection - :active (cider-connected-p)] - ["Select any CIDER buffer" cider-selector] - "--" - ["Configure CIDER" (customize-group 'cider)] - "--" - ["A sip of CIDER" cider-drink-a-sip] - ["View user manual" cider-view-manual] - ["View quick reference card" cider-view-refcard] - ["Report a bug" cider-report-bug] - ["Version info" cider-version] - "--" - ["Close ancillary buffers" cider-close-ancillary-buffers - :active (seq-remove #'null cider-ancillary-buffers)] - ("nREPL" :active (cider-connected-p) - ["List nREPL middleware" cider-list-nrepl-middleware] - ["Describe nREPL session" cider-describe-nrepl-session] - ["Toggle message logging" nrepl-toggle-message-logging])) - "Menu for CIDER mode.") - -(defconst cider-mode-eval-menu - '("CIDER Eval" :visible (cider-connected-p) - ["Eval top-level sexp" cider-eval-defun-at-point] - ["Eval top-level sexp to point" cider-eval-defun-up-to-point] - ["Eval top-level sexp to comment" cider-eval-defun-to-comment] - ["Eval top-level sexp and pretty-print to comment" cider-pprint-eval-defun-to-comment] - "--" - ["Eval current list" cider-eval-list-at-point] - ["Eval current sexp" cider-eval-sexp-at-point] - ["Eval and tap current sexp" cider-tap-sexp-at-point] - ["Eval current sexp to point" cider-eval-sexp-up-to-point] - ["Eval current sexp in context" cider-eval-sexp-at-point-in-context] - "--" - ["Eval last sexp" cider-eval-last-sexp] - ["Eval and tap last sexp" cider-tap-last-sexp] - ["Eval last sexp in context" cider-eval-last-sexp-in-context] - ["Eval last sexp and insert" cider-eval-print-last-sexp - :keys "\\[universal-argument] \\[cider-eval-last-sexp]"] - ["Eval last sexp in popup buffer" cider-pprint-eval-last-sexp] - ["Eval last sexp and replace" cider-eval-last-sexp-and-replace] - ["Eval last sexp to REPL" cider-eval-last-sexp-to-repl] - ["Eval last sexp and pretty-print to REPL" cider-pprint-eval-last-sexp-to-repl] - ["Eval last sexp and pretty-print to comment" cider-pprint-eval-last-sexp-to-comment] - "--" - ["Eval selected region" cider-eval-region] - ["Eval ns form" cider-eval-ns-form] - "--" - ["Interrupt evaluation" cider-interrupt] - "--" - ["Insert last sexp in REPL" cider-insert-last-sexp-in-repl] - ["Insert last sexp in REPL and eval" (cider-insert-last-sexp-in-repl t) - :keys "\\[universal-argument] \\[cider-insert-last-sexp-in-repl]"] - ["Insert top-level sexp in REPL" cider-insert-defun-in-repl] - ["Insert region in REPL" cider-insert-region-in-repl] - ["Insert ns form in REPL" cider-insert-ns-form-in-repl] - "--" - ["Load this buffer" cider-load-buffer] - ["Load this buffer and switch to REPL" cider-load-buffer-and-switch-to-repl-buffer] - ["Load another file" cider-load-file] - ["Recursively load all files in directory" cider-load-all-files] - ["Load all project files" cider-load-all-project-ns] - ["Refresh loaded code" cider-ns-refresh] - ["Require and reload" cider-ns-reload] - ["Require and reload all" cider-ns-reload-all] - ["Run project (-main function)" cider-run]) - "Menu for CIDER mode eval commands.") - -(defconst cider-mode-interactions-menu - `("CIDER Interactions" :visible (cider-connected-p) - ["Complete symbol" complete-symbol] - "--" - ("REPL" - ["Set REPL to this ns" cider-repl-set-ns] - ["Switch to REPL" cider-switch-to-repl-buffer] - ["REPL Pretty Print" cider-repl-toggle-pretty-printing - :style toggle :selected cider-repl-use-pretty-printing] - ["Clear latest output" cider-find-and-clear-repl-output] - ["Clear all output" (cider-find-and-clear-repl-output t) - :keys "\\[universal-argument] \\[cider-find-and-clear-repl-output]"] - "--" - ["Configure the REPL" (customize-group 'cider-repl)]) - ,cider-doc-menu - ("Find (jump to)" - ["Find definition" cider-find-var] - ["Find namespace" cider-find-ns] - ["Find resource" cider-find-resource] - ["Find keyword" cider-find-keyword] - ["Go back" cider-pop-back]) - ("Xref" - ["Find fn references" cider-xref-fn-refs] - ["Find fn references and select" cider-xref-fn-refs-select] - ["Find fn dependencies" cider-xref-fn-defs] - ["Find fn dependencies and select" cider-xref-fn-defs-select]) - ("Browse" - ["Browse namespace" cider-browse-ns] - ["Browse all namespaces" cider-browse-ns-all] - ["Browse spec" cider-browse-spec] - ["Browse all specs" cider-browse-spec-all] - ["Browse REPL input history" cider-repl-history] - ["Browse classpath" cider-classpath] - ["Browse classpath entry" cider-open-classpath-entry]) - ("Format" - ["Format EDN last sexp" cider-format-edn-last-sexp] - ["Format EDN region" cider-format-edn-region] - ["Format EDN buffer" cider-format-edn-buffer]) - ("Macroexpand" - ["Macroexpand-1" cider-macroexpand-1] - ["Macroexpand-all" cider-macroexpand-all]) - ,cider-test-menu - ("Debug" - ["Inspect" cider-inspect] - ["Toggle var tracing" cider-toggle-trace-var] - ["Toggle ns tracing" cider-toggle-trace-ns] - "--" - ["Debug top-level form" cider-debug-defun-at-point - :keys "\\[universal-argument] \\[cider-eval-defun-at-point]"] - ["List instrumented defs" cider-browse-instrumented-defs] - "--" - ["Configure the Debugger" (customize-group 'cider-debug)]) - ,cider-profile-menu - ("Misc" - ["Clojure Cheatsheet" cider-cheatsheet] - ["Flush completion cache" cider-completion-flush-caches])) - "Menu for CIDER interactions.") - - -(declare-function cider-ns-refresh "cider-ns") -(declare-function cider-ns-reload "cider-ns") -(declare-function cider-ns-reload-all "cider-ns") -(declare-function cider-browse-ns "cider-browse-ns") -(declare-function cider-eval-ns-form "cider-eval") -(declare-function cider-repl-set-ns "cider-repl") -(declare-function cider-find-ns "cider-find") - -(defvar cider-ns-map - (let ((map (define-prefix-command 'cider-ns-map))) - (define-key map (kbd "b") #'cider-browse-ns) - (define-key map (kbd "M-b") #'cider-browse-ns) - (define-key map (kbd "e") #'cider-eval-ns-form) - (define-key map (kbd "M-e") #'cider-eval-ns-form) - (define-key map (kbd "f") #'cider-find-ns) - (define-key map (kbd "M-f") #'cider-find-ns) - (define-key map (kbd "n") #'cider-repl-set-ns) - (define-key map (kbd "M-n") #'cider-repl-set-ns) - (define-key map (kbd "r") #'cider-ns-refresh) - (define-key map (kbd "M-r") #'cider-ns-refresh) - (define-key map (kbd "l") #'cider-ns-reload) - (define-key map (kbd "M-l") #'cider-ns-reload-all) - map) - "CIDER NS keymap.") - -;; Those declares are needed, because we autoload all those commands when first -;; used. That optimizes CIDER's initial load time. -(declare-function cider-macroexpand-1 "cider-macroexpansion") -(declare-function cider-macroexpand-all "cider-macroexpansion") -(declare-function cider-selector "cider-selector") -(declare-function cider-toggle-trace-ns "cider-tracing") -(declare-function cider-toggle-trace-var "cider-tracing") -(declare-function cider-find-resource "cider-find") -(declare-function cider-find-keyword "cider-find") -(declare-function cider-find-var "cider-find") -(declare-function cider-find-dwim-at-mouse "cider-find") -(declare-function cider-xref-fn-refs "cider-xref") -(declare-function cider-xref-fn-refs-select "cider-xref") -(declare-function cider-xref-fn-deps "cider-xref") -(declare-function cider-xref-fn-deps-select "cider-xref") - -(defconst cider--has-many-mouse-buttons (not (memq window-system '(mac ns))) - "Non-nil if system binds forward and back buttons to and . - -As it stands Emacs fires these events on and on 'x' and -'w32'systems while on macOS it presents them on and .") - -(defcustom cider-use-xref t - "Enable xref integration." - :type 'boolean - :safe #'booleanp - :group 'cider - :version '(cider . "1.2.0")) - -(defcustom cider-xref-fn-depth -90 - "The depth to use when adding the CIDER xref function to the relevant hook. -By convention this is a number between -100 and 100, lower numbers indicating a -higher precedence." - :type 'integer - :group 'cider - :version '(cider . "1.2.0")) - -(defconst cider-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c C-d") 'cider-doc-map) - (unless cider-use-xref - (define-key map (kbd "M-.") #'cider-find-var) - (define-key map (kbd "M-,") #'cider-pop-back)) - (define-key map (kbd (if cider--has-many-mouse-buttons "" "")) #'xref-pop-marker-stack) - (define-key map (kbd (if cider--has-many-mouse-buttons "" "")) #'cider-find-dwim-at-mouse) - (define-key map (kbd "C-c C-.") #'cider-find-ns) - (define-key map (kbd "C-c C-:") #'cider-find-keyword) - (define-key map (kbd "C-c M-.") #'cider-find-resource) - (define-key map (kbd "M-TAB") #'complete-symbol) - (define-key map (kbd "C-M-x") #'cider-eval-defun-at-point) - (define-key map (kbd "C-c C-c") #'cider-eval-defun-at-point) - (define-key map (kbd "C-x C-e") #'cider-eval-last-sexp) - (define-key map (kbd "C-c C-e") #'cider-eval-last-sexp) - (define-key map (kbd "C-c C-p") #'cider-pprint-eval-last-sexp) - (define-key map (kbd "C-c C-f") #'cider-pprint-eval-defun-at-point) - (define-key map (kbd "C-c C-v") 'cider-eval-commands-map) - (define-key map (kbd "C-c C-j") 'cider-insert-commands-map) - (define-key map (kbd "C-c M-;") #'cider-eval-defun-to-comment) - (define-key map (kbd "C-c M-e") #'cider-eval-last-sexp-to-repl) - (define-key map (kbd "C-c M-p") #'cider-insert-last-sexp-in-repl) - (define-key map (kbd "C-c M-:") #'cider-read-and-eval) - (define-key map (kbd "C-c C-u") #'cider-undef) - (define-key map (kbd "C-c C-M-u") #'cider-undef-all) - (define-key map (kbd "C-c C-m") #'cider-macroexpand-1) - (define-key map (kbd "C-c M-m") #'cider-macroexpand-all) - (define-key map (kbd "C-c M-n") 'cider-ns-map) - (define-key map (kbd "C-c M-i") #'cider-inspect) - (define-key map (kbd "C-c M-t v") #'cider-toggle-trace-var) - (define-key map (kbd "C-c M-t n") #'cider-toggle-trace-ns) - (define-key map (kbd "C-c C-z") #'cider-switch-to-repl-buffer) - (define-key map (kbd "C-c M-z") #'cider-load-buffer-and-switch-to-repl-buffer) - (define-key map (kbd "C-c C-o") #'cider-find-and-clear-repl-output) - (define-key map (kbd "C-c C-k") #'cider-load-buffer) - (define-key map (kbd "C-c C-l") #'cider-load-file) - (define-key map (kbd "C-c C-M-l") #'cider-load-all-files) - (define-key map (kbd "C-c C-b") #'cider-interrupt) - (define-key map (kbd "C-c ,") 'cider-test-commands-map) - (define-key map (kbd "C-c C-t") 'cider-test-commands-map) - (define-key map (kbd "C-c M-s") #'cider-selector) - (define-key map (kbd "C-c M-d") #'cider-describe-connection) - (define-key map (kbd "C-c C-=") 'cider-profile-map) - (define-key map (kbd "C-c C-? r") #'cider-xref-fn-refs) - (define-key map (kbd "C-c C-? C-r") #'cider-xref-fn-refs-select) - (define-key map (kbd "C-c C-? d") #'cider-xref-fn-deps) - (define-key map (kbd "C-c C-? C-d") #'cider-xref-fn-deps-select) - (define-key map (kbd "C-c C-q") #'cider-quit) - (define-key map (kbd "C-c M-r") #'cider-restart) - (define-key map (kbd "C-c M-l a") #'cider-log-appender) - (define-key map (kbd "C-c M-l c") #'cider-log-consumer) - (define-key map (kbd "C-c M-l e") #'cider-log-event) - (define-key map (kbd "C-c M-l f") #'cider-log-framework) - (define-key map (kbd "C-c M-l i") #'cider-log-info) - (define-key map (kbd "C-c M-l l") #'cider-log) - (dolist (variable '(cider-mode-interactions-menu - cider-mode-eval-menu - cider-mode-menu)) - (easy-menu-do-define (intern (format "%s-open" variable)) - map - (get variable 'variable-documentation) - (cider--menu-add-help-strings (symbol-value variable)))) - map)) - -;; This menu works as an easy entry-point into CIDER. Even if cider.el isn't -;; loaded yet, this will be shown in Clojure buffers next to the "Clojure" -;; menu. -;;;###autoload -(with-eval-after-load 'clojure-mode - (easy-menu-define cider-clojure-mode-menu-open clojure-mode-map - "Menu for Clojure mode. - This is displayed in `clojure-mode' buffers, if `cider-mode' is not active." - `("CIDER" :visible (not cider-mode) - ["Start a Clojure REPL" cider-jack-in-clj - :help "Starts an nREPL server and connects a Clojure REPL to it."] - ["Connect to a Clojure REPL" cider-connect-clj - :help "Connects to a REPL that's already running."] - ["Start a ClojureScript REPL" cider-jack-in-cljs - :help "Starts an nREPL server and connects a ClojureScript REPL to it."] - ["Connect to a ClojureScript REPL" cider-connect-cljs - :help "Connects to a ClojureScript REPL that's already running."] - ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clj&cljs - :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL."] - "--" - ["View user manual" cider-view-manual]))) - -;;; Dynamic indentation -(defcustom cider-dynamic-indentation t - "Whether CIDER should aid Clojure(Script) indentation. -If non-nil, CIDER uses runtime information (such as the \":style/indent\" -metadata) to improve standard `clojure-mode' indentation. -If nil, CIDER won't interfere with `clojure-mode's indentation. - -Toggling this variable only takes effect after a file is closed and -re-visited." - :type 'boolean - :package-version '(cider . "0.11.0") - :group 'cider) - -(defun cider--get-symbol-indent (symbol-name) - "Return the indent metadata for SYMBOL-NAME in the current namespace." - (let* ((ns (let ((clojure-cache-ns t)) ; we force ns caching here for performance reasons - ;; silence bytecode warning of unused lexical var - (ignore clojure-cache-ns) - (cider-current-ns)))) - (if-let* ((meta (cider-resolve-var ns symbol-name)) - (indent (or (nrepl-dict-get meta "style/indent") - (nrepl-dict-get meta "indent")))) - (let ((format (format ":indent metadata on ‘%s’ is unreadable! \nERROR: %%s" - symbol-name))) - (with-demoted-errors format - (cider--deep-vector-to-list (read indent)))) - ;; There's no indent metadata, but there might be a clojure-mode - ;; indent-spec with fully-qualified namespace. - (when (string-match cider-resolve--prefix-regexp symbol-name) - (when-let* ((sym (intern-soft (replace-match (save-match-data - (cider-resolve-alias ns (match-string 1 symbol-name))) - t t symbol-name 1)))) - (get sym 'clojure-indent-function)))))) - - -;;; Dynamic font locking -(defcustom cider-font-lock-dynamically '(macro core deprecated) - "Specifies how much dynamic font-locking CIDER should use. -Dynamic font-locking this refers to applying syntax highlighting to vars -defined in the currently active nREPL connection. This is done in addition -to `clojure-mode's usual (static) font-lock, so even if you set this -variable to nil you'll still see basic syntax highlighting. - -The value is a list of symbols, each one indicates a different type of var -that should be font-locked: - `macro' (default): Any defined macro gets the `font-lock-keyword-face'. - `function': Any defined function gets the `font-lock-function-face'. - `var': Any non-local var gets the `font-lock-variable-name-face'. - `deprecated' (default): Any deprecated var gets the `cider-deprecated-face' - face. - `core' (default): Any symbol from clojure.core (face depends on type). - -The value can also be t, which means to font-lock as much as possible." - :type '(choice (set :tag "Fine-tune font-locking" - (const :tag "Any defined macro" macro) - (const :tag "Any defined function" function) - (const :tag "Any defined var" var) - (const :tag "Any defined deprecated" deprecated) - (const :tag "Any symbol from clojure.core" core)) - (const :tag "Font-lock as much as possible" t)) - :group 'cider - :package-version '(cider . "0.10.0")) - -(defcustom cider-font-lock-reader-conditionals t - "Apply font-locking to unused reader conditional expressions. -The result depends on the buffer CIDER connection type." - :type 'boolean - :group 'cider - :package-version '(cider . "0.15.0")) - -(defface cider-deprecated-face - '((((background light)) :background "light goldenrod") - (((background dark)) :background "#432")) - "Face used on deprecated vars." - :group 'cider) - -(defface cider-instrumented-face - '((((type graphic)) :box (:color "#c00" :line-width -1)) - (t :underline t :background "#800")) - "Face used to mark code being debugged." - :group 'cider-debug - :group 'cider - :package-version '(cider . "0.10.0")) - -(defface cider-traced-face - '((((type graphic)) :box (:color "cyan" :line-width -1)) - (t :underline t :background "#066")) - "Face used to mark code being traced." - :group 'cider - :package-version '(cider . "0.11.0")) - -(defface cider-reader-conditional-face - '((t (:inherit font-lock-comment-face))) - "Face used to mark unused reader conditional expressions." - :group 'cider - :package-version '(cider . "0.15.0")) - -(defconst cider-reader-conditionals-regexp "\\(?:#\\?@?[[:space:]\n]*(\\)" - "Regexp for matching reader conditionals with a non-capturing group. -Starts from the reader macro characters to the opening parentheses.") - -(defvar cider--reader-conditionals-match-data (list nil nil) - "Reusable list for `match-data` in reader conditionals font lock matchers.") - -(defun cider--search-reader-conditionals (limit) - "Matcher for finding reader conditionals. -Search is done with the given LIMIT." - (when (and cider-font-lock-reader-conditionals - (cider-connected-p)) - (when (search-forward-regexp cider-reader-conditionals-regexp limit t) - (let ((start (match-beginning 0)) - (state (syntax-ppss))) - (if (or (nth 3 state) (nth 4 state)) ; inside string or comment? - (cider--search-reader-conditionals limit) - (when (<= (point) limit) - (ignore-errors - (let ((md (match-data nil cider--reader-conditionals-match-data))) - (setf (nth 0 md) start) - (setf (nth 1 md) (point)) - (set-match-data md) - t)))))))) - -(defun cider--anchored-search-suppressed-forms-internal (repl-types limit) - "Helper function for `cider--anchored-search-suppressed-forms`. -REPL-TYPES is a list of strings repl-type strings. LIMIT is the same as -the LIMIT in `cider--anchored-search-suppressed-forms`" - (when (= (length repl-types) 1) - (let ((type (car repl-types)) - (expr (read (current-buffer))) - (start (save-excursion (backward-sexp) (point)))) - (when (<= (point) limit) - (forward-sexp) - (if (not (string-equal (symbol-name expr) (concat ":" type))) - (ignore-errors - (cl-assert (<= (point) limit)) - (let ((md (match-data nil cider--reader-conditionals-match-data))) - (setf (nth 0 md) start) - (setf (nth 1 md) (point)) - (set-match-data md) - t)) - (cider--anchored-search-suppressed-forms-internal repl-types limit)))))) - -(defun cider--anchored-search-suppressed-forms (limit) - "Matcher for finding unused reader conditional expressions. -An unused reader conditional expression is an expression for a platform -that does not match the CIDER connection for the buffer. Search is done -with the given LIMIT." - (let ((repl-types (seq-uniq (seq-map - (lambda (repl) - (symbol-name (cider-repl-type repl))) - (cider-repls)))) - (result 'retry)) - (while (and (eq result 'retry) (<= (point) limit)) - (condition-case condition - (setq result - (cider--anchored-search-suppressed-forms-internal - repl-types limit)) - (invalid-read-syntax - (setq result 'retry)) - (wrong-type-argument - (setq result 'retry)) - (scan-error - (setq result 'retry)) - (end-of-file - (setq result nil)) - (error - (setq result nil) - (message - "Error during fontification while searching for forms: %S" - condition)))) - (if (eq result 'retry) (setq result nil)) - result)) - -(defconst cider--reader-conditionals-font-lock-keywords - '((cider--search-reader-conditionals - (cider--anchored-search-suppressed-forms - (save-excursion - (let* ((state (syntax-ppss)) - (list-pt (nth 1 state))) - (when list-pt - (goto-char list-pt) - (forward-list) - (backward-char) - (point)))) - nil - (0 'cider-reader-conditional-face t)))) - "Font Lock keywords for unused reader conditionals in CIDER mode.") - -(defun cider--unless-local-match (value) - "Return VALUE, unless `match-string' is a local var." - (unless (or (get-text-property (point) 'cider-block-dynamic-font-lock) - (member (match-string 0) - (get-text-property (point) 'cider-locals))) - value)) - -(defun cider--compile-font-lock-keywords (symbols-plist core-plist) - "Return a list of font-lock rules for symbols in SYMBOLS-PLIST, CORE-PLIST." - (let ((cider-font-lock-dynamically (if (eq cider-font-lock-dynamically t) - '(function var macro core deprecated) - cider-font-lock-dynamically)) - deprecated enlightened - macros functions vars instrumented traced) - (cl-labels ((handle-plist - (plist) - (let ((do-function (memq 'function cider-font-lock-dynamically)) - (do-var (memq 'var cider-font-lock-dynamically)) - (do-macro (memq 'macro cider-font-lock-dynamically)) - (do-deprecated (memq 'deprecated cider-font-lock-dynamically))) - (while plist - (let ((sym (pop plist)) - (meta (pop plist))) - (pcase (nrepl-dict-get meta "cider/instrumented") - (`nil nil) - (`"\"breakpoint-if-interesting\"" - (push sym instrumented)) - (`"\"light-form\"" - (push sym enlightened))) - ;; The ::traced keywords can be inlined by MrAnderson, so - ;; we catch that case too. - ;; FIXME: This matches values too, not just keys. - (when (seq-find (lambda (k) (and (stringp k) - (string-match (rx "clojure.tools.trace/traced" eos) k))) - meta) - (push sym traced)) - (when (and do-deprecated (nrepl-dict-get meta "deprecated")) - (push sym deprecated)) - (let ((is-macro (nrepl-dict-get meta "macro")) - (is-function (or (nrepl-dict-get meta "fn") - (nrepl-dict-get meta "arglists")))) - (cond ((and do-macro is-macro) - (push sym macros)) - ((and do-function is-function) - (push sym functions)) - ((and do-var (not is-function) (not is-macro)) - (push sym vars))))))))) - (when (memq 'core cider-font-lock-dynamically) - (let ((cider-font-lock-dynamically '(function var macro core deprecated))) - (handle-plist core-plist))) - (handle-plist symbols-plist)) - `( - ,@(when macros - `((,(concat (rx (or "(" "#'")) ; Can't take the value of macros. - "\\(" (regexp-opt macros 'symbols) "\\)") - 1 (cider--unless-local-match font-lock-keyword-face)))) - ,@(when functions - `((,(regexp-opt functions 'symbols) 0 - (cider--unless-local-match font-lock-function-name-face)))) - ,@(when vars - `((,(regexp-opt vars 'symbols) 0 - (cider--unless-local-match font-lock-variable-name-face)))) - ,@(when deprecated - `((,(regexp-opt deprecated 'symbols) 0 - (cider--unless-local-match 'cider-deprecated-face) append))) - ,@(when enlightened - `((,(regexp-opt enlightened 'symbols) 0 - (cider--unless-local-match 'cider-enlightened-face) append))) - ,@(when instrumented - `((,(regexp-opt instrumented 'symbols) 0 - (cider--unless-local-match 'cider-instrumented-face) append))) - ,@(when traced - `((,(regexp-opt traced 'symbols) 0 - (cider--unless-local-match 'cider-traced-face) append)))))) - -(defconst cider--static-font-lock-keywords - (eval-when-compile - `((,(regexp-opt '("#break" "#dbg" "#light") 'symbols) 0 font-lock-warning-face))) - "Default expressions to highlight in CIDER mode.") - -(defvar-local cider--dynamic-font-lock-keywords nil) - -(defun cider-refresh-dynamic-font-lock (&optional ns) - "Ensure that the current buffer has up-to-date font-lock rules. -NS defaults to `cider-current-ns', and it can also be a dict describing the -namespace itself." - (interactive) - (when (and cider-font-lock-dynamically - font-lock-mode) - (font-lock-remove-keywords nil cider--dynamic-font-lock-keywords) - (when-let* ((ns (or ns (cider-current-ns))) - (symbols (cider-resolve-ns-symbols ns))) - (setq-local cider--dynamic-font-lock-keywords - (cider--compile-font-lock-keywords - symbols (cider-resolve-ns-symbols (cider-resolve-core-ns)))) - (font-lock-add-keywords nil cider--dynamic-font-lock-keywords 'end)) - (font-lock-flush))) - - -;;; Detecting local variables -(defun cider--read-locals-from-next-sexp () - "Return a list of all locals inside the next logical sexp." - (save-excursion - (ignore-errors - (clojure-forward-logical-sexp 1) - (let ((out nil) - (end (point))) - (forward-sexp -1) - ;; FIXME: This returns locals found inside the :or clause of a - ;; destructuring map. - (while (search-forward-regexp "\\_<[^:&]\\(\\sw\\|\\s_\\)*\\_>" end 'noerror) - (push (match-string-no-properties 0) out)) - out)))) - -(defun cider--read-locals-from-bindings-vector () - "Return a list of all locals inside the next bindings vector." - (save-excursion - (ignore-errors - (cider-start-of-next-sexp) - (when (eq (char-after) ?\[) - (forward-char 1) - (let ((out nil)) - (setq out (append (cider--read-locals-from-next-sexp) out)) - (while (ignore-errors (clojure-forward-logical-sexp 3) - (unless (eobp) - (forward-sexp -1) - t)) - (setq out (append (cider--read-locals-from-next-sexp) out))) - out))))) - -(defun cider--read-locals-from-arglist () - "Return a list of all locals in current form's arglist(s)." - (let ((out nil)) - (save-excursion - (ignore-errors - (cider-start-of-next-sexp) - ;; Named fn - (when (looking-at-p "\\s_\\|\\sw") - (cider-start-of-next-sexp 1)) - ;; Docstring - (when (eq (char-after) ?\") - (cider-start-of-next-sexp 1)) - ;; Attribute map - (when (eq (char-after) ?{) - (cider-start-of-next-sexp 1)) - ;; The arglist - (pcase (char-after) - (?\[ (setq out (cider--read-locals-from-next-sexp))) - ;; FIXME: This returns false positives. It takes all arglists of a - ;; function and returns all args it finds. The logic should be changed - ;; so that each arglist applies to its own scope. - (?\( (ignore-errors - (while (eq (char-after) ?\() - (save-excursion - (forward-char 1) - (setq out (append (cider--read-locals-from-next-sexp) out))) - (cider-start-of-next-sexp 1))))))) - out)) - -(defun cider--parse-and-apply-locals (end &optional outer-locals) - "Figure out local variables between point and END. -A list of these variables is set as the `cider-locals' text property over -the code where they are in scope. -Optional argument OUTER-LOCALS is used to specify local variables defined -before point." - (while (search-forward-regexp "(\\(ns\\_>\\|def\\|fn\\|for\\b\\|loop\\b\\|with-\\|do[a-z]+\\|\\([a-z]+-\\)?let\\b\\)" - end 'noerror) - (goto-char (match-beginning 0)) - (let ((sym (match-string 1)) - (sexp-end (save-excursion - (or (ignore-errors (forward-sexp 1) - (point)) - end)))) - ;; #1324: Don't do dynamic font-lock in `ns' forms, they are special - ;; macros where nothing is evaluated, so we'd get a lot of false - ;; positives. - (if (equal sym "ns") - (add-text-properties (point) sexp-end '(cider-block-dynamic-font-lock t)) - (forward-char 1) - (forward-sexp 1) - (let ((locals (append outer-locals - (pcase sym - ((or "fn" "def" "") (cider--read-locals-from-arglist)) - (_ (cider--read-locals-from-bindings-vector)))))) - (add-text-properties (point) sexp-end (list 'cider-locals locals)) - (clojure-forward-logical-sexp 1) - (cider--parse-and-apply-locals sexp-end locals))) - (goto-char sexp-end)))) - -(defun cider--update-locals-for-region (beg end) - "Update the `cider-locals' text property for region from BEG to END." - (save-excursion - (goto-char beg) - ;; If the inside of a `ns' form changed, reparse it from the start. - (when (and (not (bobp)) - (get-text-property (1- (point)) 'cider-block-dynamic-font-lock)) - (ignore-errors (beginning-of-defun))) - (save-excursion - ;; Move up until we reach a sexp that encloses the entire region (or - ;; a top-level sexp), and set that as the new BEG. - (goto-char end) - (while (and (or (> (point) beg) - (not (eq (char-after) ?\())) - (condition-case nil - (progn (backward-up-list) t) - (scan-error nil)))) - (setq beg (min beg (point))) - ;; If there are locals above the current sexp, reapply them to the - ;; current sexp. - (let ((locals-above (when (> beg (point-min)) - (get-text-property (1- beg) 'cider-locals)))) - (condition-case nil - (clojure-forward-logical-sexp 1) - (error (goto-char end))) - (add-text-properties beg (point) `(cider-locals ,locals-above)) - ;; Extend the region being font-locked to include whole sexps. - (setq end (max end (point))) - (goto-char beg) - (ignore-errors - (cider--parse-and-apply-locals end locals-above)))))) - -(defun cider--docview-as-string (sym info) - "Return a string of what would be displayed by `cider-docview-render'. -SYM and INFO is passed to `cider-docview-render'" - (with-temp-buffer - (cider-docview-render (current-buffer) sym info) - (goto-char (point-max)) - (forward-line -1) - (replace-regexp-in-string - "[`']" "\\\\=\\&" - (buffer-substring-no-properties (point-min) (1- (point)))))) - -(defcustom cider-use-tooltips t - "If non-nil, CIDER displays mouse-over tooltips. -It does this as well as the `help-echo' mechanism." - :group 'cider - :type 'boolean - :package-version '(cider "0.12.0")) - -(defvar cider--debug-mode-response) -(defvar cider--debug-mode) - -(defun cider--help-echo (_ obj pos) - "Return the help-echo string for OBJ at POS. -See \(info \"(elisp) Special Properties\")" - (while-no-input - (when (and (bufferp obj) - (cider-connected-p) - cider-use-tooltips - (not (eq help-at-pt-display-when-idle t))) - (with-current-buffer obj - (ignore-errors - (save-excursion - (goto-char pos) - (when-let* ((sym (cider-symbol-at-point))) - (if (member sym (get-text-property (point) 'cider-locals)) - (concat (format "`%s' is a local" sym) - (when cider--debug-mode - (let* ((locals (nrepl-dict-get cider--debug-mode-response "locals")) - (local-val (cadr (assoc sym locals)))) - (format " with value:\n%s" local-val)))) - (let* ((info (cider-sync-request:info sym)) - (candidates (nrepl-dict-get info "candidates"))) - (if candidates - (concat "There were ambiguities resolving this symbol:\n\n" - (mapconcat (lambda (x) (cider--docview-as-string sym x)) - candidates - (concat "\n\n" (make-string 60 ?-) "\n\n"))) - (cider--docview-as-string sym info))))))))))) - -(defun cider--wrap-fontify-locals (func) - "Return a function that will call FUNC after parsing local variables. -The local variables are stored in a list under the `cider-locals' text -property." - (lambda (beg end &rest rest) - (with-silent-modifications - (remove-text-properties beg end '(cider-locals nil cider-block-dynamic-font-lock nil)) - (when cider-use-tooltips - (add-text-properties beg end '(help-echo cider--help-echo))) - (when cider-font-lock-dynamically - (cider--update-locals-for-region beg end))) - (apply func beg end rest))) - - -;;; Minor-mode definition -(defvar x-gtk-use-system-tooltips) - -;;;###autoload -(define-minor-mode cider-mode - "Minor mode for REPL interaction from a Clojure buffer. - -\\{cider-mode-map}" - :init-value nil - :lighter cider-mode-line - :keymap cider-mode-map - (if cider-mode - (progn - (setq-local sesman-system 'CIDER) - (cider-eldoc-setup) - (add-hook 'completion-at-point-functions #'cider-complete-at-point nil t) - (font-lock-add-keywords nil cider--static-font-lock-keywords) - (cider-refresh-dynamic-font-lock) - (font-lock-add-keywords nil cider--reader-conditionals-font-lock-keywords) - ;; `font-lock-mode' might get enabled after `cider-mode'. - (add-hook 'font-lock-mode-hook #'cider-refresh-dynamic-font-lock nil 'local) - (setq-local font-lock-fontify-region-function - (cider--wrap-fontify-locals font-lock-fontify-region-function)) - ;; GTK tooltips look bad, and we have no control over the face. - (setq-local x-gtk-use-system-tooltips nil) - ;; `tooltip' has variable-width by default, which looks terrible. - (set-face-attribute 'tooltip nil :inherit 'unspecified) - (when cider-dynamic-indentation - (setq-local clojure-get-indent-function #'cider--get-symbol-indent)) - (setq-local clojure-expected-ns-function #'cider-expected-ns) - (when cider-use-xref - (add-hook 'xref-backend-functions #'cider--xref-backend cider-xref-fn-depth 'local)) - (setq next-error-function #'cider-jump-to-compilation-error)) - ;; Mode cleanup - (mapc #'kill-local-variable '(next-error-function - x-gtk-use-system-tooltips - font-lock-fontify-region-function - clojure-get-indent-function)) - (remove-hook 'completion-at-point-functions #'cider-complete-at-point t) - (when cider-use-xref - (remove-hook 'xref-backend-functions #'cider--xref-backend 'local)) - (remove-hook 'font-lock-mode-hook #'cider-refresh-dynamic-font-lock 'local) - (font-lock-add-keywords nil cider--reader-conditionals-font-lock-keywords) - (font-lock-remove-keywords nil cider--dynamic-font-lock-keywords) - (font-lock-remove-keywords nil cider--static-font-lock-keywords) - (font-lock-flush) - (remove-hook 'completion-at-point-functions #'cider-complete-at-point t))) - -(defun cider-set-buffer-ns (ns) - "Set this buffer's namespace to NS and refresh font-locking." - (setq-local cider-buffer-ns ns) - (when (or cider-mode (derived-mode-p 'cider-repl-mode)) - (cider-refresh-dynamic-font-lock ns))) - -(provide 'cider-mode) - -;;; cider-mode.el ends here diff --git a/elpa/cider-20230707.640/cider-ns.el b/elpa/cider-20230707.640/cider-ns.el deleted file mode 100644 index ee31bce5..00000000 --- a/elpa/cider-20230707.640/cider-ns.el +++ /dev/null @@ -1,272 +0,0 @@ -;;; cider-ns.el --- Namespace manipulation functionality -*- lexical-binding: t -*- - -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Bozhidar Batsov -;; Artur Malabarba - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Smart code refresh functionality based on ideas from: -;; http://thinkrelevance.com/blog/2013/06/04/clojure-workflow-reloaded -;; -;; Note that refresh with clojure.tools.namespace.repl is a smarter way to -;; reload code: the traditional way to reload Clojure code without restarting -;; the JVM is (require ... :reload) or an editor/IDE feature that does the same -;; thing. -;; -;; This has several problems: -;; -;; If you modify two namespaces which depend on each other, you must remember to -;; reload them in the correct order to avoid compilation errors. -;; -;; If you remove definitions from a source file and then reload it, those -;; definitions are still available in memory. If other code depends on those -;; definitions, it will continue to work but will break the next time you -;; restart the JVM. -;; -;; If the reloaded namespace contains defmulti, you must also reload all of the -;; associated defmethod expressions. -;; -;; If the reloaded namespace contains defprotocol, you must also reload any -;; records or types implementing that protocol and replace any existing -;; instances of those records/types with new instances. -;; -;; If the reloaded namespace contains macros, you must also reload any -;; namespaces which use those macros. -;; -;; If the running program contains functions which close over values in the -;; reloaded namespace, those closed-over values are not updated (This is common -;; in web applications which construct the "handler stack" as a composition of -;; functions.) - -;;; Code: - -(require 'map) -(require 'seq) -(require 'subr-x) - -(require 'cider-client) -(require 'cider-eval) -(require 'cider-popup) -(require 'cider-stacktrace) - -(defcustom cider-ns-save-files-on-refresh 'prompt - "Controls whether to prompt to save files before refreshing. -If nil, files are not saved. -If 'prompt, the user is prompted to save files if they have been modified. -If t, save the files without confirmation." - :type '(choice (const prompt :tag "Prompt to save files if they have been modified") - (const nil :tag "Don't save the files") - (const t :tag "Save the files without confirmation")) - :group 'cider - :package-version '(cider . "0.15.0")) - -(defcustom cider-ns-save-files-on-refresh-modes '(clojure-mode) - "Controls which files might be saved before refreshing. -If a list of modes, any buffers visiting files on the classpath whose major -mode is derived from any of the modes might be saved. -If t, all buffers visiting files on the classpath might be saved." - :type '(choice listp - (const t)) - :group 'cider - :package-version '(cider . "0.21.0")) - -(defconst cider-ns-refresh-log-buffer "*cider-ns-refresh-log*") - -(defcustom cider-ns-refresh-show-log-buffer nil - "Controls when to display the refresh log buffer. -If non-nil, the log buffer will be displayed every time `cider-ns-refresh' is -called. If nil, the log buffer will still be written to, but will never be -displayed automatically. Instead, the most relevant information will be -displayed in the echo area." - :type '(choice (const :tag "always" t) - (const :tag "never" nil)) - :group 'cider - :package-version '(cider . "0.10.0")) - -(defcustom cider-ns-refresh-before-fn nil - "Clojure function for `cider-ns-refresh' to call before reloading. -If nil, nothing will be invoked before reloading. Must be a -namespace-qualified function of zero arity. Any thrown exception will -prevent reloading from occurring." - :type 'string - :group 'cider - :package-version '(cider . "0.10.0")) - -(defcustom cider-ns-refresh-after-fn nil - "Clojure function for `cider-ns-refresh' to call after reloading. -If nil, nothing will be invoked after reloading. Must be a -namespace-qualified function of zero arity." - :type 'string - :group 'cider - :package-version '(cider . "0.10.0")) - -(defun cider-ns-refresh--handle-response (response log-buffer) - "Refresh LOG-BUFFER with RESPONSE." - (nrepl-dbind-response response (out err reloading status error error-ns after before) - (cl-flet* ((log (message &optional face) - (cider-emit-into-popup-buffer log-buffer message face t)) - - (log-echo (message &optional face) - (log message face) - (unless cider-ns-refresh-show-log-buffer - (let ((message-truncate-lines t)) - (message "cider-ns-refresh: %s" message))))) - (cond - (out - (log out)) - - (err - (log err 'font-lock-warning-face)) - - ((member "invoking-before" status) - (log-echo (format "Calling %s\n" before) 'font-lock-string-face)) - - ((member "invoked-before" status) - (log-echo (format "Successfully called %s\n" before) 'font-lock-string-face)) - - ((member "invoked-not-resolved" status) - (log-echo "Could not resolve refresh function\n" 'font-lock-string-face)) - - (reloading - (log-echo (format "Reloading %s\n" reloading) 'font-lock-string-face)) - - ((member "reloading" (nrepl-dict-keys response)) - (log-echo "Nothing to reload\n" 'font-lock-string-face)) - - ((member "ok" status) - (log-echo "Reloading successful\n" 'font-lock-string-face)) - - (error-ns - (log-echo (format "Error reloading %s\n" error-ns) 'font-lock-warning-face)) - - ((member "invoking-after" status) - (log-echo (format "Calling %s\n" after) 'font-lock-string-face)) - - ((member "invoked-after" status) - (log-echo (format "Successfully called %s\n" after) 'font-lock-string-face)))) - - (with-selected-window (or (get-buffer-window cider-ns-refresh-log-buffer) - (selected-window)) - (with-current-buffer cider-ns-refresh-log-buffer - (goto-char (point-max)))) - - (when (member "error" status) - (cider--render-stacktrace-causes error)))) - -(defun cider-ns-refresh--save-modified-buffers () - "Ensure any relevant modified buffers are saved before refreshing. -Its behavior is controlled by `cider-ns-save-files-on-refresh' and -`cider-ns-save-files-on-refresh-modes'." - (when cider-ns-save-files-on-refresh - (let ((dirs (seq-filter #'file-directory-p - (cider-classpath-entries)))) - (save-some-buffers - (not (eq cider-ns-save-files-on-refresh 'prompt)) - (lambda () - (and (seq-some #'derived-mode-p cider-ns-save-files-on-refresh-modes) - (seq-some (lambda (dir) - (file-in-directory-p buffer-file-name dir)) - dirs))))))) - -;;;###autoload -(defun cider-ns-reload (&optional prompt) - "Send a (require 'ns :reload) to the REPL. - -With an argument PROMPT, it prompts for a namespace name. This is the -Clojure out of the box reloading experience and does not rely on -org.clojure/tools.namespace. See Commentary of this file for a longer list -of differences. From the Clojure doc: \":reload forces loading of all the -identified libs even if they are already loaded\"." - (interactive "P") - (let ((ns (if prompt - (string-remove-prefix "'" (read-from-minibuffer "Namespace: " (clojure-find-ns))) - (clojure-find-ns)))) - (cider-interactive-eval (format "(require '%s :reload)" ns)))) - -;;;###autoload -(defun cider-ns-reload-all (&optional prompt) - "Send a (require 'ns :reload-all) to the REPL. - -With an argument PROMPT, it prompts for a namespace name. This is the -Clojure out of the box reloading experience and does not rely on -org.clojure/tools.namespace. See Commentary of this file for a longer list -of differences. From the Clojure doc: \":reload-all implies :reload and -also forces loading of all libs that the identified libs directly or -indirectly load via require\"." - (interactive "P") - (let ((ns (if prompt - (string-remove-prefix "'" (read-from-minibuffer "Namespace: " (clojure-find-ns))) - (clojure-find-ns)))) - (cider-interactive-eval (format "(require '%s :reload-all)" ns)))) - -;;;###autoload -(defun cider-ns-refresh (&optional mode) - "Reload modified and unloaded namespaces on the classpath. - -With a single prefix argument, or if MODE is `refresh-all', reload all -namespaces on the classpath unconditionally. - -With a double prefix argument, or if MODE is `clear', clear the state of -the namespace tracker before reloading. This is useful for recovering from -some classes of error (for example, those caused by circular dependencies) -that a normal reload would not otherwise recover from. The trade-off of -clearing is that stale code from any deleted files may not be completely -unloaded. - -With a negative prefix argument, or if MODE is `inhibit-fns', prevent any -refresh functions (defined in `cider-ns-refresh-before-fn' and -`cider-ns-refresh-after-fn') from being invoked." - (interactive "p") - (cider-ensure-connected) - (cider-ensure-op-supported "refresh") - (cider-ns-refresh--save-modified-buffers) - (let ((clear? (member mode '(clear 16))) - (refresh-all? (member mode '(refresh-all 4))) - (inhibit-refresh-fns (member mode '(inhibit-fns -1)))) - (cider-map-repls :clj - (lambda (conn) - ;; Inside the lambda, so the buffer is not created if we error out. - (let ((log-buffer (or (get-buffer cider-ns-refresh-log-buffer) - (cider-make-popup-buffer cider-ns-refresh-log-buffer)))) - (when cider-ns-refresh-show-log-buffer - (cider-popup-buffer-display log-buffer)) - (when inhibit-refresh-fns - (cider-emit-into-popup-buffer log-buffer - "inhibiting refresh functions\n" - nil - t)) - (when clear? - (cider-nrepl-send-sync-request '("op" "refresh-clear") conn)) - (cider-nrepl-send-request - (thread-last - (map-merge 'list - `(("op" ,(if refresh-all? "refresh-all" "refresh"))) - (cider--nrepl-print-request-map fill-column) - (when (and (not inhibit-refresh-fns) cider-ns-refresh-before-fn) - `(("before" ,cider-ns-refresh-before-fn))) - (when (and (not inhibit-refresh-fns) cider-ns-refresh-after-fn) - `(("after" ,cider-ns-refresh-after-fn)))) - (seq-mapcat #'identity)) - (lambda (response) - (cider-ns-refresh--handle-response response log-buffer)) - conn)))))) - -(provide 'cider-ns) -;;; cider-ns.el ends here diff --git a/elpa/cider-20230707.640/cider-overlays.el b/elpa/cider-20230707.640/cider-overlays.el deleted file mode 100644 index c9f565a4..00000000 --- a/elpa/cider-20230707.640/cider-overlays.el +++ /dev/null @@ -1,354 +0,0 @@ -;;; cider-overlays.el --- Managing CIDER overlays -*- lexical-binding: t; -*- - -;; Copyright © 2015-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors - -;; Author: Artur Malabarba - -;; 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 . - -;;; Commentary: - -;; Use `cider--make-overlay' to place a generic overlay at point. Or use -;; `cider--make-result-overlay' to place an interactive eval result overlay at -;; the end of a specified line. - -;;; Code: - -(require 'cider-common) -(require 'subr-x) -(require 'cl-lib) - - -;;; Customization -(defface cider-result-overlay-face - '((((class color) (background light)) - :background "grey90" :box (:line-width -1 :color "yellow")) - (((class color) (background dark)) - :background "grey10" :box (:line-width -1 :color "black"))) - "Face used to display evaluation results at the end of line. -If `cider-overlays-use-font-lock' is non-nil, this face is -applied with lower priority than the syntax highlighting." - :group 'cider - :package-version '(cider "0.9.1")) - -(defface cider-error-overlay-face - '((((class color) (background light)) - :background "orange red" - :extend t) - (((class color) (background dark)) - :background "firebrick" - :extend t)) - "Like `cider-result-overlay-face', but for evaluation errors." - :group 'cider - :package-version '(cider "0.25.0")) - -(defcustom cider-result-use-clojure-font-lock t - "If non-nil, interactive eval results are font-locked as Clojure code." - :group 'cider - :type 'boolean - :package-version '(cider . "0.10.0")) - -(defcustom cider-overlays-use-font-lock t - "If non-nil, results overlays are font-locked as Clojure code. -If nil, apply `cider-result-overlay-face' to the entire overlay instead of -font-locking it." - :group 'cider - :type 'boolean - :package-version '(cider . "0.10.0")) - -(defcustom cider-use-overlays 'both - "Whether to display evaluation results with overlays. -If t, use overlays determined by `cider-result-overlay-position'. -If nil, display on the echo area. -If both, display on both places. - -Only applies to evaluation commands. To configure the debugger overlays, -see `cider-debug-use-overlays'." - :type '(choice (const :tag "Display using overlays" t) - (const :tag "Display in echo area" nil) - (const :tag "Both" both)) - :group 'cider - :package-version '(cider . "0.10.0")) - -(defcustom cider-result-overlay-position 'at-eol - "Where to display result overlays for inline evaluation and the debugger. -If 'at-eol, display at the end of the line. -If 'at-point, display at the end of the respective sexp." - :group 'cider - :type ''(choice (const :tag "End of line" at-eol) - (const :tag "End of sexp" at-point)) - :package-version '(cider . "0.23.0")) - -(defcustom cider-eval-result-prefix "=> " - "The prefix displayed in the minibuffer before a result value." - :type 'string - :group 'cider - :package-version '(cider . "0.5.0")) - -(defcustom cider-eval-result-duration 'command - "Duration, in seconds, of CIDER's eval-result overlays. -If nil, overlays last indefinitely. -If the symbol `command', they're erased after the next command. -If the symbol `change', they last until the next change to the buffer. -Also see `cider-use-overlays'." - :type '(choice (integer :tag "Duration in seconds") - (const :tag "Until next command" command) - (const :tag "Until next buffer change" change) - (const :tag "Last indefinitely" nil)) - :group 'cider - :package-version '(cider . "0.10.0")) - - -;;; Overlay logic -(defun cider--delete-overlay (ov &rest _) - "Safely delete overlay OV. -Never throws errors, and can be used in an overlay's modification-hooks." - (ignore-errors (delete-overlay ov))) - -(defun cider--make-overlay (l r type &rest props) - "Place an overlay between L and R and return it. -TYPE is a symbol put on the overlay's category property. It is used to -easily remove all overlays from a region with: - (remove-overlays start end 'category TYPE) -PROPS is a plist of properties and values to add to the overlay." - (let ((o (make-overlay l (or r l) (current-buffer)))) - (overlay-put o 'category type) - (overlay-put o 'cider-temporary t) - (while props (overlay-put o (pop props) (pop props))) - (push #'cider--delete-overlay (overlay-get o 'modification-hooks)) - o)) - -(defun cider--remove-result-overlay (&rest _) - "Remove result overlay from current buffer. -This function also removes itself from `post-command-hook' and -`after-change-functions'." - (let ((hook (pcase cider-eval-result-duration - (`command 'post-command-hook) - (`change 'after-change-functions)))) - (remove-hook hook #'cider--remove-result-overlay 'local)) - (remove-overlays nil nil 'category 'result)) - -(defun cider--remove-result-overlay-after-command () - "Add `cider--remove-result-overlay' locally to `post-command-hook'. -This function also removes itself from `post-command-hook'." - (remove-hook 'post-command-hook #'cider--remove-result-overlay-after-command 'local) - (add-hook 'post-command-hook #'cider--remove-result-overlay nil 'local)) - -(defface cider-fringe-good-face - '((((class color) (background light)) :foreground "lightgreen") - (((class color) (background dark)) :foreground "darkgreen")) - "Face used on the fringe indicator for successful evaluation." - :group 'cider) - -(defconst cider--fringe-overlay-good - (propertize " " 'display '(left-fringe empty-line cider-fringe-good-face)) - "The before-string property that adds a green indicator on the fringe.") - -(defcustom cider-use-fringe-indicators t - "Whether to display evaluation indicators on the left fringe." - :safe #'booleanp - :group 'cider - :type 'boolean - :package-version '(cider . "0.13.0")) - -(defun cider--make-fringe-overlay (&optional end) - "Place an eval indicator at the fringe before a sexp. -END is the position where the sexp ends, and defaults to point." - (when cider-use-fringe-indicators - (with-current-buffer (if (markerp end) - (marker-buffer end) - (current-buffer)) - (save-excursion - (if end - (goto-char end) - (setq end (point))) - (clojure-forward-logical-sexp -1) - ;; Create the green-circle overlay. - (cider--make-overlay (point) end 'cider-fringe-indicator - 'before-string cider--fringe-overlay-good))))) - -(cl-defun cider--make-result-overlay (value &rest props &key where duration (type 'result) - (format (concat " " cider-eval-result-prefix "%s ")) - (prepend-face 'cider-result-overlay-face) - &allow-other-keys) - "Place an overlay displaying VALUE at the position determined by WHERE. -VALUE is used as the overlay's after-string property, meaning it is -displayed at the end of the overlay. -Return nil if the overlay was not placed or if it might not be visible, and -return the overlay otherwise. - -Return the overlay if it was placed successfully, and nil if it failed. - -This function takes some optional keyword arguments: - - If WHERE is a number or a marker, apply the overlay as determined by - `cider-result-overlay-position'. If it is a cons cell, the car and cdr - determine the start and end of the overlay. - DURATION takes the same possible values as the - `cider-eval-result-duration' variable. - TYPE is passed to `cider--make-overlay' (defaults to `result'). - FORMAT is a string passed to `format'. It should have - exactly one %s construct (for VALUE). - -All arguments beyond these (PROPS) are properties to be used on the -overlay." - (declare (indent 1)) - (while (keywordp (car props)) - (setq props (cdr (cdr props)))) - ;; If the marker points to a dead buffer, don't do anything. - (let ((buffer (cond - ((markerp where) (marker-buffer where)) - ((markerp (car-safe where)) (marker-buffer (car where))) - (t (current-buffer))))) - (with-current-buffer buffer - (save-excursion - (when (number-or-marker-p where) - (goto-char where)) - ;; Make sure the overlay is actually at the end of the sexp. - (skip-chars-backward "\r\n[:blank:]") - (let* ((beg (if (consp where) - (car where) - (save-excursion - (clojure-backward-logical-sexp 1) - (point)))) - (end (if (consp where) - (cdr where) - (pcase cider-result-overlay-position - ('at-eol (line-end-position)) - ('at-point (point))))) - ;; Specify `default' face, otherwise unformatted text will - ;; inherit the face of the following text. - (display-string (format (propertize format 'face 'default) value)) - (o nil)) - ;; Remove any overlay at the position we're creating a new one, if it - ;; exists. - (remove-overlays beg end 'category type) - (funcall (if cider-overlays-use-font-lock - #'font-lock-prepend-text-property - #'put-text-property) - 0 (length display-string) - 'face prepend-face - display-string) - ;; If the display spans multiple lines or is very long, display it at - ;; the beginning of the next line. - (when (or (string-match "\n." display-string) - (> (string-width display-string) - (- (window-width) (current-column)))) - (setq display-string (concat " \n" display-string))) - ;; Put the cursor property only once we're done manipulating the - ;; string, since we want it to be at the first char. - (put-text-property 0 1 'cursor 0 display-string) - (when (> (string-width display-string) (* 3 (window-width))) - (setq display-string - (concat (substring display-string 0 (* 3 (window-width))) - (substitute-command-keys - "...\nResult truncated. Type `\\[cider-inspect-last-result]' to inspect it.")))) - ;; Create the result overlay. - (setq o (apply #'cider--make-overlay - beg end type - 'after-string display-string - props)) - (pcase duration - ((pred numberp) (run-at-time duration nil #'cider--delete-overlay o)) - (`command - ;; Since the previous overlay was already removed above, we should - ;; remove the hook to remove all overlays after this function - ;; ends. Otherwise, we would inadvertently remove the newly created - ;; overlay too. - (remove-hook 'post-command-hook 'cider--remove-result-overlay 'local) - ;; If inside a command-loop, tell `cider--remove-result-overlay' - ;; to only remove after the *next* command. - (if this-command - (add-hook 'post-command-hook - #'cider--remove-result-overlay-after-command - nil 'local) - (cider--remove-result-overlay-after-command))) - (`change - (add-hook 'after-change-functions - #'cider--remove-result-overlay - nil 'local))) - (when-let* ((win (get-buffer-window buffer))) - ;; Left edge is visible. - (when (and (<= (window-start win) (point) (window-end win)) - ;; Right edge is visible. This is a little conservative - ;; if the overlay contains line breaks. - (or (< (+ (current-column) (string-width value)) - (window-width win)) - (not truncate-lines))) - o))))))) - - -;;; Displaying eval result -(defun cider--display-interactive-eval-result (value &optional point overlay-face) - "Display the result VALUE of an interactive eval operation. -VALUE is syntax-highlighted and displayed in the echo area. -OVERLAY-FACE is the face applied to the overlay, which defaults to -`cider-result-overlay-face' if nil. -If POINT and `cider-use-overlays' are non-nil, it is also displayed in an -overlay at the end of the line containing POINT. -Note that, while POINT can be a number, it's preferable to be a marker, as -that will better handle some corner cases where the original buffer is not -focused." - (let* ((font-value (if cider-result-use-clojure-font-lock - (cider-font-lock-as-clojure value) - value)) - (font-value (string-trim-right font-value)) - (used-overlay (when (and point cider-use-overlays) - (cider--make-result-overlay font-value - :where point - :duration cider-eval-result-duration - :prepend-face (or overlay-face 'cider-result-overlay-face))))) - (message - "%s" - (propertize (format "%s%s" cider-eval-result-prefix font-value) - ;; The following hides the message from the echo-area, but - ;; displays it in the Messages buffer. We only hide the message - ;; if the user wants to AND if the overlay succeeded. - 'invisible (and used-overlay - (not (eq cider-use-overlays 'both))))))) - - -;;; Fragile buttons -(defface cider-fragile-button-face - '((((type graphic)) - :box (:line-width 3 :style released-button) - :inherit font-lock-warning-face) - (t :inverse-video t)) - "Face for buttons that vanish when clicked." - :package-version '(cider . "0.12.0") - :group 'cider) - -(define-button-type 'cider-fragile - 'action #'cider--overlay-destroy - 'follow-link t - 'face nil - 'modification-hooks '(cider--overlay-destroy) - 'help-echo "RET: delete this.") - -(defun cider--overlay-destroy (ov &rest r) - "Delete overlay OV and its underlying text. -If any other arguments are given (collected in R), only actually do anything -if the first one is non-nil. This is so it works in `modification-hooks'." - (unless (and r (not (car r))) - (let ((inhibit-modification-hooks t) - (beg (copy-marker (overlay-start ov))) - (end (copy-marker (overlay-end ov)))) - (delete-overlay ov) - (delete-region beg end) - (goto-char beg) - (when (= (char-after) (char-before) ?\n) - (delete-char 1))))) - -(provide 'cider-overlays) -;;; cider-overlays.el ends here diff --git a/elpa/cider-20230707.640/cider-pkg.el b/elpa/cider-20230707.640/cider-pkg.el deleted file mode 100644 index 083de8d0..00000000 --- a/elpa/cider-20230707.640/cider-pkg.el +++ /dev/null @@ -1,26 +0,0 @@ -(define-package "cider" "20230707.640" "Clojure Interactive Development Environment that Rocks" - '((emacs "26") - (clojure-mode "5.16.0") - (parseedn "1.0.6") - (queue "0.2") - (spinner "1.7") - (seq "2.22") - (sesman "0.3.2") - (transient "0.4.1")) - :commit "bc8903b0c85cf0891f106337eabfc6f747d262a1" :authors - '(("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")) - :maintainers - '(("Bozhidar Batsov" . "bozhidar@batsov.dev")) - :maintainer - '("Bozhidar Batsov" . "bozhidar@batsov.dev") - :keywords - '("languages" "clojure" "cider") - :url "http://www.github.com/clojure-emacs/cider") -;; Local Variables: -;; no-byte-compile: t -;; End: diff --git a/elpa/cider-20230707.640/cider-popup.el b/elpa/cider-20230707.640/cider-popup.el deleted file mode 100644 index a7fb26d6..00000000 --- a/elpa/cider-20230707.640/cider-popup.el +++ /dev/null @@ -1,133 +0,0 @@ -;;; cider-popup.el --- Creating and quitting popup buffers -*- lexical-binding: t; -*- - -;; Copyright © 2015-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors - -;; Author: Artur Malabarba - -;; 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 . - -;;; Commentary: - -;; Common functionality for dealing with popup buffers. - -;;; Code: - -(require 'subr-x) - -(define-minor-mode cider-popup-buffer-mode - "Mode for CIDER popup buffers." - :lighter (" cider-tmp") - :keymap '(("q" . cider-popup-buffer-quit-function))) - -(defvar-local cider-popup-buffer-quit-function #'cider-popup-buffer-quit - "The function that is used to quit a temporary popup buffer.") - -(defun cider-popup-buffer-quit-function (&optional kill-buffer-p) - "Wrapper to invoke the function `cider-popup-buffer-quit-function'. -KILL-BUFFER-P is passed along." - (interactive) - (funcall cider-popup-buffer-quit-function kill-buffer-p)) - -(defun cider-popup-buffer (name &optional select mode ancillary) - "Create new popup buffer called NAME. -If SELECT is non-nil, select the newly created window. -If major MODE is non-nil, enable it for the popup buffer. -If ANCILLARY is non-nil, the buffer is added to `cider-ancillary-buffers' -and automatically removed when killed." - (thread-first (cider-make-popup-buffer name mode ancillary) - (cider-popup-buffer-display select))) - -(defun cider-popup-buffer-display (buffer &optional select) - "Display BUFFER. -If SELECT is non-nil, select the BUFFER." - (let ((window (get-buffer-window buffer 'visible))) - (when window - (with-current-buffer buffer - (set-window-point window (point)))) - ;; If the buffer we are popping up is already displayed in the selected - ;; window, the below `inhibit-same-window' logic will cause it to be - ;; displayed twice - so we early out in this case. Note that we must check - ;; `selected-window', as async request handlers are executed in the context - ;; of the current connection buffer (i.e. `current-buffer' is dynamically - ;; bound to that). - (unless (eq window (selected-window)) - ;; Non nil `inhibit-same-window' ensures that current window is not covered - ;; Non nil `inhibit-switch-frame' ensures that the other frame is not selected - ;; if that's where the buffer is being shown. - (funcall (if select #'pop-to-buffer #'display-buffer) - buffer `(nil . ((inhibit-same-window . ,pop-up-windows) - (reusable-frames . visible)))))) - buffer) - -(defun cider-popup-buffer-quit (&optional kill) - "Quit the current (temp) window. -Bury its buffer using `quit-restore-window'. -If prefix argument KILL is non-nil, kill the buffer instead of burying it." - (interactive) - (quit-restore-window (selected-window) (if kill 'kill 'append))) - -(defvar-local cider-popup-output-marker nil) - -(defvar cider-ancillary-buffers nil - "A list ancillary buffers created by the various CIDER commands. -We track them mostly to be able to clean them up on quit.") - -(defun cider-make-popup-buffer (name &optional mode ancillary) - "Create a temporary buffer called NAME using major MODE (if specified). -If ANCILLARY is non-nil, the buffer is added to `cider-ancillary-buffers' -and automatically removed when killed." - (with-current-buffer (get-buffer-create name) - (kill-all-local-variables) - (setq buffer-read-only nil) - (erase-buffer) - (when mode - (funcall mode)) - (cider-popup-buffer-mode 1) - (setq cider-popup-output-marker (point-marker)) - (setq buffer-read-only t) - (when ancillary - (add-to-list 'cider-ancillary-buffers name) - (add-hook 'kill-buffer-hook - (lambda () - (setq cider-ancillary-buffers - (remove name cider-ancillary-buffers))) - nil 'local)) - (current-buffer))) - -(defun cider-emit-into-popup-buffer (buffer value &optional face inhibit-indent) - "Emit into BUFFER the provided VALUE optionally using FACE. -Indent emitted value (usually a sexp) unless INHIBIT-INDENT is specified -and non-nil." - ;; Long string output renders Emacs unresponsive and users might intentionally - ;; kill the frozen popup buffer. Therefore, we don't re-create the buffer and - ;; silently ignore the output. - (when (buffer-live-p buffer) - (with-current-buffer buffer - (let ((inhibit-read-only t) - (buffer-undo-list t) - (moving (= (point) cider-popup-output-marker))) - (save-excursion - (goto-char cider-popup-output-marker) - (let ((value-str (format "%s" value))) - (when face - (add-face-text-property 0 (length value-str) face nil value-str)) - (insert value-str)) - (unless inhibit-indent - (indent-sexp)) - (set-marker cider-popup-output-marker (point))) - (when moving (goto-char cider-popup-output-marker)))))) - -(provide 'cider-popup) - -;;; cider-popup.el ends here diff --git a/elpa/cider-20230707.640/cider-profile.el b/elpa/cider-20230707.640/cider-profile.el deleted file mode 100644 index e2dd6fc6..00000000 --- a/elpa/cider-20230707.640/cider-profile.el +++ /dev/null @@ -1,216 +0,0 @@ -;;; cider-profile.el --- CIDER support for profiling -*- lexical-binding: t; -*- - -;; Copyright © 2014-2023 Edwin Watkeys and CIDER contributors - -;; Author: Edwin Watkeys -;; Juan E. Maya - -;; 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 . - -;;; Commentary: - -;; Provides coarse-grained interactive profiling support. -;; Based on earlier work by Edwin Watkeys (https://github.com/thunknyc/nrepl-profile). - -;;; Code: - -(require 'cider-client) -(require 'cider-popup) -(require 'cider-eval) - -(defconst cider-profile-buffer "*cider-profile*") - -(defvar cider-profile-map - (let ((map (define-prefix-command 'cider-profile-map))) - (define-key map (kbd "t") #'cider-profile-toggle) - (define-key map (kbd "C-t") #'cider-profile-toggle) - (define-key map (kbd "c") #'cider-profile-clear) - (define-key map (kbd "C-c") #'cider-profile-clear) - (define-key map (kbd "S") #'cider-profile-summary) - (define-key map (kbd "C-S") #'cider-profile-summary) - (define-key map (kbd "s") #'cider-profile-var-summary) - (define-key map (kbd "C-s") #'cider-profile-var-summary) - (define-key map (kbd "n") #'cider-profile-ns-toggle) - (define-key map (kbd "C-n") #'cider-profile-ns-toggle) - (define-key map (kbd "v") #'cider-profile-var-profiled-p) - (define-key map (kbd "C-v") #'cider-profile-var-profiled-p) - (define-key map (kbd "+") #'cider-profile-samples) - (define-key map (kbd "C-+") #'cider-profile-samples) - map) - "CIDER profiler keymap.") - -(defconst cider-profile-menu - '("Profile" - ["Toggle var profiling" cider-profile-toggle] - ["Toggle namespace profiling" cider-profile-ns-toggle] - "--" - ["Display var profiling status" cider-profile-var-profiled-p] - ["Display max sample count" cider-profile-samples] - ["Display var summary" cider-profile-var-summary] - ["Display summary" cider-profile-summary] - ["Clear data" cider-profile-clear]) - "CIDER profiling submenu.") - -(defun cider-profile--make-response-handler (handler &optional buffer) - "Make a response handler using value handler HANDLER for connection BUFFER. - -Optional argument BUFFER defaults to current buffer." - (nrepl-make-response-handler - (or buffer (current-buffer)) handler nil nil nil)) - -;;;###autoload -(defun cider-profile-samples (&optional query) - "Displays current max-sample-count. -If optional QUERY is specified, set max-sample-count and display new value." - (interactive "P") - (cider-ensure-op-supported "set-max-samples") - (cider-ensure-op-supported "get-max-samples") - (if (not (null query)) - (cider-nrepl-send-request - (let ((max-samples (if (numberp query) query '()))) - (message "query: %s" max-samples) - `("op" "set-max-samples" "max-samples" ,max-samples)) - (cider-profile--make-response-handler - (lambda (_buffer value) - (let ((value (if (zerop (length value)) "unlimited" value))) - (message "max-sample-count is now %s" value))))) - (cider-nrepl-send-request - '("op" "get-max-samples") - (cider-profile--make-response-handler - (lambda (_buffer value) - (let ((value (if (zerop (length value)) "unlimited" value))) - (message "max-sample-count is now %s" value)))))) - query) - -;;;###autoload -(defun cider-profile-var-profiled-p (query) - "Displays the profiling status of var under point. -Prompts for var if none under point or QUERY is present." - (interactive "P") - (cider-ensure-op-supported "is-var-profiled") - (cider-read-symbol-name - "Report profiling status for var: " - (lambda (sym) - (let ((ns (cider-current-ns))) - (cider-nrepl-send-request - `("op" "is-var-profiled" - "ns" ,ns - "sym" ,sym) - (cider-profile--make-response-handler - (lambda (_buffer value) - (pcase value - ("profiled" (message "Profiling is currently enabled for %s/%s" ns sym)) - ("unprofiled" (message "Profiling is currently disabled for %s/%s" ns sym)) - ("unbound" (message "%s/%s is unbound" ns sym))))))))) - query) - -;;;###autoload -(defun cider-profile-ns-toggle (&optional query) - "Toggle profiling for the ns associated with optional QUERY. - -If optional argument QUERY is non-nil, prompt for ns. Otherwise use -current ns." - (interactive "P") - (cider-ensure-op-supported "toggle-profile-ns") - (let ((ns (if query - (completing-read "Toggle profiling for ns: " - (cider-sync-request:ns-list)) - (cider-current-ns)))) - (cider-nrepl-send-request - `("op" "toggle-profile-ns" - "ns" ,ns) - (cider-profile--make-response-handler - (lambda (_buffer value) - (pcase value - ("profiled" (message "Profiling enabled for %s" ns)) - ("unprofiled" (message "Profiling disabled for %s" ns))))))) - query) - -;;;###autoload -(defun cider-profile-toggle (query) - "Toggle profiling for the given QUERY. -Defaults to the symbol at point. -With prefix arg or no symbol at point, prompts for a var." - (interactive "P") - (cider-ensure-op-supported "toggle-profile") - (cider-read-symbol-name - "Toggle profiling for var: " - (lambda (sym) - (let ((ns (cider-current-ns))) - (cider-nrepl-send-request - `("op" "toggle-profile" - "ns" ,ns - "sym" ,sym) - (cider-profile--make-response-handler - (lambda (_buffer value) - (pcase value - ("profiled" (message "Profiling enabled for %s/%s" ns sym)) - ("unprofiled" (message "Profiling disabled for %s/%s" ns sym)) - ("unbound" (message "%s/%s is unbound" ns sym))))))))) - query) - -(defun cider-profile-display-stats (stats-response) - "Displays the STATS-RESPONSE on `cider-profile-buffer`." - (let ((table (nrepl-dict-get stats-response "err"))) - (if cider-profile-buffer - (let ((buffer (cider-make-popup-buffer cider-profile-buffer))) - (with-current-buffer buffer - (let ((inhibit-read-only t)) (insert table))) - (display-buffer buffer) - (let ((window (get-buffer-window buffer))) - (set-window-point window 0) - (select-window window) - (fit-window-to-buffer window))) - (cider-emit-interactive-eval-err-output table)))) - -;;;###autoload -(defun cider-profile-summary () - "Display a summary of currently collected profile data." - (interactive) - (cider-ensure-op-supported "profile-summary") - (cider-profile-display-stats - (cider-nrepl-send-sync-request '("op" "profile-summary")))) - -;;;###autoload -(defun cider-profile-var-summary (query) - "Display profile data for var under point QUERY. -Defaults to the symbol at point. With prefix arg or no symbol at point, -prompts for a var." - (interactive "P") - (cider-ensure-op-supported "profile-var-summary") - (cider-read-symbol-name - "Profile-summary for var: " - (lambda (sym) - (cider-profile-display-stats - (cider-nrepl-send-sync-request - `("op" "profile-var-summary" - "ns" ,(cider-current-ns) - "sym" ,sym))))) - query) - -;;;###autoload -(defun cider-profile-clear () - "Clear any collected profile data." - (interactive) - (cider-ensure-op-supported "clear-profile") - (cider-nrepl-send-request - '("op" "clear-profile") - (cider-profile--make-response-handler - (lambda (_buffer value) - (when (equal value "cleared") - (message "Cleared profile data")))))) - -(provide 'cider-profile) - -;;; cider-profile.el ends here diff --git a/elpa/cider-20230707.640/cider-repl-history.el b/elpa/cider-20230707.640/cider-repl-history.el deleted file mode 100644 index e5044bf6..00000000 --- a/elpa/cider-20230707.640/cider-repl-history.el +++ /dev/null @@ -1,721 +0,0 @@ -;;; cider-repl-history.el --- REPL input history browser -*- lexical-binding: t; -*- - -;; Copyright (c) 2017-2023 John Valente and browse-kill-ring authors - -;; 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 . - -;; This file is not part of GNU Emacs. - -;; Based heavily on browse-kill-ring -;; https://github.com/browse-kill-ring/browse-kill-ring - -;;; Commentary: - -;; REPL input history browser for CIDER. - -;; Allows you to browse the full input history for your REPL buffer, and -;; insert previous commands at the prompt. - -;;; Code: - -(require 'cl-lib) -(require 'cider-popup) -(require 'clojure-mode) -(require 'derived) -(require 'pulse) -(require 'sesman) - -(defconst cider-repl-history-buffer "*cider-repl-history*") - -(defgroup cider-repl-history nil - "A package for browsing and inserting the items in the CIDER command history." - :prefix "cider-repl-history-" - :group 'cider) - -(defvar cider-repl-history-display-styles - '((separated . cider-repl-history-insert-as-separated) - (one-line . cider-repl-history-insert-as-one-line))) - -(defcustom cider-repl-history-display-style 'separated - "How to display the CIDER command history items. - -If `one-line', then replace newlines with \"\\n\" for display. - -If `separated', then display `cider-repl-history-separator' between -entries." - :type '(choice (const :tag "One line" one-line) - (const :tag "Separated" separated)) - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-quit-action 'quit-window - "What action to take when `cider-repl-history-quit' is called. - -If `bury-buffer', then simply bury the *cider-repl-history* buffer, but keep -the window. - -If `bury-and-delete-window', then bury the buffer, and (if there is -more than one window) delete the window. - -If `delete-and-restore', then restore the window configuration to what it was -before `cider-repl-history' was called, and kill the *cider-repl-history* -buffer. - -If `quit-window', then restore the window configuration to what -it was before `cider-repl-history' was called, and bury *cider-repl-history*. -This is the default. - -If `kill-and-delete-window', then kill the *cider-repl-history* buffer, and -delete the window on close. - -Otherwise, it should be a function to call." - ;; Note, if you use one of the non-"delete" options, after you "quit", - ;; the *cider-repl-history* buffer is still available. If you are using - ;; `cider-repl-history-show-preview', and you switch to *cider-repl-history* (i.e., - ;; with C-x b), it will not give the preview unless and until you "update" - ;; the *cider-repl-history* buffer. - ;; - ;; This really should not be an issue, because there's no reason to "switch" - ;; back to the buffer. If you want to get it back, you can just do C-c M-p - ;; from the REPL buffer. - - ;; If you get in this situation and find it annoying, you can either disable - ;; the preview, or set `cider-repl-history-quit-action' to 'delete-and-restore. - ;; Then you will simply not have the *cider-repl-history* buffer after you quit, - ;; and it won't be an issue. - - :type '(choice (const :tag "Bury buffer" - :value bury-buffer) - (const :tag "Bury buffer and delete window" - :value bury-and-delete-window) - (const :tag "Delete window" - :value delete-and-restore) - (const :tag "Save and restore" - :value quit-window) - (const :tag "Kill buffer and delete window" - :value kill-and-delete-window) - function) - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-resize-window nil - "Whether to resize the `cider-repl-history' window to fit its contents. -Value is either t, meaning yes, or a cons pair of integers, - (MAXIMUM . MINIMUM) for the size of the window. MAXIMUM defaults to -the window size chosen by `pop-to-buffer'; MINIMUM defaults to -`window-min-height'." - :type '(choice (const :tag "No" nil) - (const :tag "Yes" t) - (cons (integer :tag "Maximum") (integer :tag "Minimum"))) - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-separator ";;;;;;;;;;" - "The string separating entries in the `separated' style. -See `cider-repl-history-display-style'." - ;; The (default) separator is a Clojure comment, to preserve fontification - ;; in the buffer. - :type 'string - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-recenter nil - "If non-nil, then always keep the current entry at the top of the window." - :type 'boolean - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-highlight-current-entry nil - "If non-nil, highlight the currently selected command history entry." - :type 'boolean - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-highlight-inserted-item nil - "If non-nil, then temporarily highlight the inserted command history entry. -The value selected controls how the inserted item is highlighted, -possible values are `solid' (highlight the inserted text for a -fixed period of time), or `pulse' (fade out the highlighting gradually). -Setting this variable to the value t will select the default -highlighting style, which currently `pulse'. - -The variable `cider-repl-history-inserted-item-face' contains the -face used for highlighting." - :type '(choice (const nil) (const t) (const solid) (const pulse)) - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-separator-face 'bold - "The face in which to highlight the `cider-repl-history-separator'." - :type 'face - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-current-entry-face 'highlight - "The face in which to highlight the command history current entry." - :type 'face - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-inserted-item-face 'highlight - "The face in which to highlight the inserted item." - :type 'face - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-maximum-display-length nil - "Whether or not to limit the length of displayed items. - -If this variable is an integer, the display of the command history will be -limited to that many characters. -Setting this variable to nil means no limit." - :type '(choice (const :tag "None" nil) - integer) - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-display-duplicates t - "If non-nil, then display duplicate items in the command history." - :type 'boolean - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-display-duplicate-highest t - "If non-nil, then display most recent duplicate items in the command history. -Only takes effect when `cider-repl-history-display-duplicates' is nil." - :type 'boolean - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-text-properties nil - "If non-nil, maintain text properties of the command history items." - :type 'boolean - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-hook nil - "A list of functions to call after `cider-repl-history'." - :type 'hook - :package-version '(cider . "0.15.0")) - -(defcustom cider-repl-history-show-preview nil - "If non-nil, show a preview of the inserted text in the REPL buffer. - -The REPL buffer would show a preview of what the buffer would look like -if the item under point were inserted." - - :type 'boolean - :package-version '(cider . "0.15.0")) - -(defvar cider-repl-history-repl-window nil - "The window in which chosen command history data will be inserted. -It is probably not a good idea to set this variable directly; simply -call `cider-repl-history' again.") - -(defvar cider-repl-history-repl-buffer nil - "The buffer in which chosen command history data will be inserted. -It is probably not a good idea to set this variable directly; simply -call `cider-repl-history' again.") - -(defvar cider-repl-history-preview-overlay nil - "Overlay used to preview what would happen if the user inserted the given text.") - -(defvar cider-repl-history-previous-overlay nil - "Previous overlay within *cider-repl-history* buffer.") - - -(defun cider-repl-history-get-history () - "Function to retrieve history from the REPL buffer." - (if cider-repl-history-repl-buffer - (buffer-local-value - 'cider-repl-input-history - cider-repl-history-repl-buffer) - (error "Variable `cider-repl-history-repl-buffer' not bound to a buffer"))) - -(defun cider-repl-history-resize-window () - "Resize the *cider-repl-history* window if needed. -Controlled by variable `cider-repl-history-resize-window'." - (when cider-repl-history-resize-window - (apply #'fit-window-to-buffer (selected-window) - (if (consp cider-repl-history-resize-window) - (list (car cider-repl-history-resize-window) - (or (cdr cider-repl-history-resize-window) - window-min-height)) - (list nil window-min-height))))) - -(defun cider-repl-history-read-regexp (msg use-default-p) - "Get a regular expression from the user. -Prompts with MSG; previous entry is default if USE-DEFAULT-P." - (let* ((default (car regexp-history)) - (prompt (if (and default use-default-p) - (format "%s for regexp (default `%s'): " - msg - default) - (format "%s (regexp): " msg))) - (input - (read-from-minibuffer prompt nil nil nil 'regexp-history - (if use-default-p nil default)))) - (if (equal input "") - (if use-default-p default nil) - input))) - -(defun cider-repl-history-clear-preview () - "Clear the preview, if one is present." - (interactive) - (when cider-repl-history-preview-overlay - (cl-assert (overlayp cider-repl-history-preview-overlay)) - (delete-overlay cider-repl-history-preview-overlay))) - -(defun cider-repl-history-cleanup-on-exit () - "Function called when the user is finished with `cider-repl-history'. -This function performs any cleanup that is required when the user -has finished interacting with the *cider-repl-history* buffer. For now -the only cleanup performed is to remove the preview overlay, if -it's turned on." - (cider-repl-history-clear-preview)) - -(defun cider-repl-history-quit () - "Take the action specified by `cider-repl-history-quit-action'." - (interactive) - (cider-repl-history-cleanup-on-exit) - (pcase cider-repl-history-quit-action - (`delete-and-restore - (quit-restore-window (selected-window) 'kill)) - (`quit-window - (quit-window)) - (`kill-and-delete-window - (kill-buffer (current-buffer)) - (unless (= (count-windows) 1) - (delete-window))) - (`bury-and-delete-window - (bury-buffer) - (unless (= (count-windows) 1) - (delete-window))) - (_ - (funcall cider-repl-history-quit-action)))) - -(defun cider-repl-history-preview-overlay-setup (orig-buf) - "Setup the preview overlay in ORIG-BUF." - (when cider-repl-history-show-preview - (with-current-buffer orig-buf - (let* ((will-replace (region-active-p)) - (start (if will-replace - (min (point) (mark)) - (point))) - (end (if will-replace - (max (point) (mark)) - (point)))) - (cider-repl-history-clear-preview) - (setq cider-repl-history-preview-overlay - (make-overlay start end orig-buf)) - (overlay-put cider-repl-history-preview-overlay - 'invisible t))))) - -(defun cider-repl-history-highlight-inserted (start end) - "Insert the text between START and END." - (pcase cider-repl-history-highlight-inserted-item - ((or `pulse `t) - (let ((pulse-delay .05) (pulse-iterations 10)) - (with-no-warnings - (pulse-momentary-highlight-region - start end cider-repl-history-inserted-item-face)))) - (`solid - (let ((o (make-overlay start end))) - (overlay-put o 'face cider-repl-history-inserted-item-face) - (sit-for 0.5) - (delete-overlay o))))) - -(defun cider-repl-history-insert-and-highlight (str) - "Helper function to insert STR at point, highlighting it if appropriate." - (let ((before-insert (point))) - (let (deactivate-mark) - (insert-for-yank str)) - (cider-repl-history-highlight-inserted - before-insert - (point)))) - -(defun cider-repl-history-target-overlay-at (_position &optional no-error) - "Return overlay at POSITION that has property `cider-repl-history-target'. -If no such overlay, raise an error unless NO-ERROR is true, in which -case return nil." - (let ((ovs (overlays-at (point)))) - (catch 'cider-repl-history-target-overlay-at - (dolist (ov ovs) - (when (overlay-get ov 'cider-repl-history-target) - (throw 'cider-repl-history-target-overlay-at ov))) - (unless no-error - (error "No CIDER history item here"))))) - -(defun cider-repl-history-current-string (pt &optional no-error) - "Find the string to insert into the REPL by looking for the overlay at PT. -Might error unless NO-ERROR set." - (let ((o (cider-repl-history-target-overlay-at pt t))) - (if o - (overlay-get o 'cider-repl-history-target) - (unless no-error - (error "No CIDER history item in this buffer"))))) - -(defun cider-repl-history-do-insert (_buf pt) - "Helper function to insert text from BUF at PT into the REPL buffer. -Also kills *cider-repl-history*." - ;; Note: as mentioned at the top, this file is based on browse-kill-ring, - ;; which has numerous insertion options. The functionality of - ;; browse-kill-ring allows users to insert at point, and move point to the end - ;; of the inserted text; or insert at the beginning or end of the buffer, - ;; while leaving point alone. And each of these had the option of leaving the - ;; history buffer in place, or getting rid of it. That was appropriate for a - ;; generic paste tool, but for inserting a previous command into an - ;; interpreter, I felt the only useful option would be inserting it at the end - ;; and quitting the history buffer, so that is all that's provided. - (let ((str (cider-repl-history-current-string pt))) - (cider-repl-history-quit) - (with-selected-window cider-repl-history-repl-window - (with-current-buffer cider-repl-history-repl-buffer - (let ((max (point-max))) - (if (= max (point)) - (cider-repl-history-insert-and-highlight str) - (save-excursion - (goto-char max) - (cider-repl-history-insert-and-highlight str)))))))) - -(defun cider-repl-history-insert-and-quit () - "Insert the item into the REPL buffer, and close *cider-repl-history*. - -The text is always inserted at the very bottom of the REPL buffer. If your -cursor is already at the bottom, it is advanced to the end of the inserted -text. If your cursor is somewhere else, the cursor is not moved, but the -text is still inserted at the end." - (interactive) - (cider-repl-history-do-insert (current-buffer) (point))) - -(defun cider-repl-history-mouse-insert (e) - "Insert the item at E into the REPL buffer, and close *cider-repl-history*. - -The text is always inserted at the very bottom of the REPL buffer. If your -cursor is already at the bottom, it is advanced to the end of the inserted -text. If your cursor is somewhere else, the cursor is not moved, but the -text is still inserted at the end." - (interactive "e") - (let* ((data (save-excursion - (mouse-set-point e) - (cons (current-buffer) (point)))) - (buf (car data)) - (pt (cdr data))) - (cider-repl-history-do-insert buf pt))) - -(defun cider-repl-history-clear-highlighted-entry () - "Clear the highlighted entry, when one exists." - (when cider-repl-history-previous-overlay - (cl-assert (overlayp cider-repl-history-previous-overlay) - nil "not an overlay") - (overlay-put cider-repl-history-previous-overlay 'face nil))) - -(defun cider-repl-history-update-highlighted-entry () - "Update highlighted entry, when feature is turned on." - (when cider-repl-history-highlight-current-entry - (if-let* ((current-overlay (cider-repl-history-target-overlay-at (point) t))) - (unless (equal cider-repl-history-previous-overlay current-overlay) - ;; We've changed overlay. Clear current highlighting, - ;; and highlight the new overlay. - (cl-assert (overlay-get current-overlay 'cider-repl-history-target) t) - (cider-repl-history-clear-highlighted-entry) - (setq cider-repl-history-previous-overlay current-overlay) - (overlay-put current-overlay 'face - cider-repl-history-current-entry-face)) - ;; No overlay at point. Just clear all current highlighting. - (cider-repl-history-clear-highlighted-entry)))) - -(defun cider-repl-history-forward (&optional arg) - "Move forward by ARG command history entries." - (interactive "p") - (beginning-of-line) - (while (not (zerop arg)) - (let ((o (cider-repl-history-target-overlay-at (point) t))) - (cond - ((>= arg 0) - (setq arg (1- arg)) - ;; We're on a cider-repl-history overlay, skip to the end of it. - (when o - (goto-char (overlay-end o)) - (setq o nil)) - (while (not (or o (eobp))) - (goto-char (next-overlay-change (point))) - (setq o (cider-repl-history-target-overlay-at (point) t)))) - (t - (setq arg (1+ arg)) - (when o - (goto-char (overlay-start o)) - (setq o nil)) - (while (not (or o (bobp))) - (goto-char (previous-overlay-change (point))) - (setq o (cider-repl-history-target-overlay-at (point) t))))))) - (when cider-repl-history-recenter - (recenter 1))) - -(defun cider-repl-history-previous (&optional arg) - "Move backward by ARG command history entries." - (interactive "p") - (cider-repl-history-forward (- arg))) - -(defun cider-repl-history-search-forward (regexp &optional backwards) - "Move to the next command history entry matching REGEXP from point. -If optional arg BACKWARDS is non-nil, move to the previous matching -entry." - (interactive - (list (cider-repl-history-read-regexp "Search forward" t) - current-prefix-arg)) - (let ((orig (point))) - (cider-repl-history-forward (if backwards -1 1)) - (let ((over (cider-repl-history-target-overlay-at (point) t))) - (while (and over - (not (if backwards (bobp) (eobp))) - (not (string-match regexp - (overlay-get over - 'cider-repl-history-target)))) - (cider-repl-history-forward (if backwards -1 1)) - (setq over (cider-repl-history-target-overlay-at (point) t))) - (unless (and over - (string-match regexp - (overlay-get over - 'cider-repl-history-target))) - (goto-char orig) - (message "No more command history entries matching %s" regexp))))) - -(defun cider-repl-history-search-backward (regexp) - "Move to the previous command history entry matching REGEXP from point." - (interactive - (list (cider-repl-history-read-regexp "Search backward" t))) - (cider-repl-history-search-forward regexp t)) - -(defun cider-repl-history-elide (str) - ;; FIXME: Use `truncate-string-to-width'? - "If STR is too long, abbreviate it with an ellipsis. -Otherwise, return it unchanged." - (if (and cider-repl-history-maximum-display-length - (> (length str) - cider-repl-history-maximum-display-length)) - (concat (substring str 0 (- cider-repl-history-maximum-display-length 3)) - (propertize "..." 'cider-repl-history-extra t)) - str)) - -(defmacro cider-repl-history-add-overlays-for (item &rest body) - "Add overlays for ITEM, and execute BODY." - (let ((beg (cl-gensym "cider-repl-history-add-overlays-")) - (end (cl-gensym "cider-repl-history-add-overlays-"))) - `(let ((,beg (point)) - (,end - (progn - ,@body - (point)))) - (let ((o (make-overlay ,beg ,end))) - (overlay-put o 'cider-repl-history-target ,item) - (overlay-put o 'mouse-face 'highlight))))) - -(defun cider-repl-history-insert-as-separated (items) - "Insert ITEMS into the current buffer, with separators between items." - (while items - (let* ((origitem (car items)) - (item (cider-repl-history-elide origitem)) - ) ;; (len (length item)) - (cider-repl-history-add-overlays-for origitem (insert item)) - ;; When the command history has items with read-only text property at - ;; **the end of** string, cider-repl-history-setup fails with error - ;; `Text is read-only'. So inhibit-read-only here. - ;; See http://bugs.debian.org/225082 - (let ((inhibit-read-only t)) - (insert "\n") - (when (cdr items) - (insert (propertize cider-repl-history-separator - 'cider-repl-history-extra t - 'cider-repl-history-separator t)) - (insert "\n")))) - (setq items (cdr items)))) - -(defun cider-repl-history-insert-as-one-line (items) - "Insert ITEMS into the current buffer, formatting each item as a single line. - -An explicit newline character will replace newlines so that the text retains its -spacing when it's actually inserted into the REPL buffer." - (dolist (item items) - (cider-repl-history-add-overlays-for - item - (let* ((item (cider-repl-history-elide item)) - (len (length item)) - (start 0) - (newl (propertize "\\n" 'cider-repl-history-extra t))) - (while (and (< start len) - (string-match "\n" item start)) - (insert (substring item start (match-beginning 0)) - newl) - (setq start (match-end 0))) - (insert (substring item start len)))) - (insert "\n"))) - -(defun cider-repl-history-preview-update-text (preview-text) - "Update `cider-repl-history-preview-overlay' to show `PREVIEW-TEXT`." - ;; If preview-text is nil, replacement should be nil too. - (cl-assert (overlayp cider-repl-history-preview-overlay)) - (let ((replacement (when preview-text - (propertize preview-text 'face 'highlight)))) - (overlay-put cider-repl-history-preview-overlay - 'before-string replacement))) - -(defun cider-repl-history-preview-update-by-position (&optional pt) - "Update `cider-repl-history-preview-overlay' to match item at PT. - -This function is called whenever the selection in the *cider-repl-history* -buffer is adjusted, the `cider-repl-history-preview-overlay' -is updated to preview the text of the selection at PT (or the -current point if not specified)." - (let ((new-text (cider-repl-history-current-string - (or pt (point)) t))) - (cider-repl-history-preview-update-text new-text))) - -(defun cider-repl-history-undo-other-window () - "Undo the most recent change in the other window's buffer. -You most likely want to use this command for undoing an insertion of -text from the *cider-repl-history* buffer." - (interactive) - (with-current-buffer cider-repl-history-repl-buffer - (undo))) - -(defun cider-repl-history-setup (repl-win repl-buf history-buf &optional regexp) - "Setup. -REPL-WIN and REPL-BUF are where to insert commands; -HISTORY-BUF is the history, and optional arg REGEXP is a filter." - (cider-repl-history-preview-overlay-setup repl-buf) - (with-current-buffer history-buf - (unwind-protect - (progn - (cider-repl-history-mode) - (setq buffer-read-only nil) - (when (eq 'one-line cider-repl-history-display-style) - (setq truncate-lines t)) - (let ((inhibit-read-only t)) - (erase-buffer)) - (setq cider-repl-history-repl-buffer repl-buf) - (setq cider-repl-history-repl-window repl-win) - (let* ((cider-repl-history-maximum-display-length - (if (and cider-repl-history-maximum-display-length - (<= cider-repl-history-maximum-display-length 3)) - 4 - cider-repl-history-maximum-display-length)) - (cider-command-history (cider-repl-history-get-history)) - (items (mapcar - (if cider-repl-history-text-properties - #'copy-sequence - #'substring-no-properties) - cider-command-history))) - (unless cider-repl-history-display-duplicates - ;; display highest or lowest duplicate. - ;; if `cider-repl-history-display-duplicate-highest' is t, - ;; display highest (most recent) duplicate. - (cl-delete-duplicates - items - :test #'equal - :from-end cider-repl-history-display-duplicate-highest)) - (when (stringp regexp) - (setq items (delq nil - (mapcar - #'(lambda (item) - (when (string-match regexp item) - item)) - items)))) - (funcall (or (cdr (assq cider-repl-history-display-style - cider-repl-history-display-styles)) - (error "Invalid `cider-repl-history-display-style': %s" - cider-repl-history-display-style)) - items) - (when cider-repl-history-show-preview - (cider-repl-history-preview-update-by-position (point-min)) - ;; Local post-command-hook, only happens in *cider-repl-history* - (add-hook 'post-command-hook - #'cider-repl-history-preview-update-by-position - nil t) - (add-hook 'kill-buffer-hook - #'cider-repl-history-cleanup-on-exit - nil t)) - (when cider-repl-history-highlight-current-entry - (add-hook 'post-command-hook - #'cider-repl-history-update-highlighted-entry - nil t)) - (message - (let ((entry (if (= 1 (length cider-command-history)) - "entry" - "entries"))) - (concat - (if (and (not regexp) - cider-repl-history-display-duplicates) - (format "%s %s in the command history." - (length cider-command-history) entry) - (format "%s (of %s) %s in the command history shown." - (length items) (length cider-command-history) entry)) - (substitute-command-keys - (concat " Type \\[cider-repl-history-quit] to quit. " - "\\[describe-mode] for help."))))) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (cider-repl-history-forward 0) - (setq mode-name (if regexp - (concat "History [" regexp "]") - "History")) - (run-hooks 'cider-repl-history-hook))) - (setq buffer-read-only t)))) - -(defun cider-repl-history-update () - "Update the history buffer to reflect the latest state of the command history." - (interactive) - (cl-assert (eq major-mode 'cider-repl-history-mode)) - (cider-repl-history-setup cider-repl-history-repl-window - cider-repl-history-repl-buffer - (current-buffer)) - (cider-repl-history-resize-window)) - -(defun cider-repl-history-occur (regexp) - "Display all command history entries matching REGEXP." - (interactive - (list (cider-repl-history-read-regexp - "Display command history entries matching" nil))) - (cl-assert (eq major-mode 'cider-repl-history-mode)) - (cider-repl-history-setup cider-repl-history-repl-window - cider-repl-history-repl-buffer - (current-buffer) - regexp) - (cider-repl-history-resize-window)) - -(defvar cider-repl-history-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "n") #'cider-repl-history-forward) - (define-key map (kbd "p") #'cider-repl-history-previous) - (define-key map (kbd "SPC") #'cider-repl-history-insert-and-quit) - (define-key map (kbd "RET") #'cider-repl-history-insert-and-quit) - (define-key map [(mouse-2)] #'cider-repl-history-mouse-insert) - (define-key map (kbd "l") #'cider-repl-history-occur) - (define-key map (kbd "s") #'cider-repl-history-search-forward) - (define-key map (kbd "r") #'cider-repl-history-search-backward) - (define-key map (kbd "g") #'cider-repl-history-update) - (define-key map (kbd "q") #'cider-repl-history-quit) - (define-key map (kbd "U") #'cider-repl-history-undo-other-window) - (define-key map (kbd "?") #'describe-mode) - (define-key map (kbd "h") #'describe-mode) - map)) - -(put 'cider-repl-history-mode 'mode-class 'special) -(define-derived-mode cider-repl-history-mode clojure-mode "History" - "Major mode for browsing the entries in the command input history." - (setq-local sesman-system 'CIDER)) - -;;;###autoload -(defun cider-repl-history () - "Display items in the CIDER command history in another buffer." - (interactive) - (when (eq major-mode 'cider-repl-history-mode) - (user-error "Already viewing the CIDER command history")) - - (let* ((repl-win (selected-window)) - (repl-buf (window-buffer repl-win)) - (buf (get-buffer-create cider-repl-history-buffer))) - (cider-repl-history-setup repl-win repl-buf buf) - (pop-to-buffer buf) - (cider-repl-history-resize-window))) - -(provide 'cider-repl-history) - -;;; cider-repl-history.el ends here diff --git a/elpa/cider-20230707.640/cider-repl.el b/elpa/cider-20230707.640/cider-repl.el deleted file mode 100644 index 3245690f..00000000 --- a/elpa/cider-20230707.640/cider-repl.el +++ /dev/null @@ -1,1883 +0,0 @@ -;;; cider-repl.el --- CIDER REPL mode interactions -*- lexical-binding: t -*- - -;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Tim King -;; Phil Hagelberg -;; Bozhidar Batsov -;; Artur Malabarba -;; Hugo Duncan -;; Steve Purcell -;; Reid McKenzie - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; This functionality concerns `cider-repl-mode' and REPL interaction. For -;; REPL/connection life-cycle management see cider-connection.el. - -;;; Code: - -(require 'cl-lib) -(require 'easymenu) -(require 'image) -(require 'map) -(require 'seq) -(require 'subr-x) - -(require 'clojure-mode) -(require 'sesman) - -(require 'cider-client) -(require 'cider-doc) -(require 'cider-test) -(require 'cider-eldoc) ; for cider-eldoc-setup -(require 'cider-common) -(require 'cider-util) -(require 'cider-resolve) - -(declare-function cider-inspect "cider-inspector") - - -(defgroup cider-repl nil - "Interaction with the REPL." - :prefix "cider-repl-" - :group 'cider) - -(defface cider-repl-prompt-face - '((t (:inherit font-lock-keyword-face))) - "Face for the prompt in the REPL buffer.") - -(defface cider-repl-stdout-face - '((t (:inherit font-lock-string-face))) - "Face for STDOUT output in the REPL buffer.") - -(defface cider-repl-stderr-face - '((t (:inherit font-lock-warning-face))) - "Face for STDERR output in the REPL buffer." - :package-version '(cider . "0.6.0")) - -(defface cider-repl-input-face - '((t (:bold t))) - "Face for previous input in the REPL buffer.") - -(defface cider-repl-result-face - '((t ())) - "Face for the result of an evaluation in the REPL buffer.") - -(defcustom cider-repl-pop-to-buffer-on-connect t - "Controls whether to pop to the REPL buffer on connect. - -When set to nil the buffer will only be created, and not displayed. When -set to `display-only' the buffer will be displayed, but it will not become -focused. Otherwise the buffer is displayed and focused." - :type '(choice (const :tag "Create the buffer, but don't display it" nil) - (const :tag "Create and display the buffer, but don't focus it" - display-only) - (const :tag "Create, display, and focus the buffer" t))) - -(defcustom cider-repl-display-in-current-window nil - "Controls whether the REPL buffer is displayed in the current window." - :type 'boolean) - -(make-obsolete-variable 'cider-repl-scroll-on-output 'scroll-conservatively "0.21") - -(defcustom cider-repl-use-pretty-printing t - "Control whether results in the REPL are pretty-printed or not. -The REPL will use the printer specified in `cider-print-fn'. -The `cider-toggle-pretty-printing' command can be used to interactively -change the setting's value." - :type 'boolean) - -(make-obsolete-variable 'cider-repl-pretty-print-width 'cider-print-options "0.21") - -(defcustom cider-repl-use-content-types nil - "Control whether REPL results are presented using content-type information. -The `cider-repl-toggle-content-types' command can be used to interactively -change the setting's value." - :type 'boolean - :package-version '(cider . "0.17.0")) - -(defcustom cider-repl-auto-detect-type t - "Control whether to auto-detect the REPL type using track-state information. -If you disable this you'll have to manually change the REPL type between -Clojure and ClojureScript when invoking REPL type changing forms. -Use `cider-set-repl-type' to manually change the REPL type." - :type 'boolean - :safe #'booleanp - :package-version '(cider . "0.18.0")) - -(defcustom cider-repl-use-clojure-font-lock t - "Non-nil means to use Clojure mode font-locking for input and result. -Nil means that `cider-repl-input-face' and `cider-repl-result-face' -will be used." - :type 'boolean - :package-version '(cider . "0.10.0")) - -(defcustom cider-repl-require-ns-on-set nil - "Controls whether to require the ns before setting it in the REPL." - :type 'boolean - :package-version '(cider . "0.22.0")) - -(defcustom cider-repl-result-prefix "" - "The prefix displayed in the REPL before a result value. -By default there's no prefix, but you can specify something -like \"=>\" if want results to stand out more." - :type 'string - :group 'cider - :package-version '(cider . "0.5.0")) - -(defcustom cider-repl-tab-command 'cider-repl-indent-and-complete-symbol - "Select the command to be invoked by the TAB key. -The default option is `cider-repl-indent-and-complete-symbol'. If -you'd like to use the default Emacs behavior use -`indent-for-tab-command'." - :type 'symbol) - -(make-obsolete-variable 'cider-repl-print-length 'cider-print-options "0.21") -(make-obsolete-variable 'cider-repl-print-level 'cider-print-options "0.21") - -(defvar cider-repl-require-repl-utils-code - '((clj . "(when-let [requires (resolve 'clojure.main/repl-requires)] - (clojure.core/apply clojure.core/require @requires))") - (cljs . "(require '[cljs.repl :refer [apropos dir doc find-doc print-doc pst source]])"))) - -(defcustom cider-repl-init-code (list (cdr (assoc 'clj cider-repl-require-repl-utils-code))) - "Clojure code to evaluate when starting a REPL. -Will be evaluated with bindings for set!-able vars in place. - -See also `cider-repl-eval-init-code'." - :type '(list string) - :package-version '(cider . "0.21.0")) - -(defcustom cider-repl-display-help-banner t - "When non-nil a bit of help text will be displayed on REPL start." - :type 'boolean - :package-version '(cider . "0.11.0")) - -;; See https://github.com/clojure-emacs/cider/issues/3219 for more details -(defcustom cider-repl-display-output-before-window-boundaries nil - "Controls whether to display output emitted before the REPL window boundaries. - -If the prompt is on the first line of the window, then scroll the window -down by a single line to make the emitted output visible. - -That behavior is desirable, but rarely needed and it slows down printing -output a lot (e.g. 10x) that's why it's disable by default starting with -CIDER 1.7." - :type 'boolean - :package-version '(cider . "1.7.0")) - - -;;;; REPL buffer local variables -(defvar-local cider-repl-input-start-mark nil) - -(defvar-local cider-repl-prompt-start-mark nil) - -(defvar-local cider-repl-old-input-counter 0 - "Counter used to generate unique `cider-old-input' properties. -This property value must be unique to avoid having adjacent inputs be -joined together.") - -(defvar-local cider-repl-input-history '() - "History list of strings read from the REPL buffer.") - -(defvar-local cider-repl-input-history-items-added 0 - "Variable counting the items added in the current session.") - -(defvar-local cider-repl-output-start nil - "Marker for the start of output. -Currently its only purpose is to facilitate `cider-repl-clear-buffer'.") - -(defvar-local cider-repl-output-end nil - "Marker for the end of output. -Currently its only purpose is to facilitate `cider-repl-clear-buffer'.") - -(defun cider-repl-tab () - "Invoked on TAB keystrokes in `cider-repl-mode' buffers." - (interactive) - (funcall cider-repl-tab-command)) - -(defun cider-repl-reset-markers () - "Reset all REPL markers." - (dolist (markname '(cider-repl-output-start - cider-repl-output-end - cider-repl-prompt-start-mark - cider-repl-input-start-mark)) - (set markname (make-marker)) - (set-marker (symbol-value markname) (point)))) - - -;;; REPL init - -(defvar-local cider-repl-ns-cache nil - "A dict holding information about all currently loaded namespaces. -This cache is stored in the connection buffer.") - -(defvar cider-mode) -(declare-function cider-refresh-dynamic-font-lock "cider-mode") - -(defun cider-repl--state-handler (response) - "Handle server state contained in RESPONSE." - (with-demoted-errors "Error in `cider-repl--state-handler': %s" - (when (member "state" (nrepl-dict-get response "status")) - (nrepl-dbind-response response (repl-type changed-namespaces) - (when (and repl-type cider-repl-auto-detect-type) - (cider-set-repl-type repl-type)) - (when (eq (cider-maybe-intern repl-type) 'cljs) - (setq cider-repl-cljs-upgrade-pending nil)) - (unless (nrepl-dict-empty-p changed-namespaces) - (setq cider-repl-ns-cache (nrepl-dict-merge cider-repl-ns-cache changed-namespaces)) - (dolist (b (buffer-list)) - (with-current-buffer b - ;; Metadata changed, so signatures may have changed too. - (setq cider-eldoc-last-symbol nil) - (when (or cider-mode (derived-mode-p 'cider-repl-mode)) - (when-let* ((ns-dict (or (nrepl-dict-get changed-namespaces (cider-current-ns)) - (let ((ns-dict (cider-resolve--get-in (cider-current-ns)))) - (when (seq-find (lambda (ns) (nrepl-dict-get changed-namespaces ns)) - (nrepl-dict-get ns-dict "aliases")) - ns-dict))))) - (cider-refresh-dynamic-font-lock ns-dict)))))))))) - -(defun cider-repl-require-repl-utils () - "Require standard REPL util functions into the current REPL." - (interactive) - (let* ((current-repl (cider-current-repl nil 'ensure)) - (require-code (cdr (assoc (cider-repl-type current-repl) cider-repl-require-repl-utils-code)))) - (nrepl-send-sync-request - (lax-plist-put - (nrepl--eval-request require-code (cider-current-ns)) - "inhibit-cider-middleware" "true") - current-repl))) - -(defun cider-repl-init-eval-handler (&optional callback) - "Make an nREPL evaluation handler for use during REPL init. -Run CALLBACK once the evaluation is complete." - (nrepl-make-response-handler (current-buffer) - (lambda (_buffer _value)) - (lambda (buffer out) - (cider-repl-emit-stdout buffer out)) - (lambda (buffer err) - (cider-repl-emit-stderr buffer err)) - (lambda (buffer) - (cider-repl-emit-prompt buffer) - (when callback - (funcall callback))))) - -(defun cider-repl-eval-init-code (&optional callback) - "Evaluate `cider-repl-init-code' in the current REPL. -Run CALLBACK once the evaluation is complete." - (interactive) - (let* ((request (map-merge 'hash-table - (cider--repl-request-map fill-column) - '(("inhibit-cider-middleware" "true"))))) - (cider-nrepl-request:eval - ;; Ensure we evaluate _something_ so the initial namespace is correctly set - (thread-first (or cider-repl-init-code '("nil")) - (string-join "\n")) - (cider-repl-init-eval-handler callback) - nil - (line-number-at-pos (point)) - (cider-column-number-at-pos (point)) - (thread-last - request - (map-pairs) - (seq-mapcat #'identity))))) - -(defun cider-repl-init (buffer &optional callback) - "Initialize the REPL in BUFFER. -BUFFER must be a REPL buffer with `cider-repl-mode' and a running -client process connection. CALLBACK will be run once the REPL is -fully initialized." - (when cider-repl-display-in-current-window - (add-to-list 'same-window-buffer-names (buffer-name buffer))) - (pcase cider-repl-pop-to-buffer-on-connect - (`display-only - (let ((orig-buffer (current-buffer))) - (display-buffer buffer) - ;; User popup-rules (specifically `:select nil') can cause the call to - ;; `display-buffer' to reset the current Emacs buffer to the clj/cljs - ;; buffer that the user ran `jack-in' from - we need the current-buffer - ;; to be the repl to initialize, so reset it back here to be resilient - ;; against user config - (set-buffer orig-buffer))) - ((pred identity) (pop-to-buffer buffer))) - (with-current-buffer buffer - (cider-repl--insert-banner) - (cider-repl--insert-startup-commands) - (when-let* ((window (get-buffer-window buffer t))) - (with-selected-window window - (recenter (- -1 scroll-margin)))) - (cider-repl-eval-init-code callback)) - buffer) - -(defun cider-repl--insert-banner () - "Insert the banner in the current REPL buffer." - (insert-before-markers - (propertize (cider-repl--banner) 'font-lock-face 'font-lock-comment-face)) - (when cider-repl-display-help-banner - (insert-before-markers - (propertize (cider-repl--help-banner) 'font-lock-face 'font-lock-comment-face)))) - -(defun cider-repl--insert-startup-commands () - "Insert the values from params specified in PARAM-TUPLES. -PARAM-TUPLES are tuples of (param-key description) or (param-key -description transform) where transform is called with the param-value if -present." - (cl-labels - ((emit-comment - (contents) - (insert-before-markers - (propertize - (if (string-blank-p contents) ";;\n" (concat ";; " contents "\n")) - 'font-lock-face 'font-lock-comment-face)))) - (let ((jack-in-command (plist-get cider-launch-params :jack-in-cmd)) - (cljs-repl-type (plist-get cider-launch-params :cljs-repl-type)) - (cljs-init-form (plist-get cider-launch-params :repl-init-form))) - (when jack-in-command - ;; spaces to align with the banner - (emit-comment (concat " Startup: " jack-in-command))) - (when (or cljs-repl-type cljs-init-form) - (emit-comment "") - (when cljs-repl-type - (emit-comment (concat "ClojureScript REPL type: " (symbol-name cljs-repl-type)))) - (when cljs-init-form - (emit-comment (concat "ClojureScript REPL init form: " cljs-init-form))) - (emit-comment ""))))) - -(defun cider-repl--banner () - "Generate the welcome REPL buffer banner." - (cond - ((cider--clojure-version) (cider-repl--clojure-banner)) - ((cider--babashka-version) (cider-repl--babashka-banner)) - (t (cider-repl--basic-banner)))) - -(defun cider-repl--clojure-banner () - "Generate the welcome REPL buffer banner for Clojure(Script)." - (format ";; Connected to nREPL server - nrepl://%s:%s -;; CIDER %s, nREPL %s -;; Clojure %s, Java %s -;; Docs: (doc function-name) -;; (find-doc part-of-name) -;; Source: (source function-name) -;; Javadoc: (javadoc java-object-or-class) -;; Exit: -;; Results: Stored in vars *1, *2, *3, an exception in *e; -" - (plist-get nrepl-endpoint :host) - (plist-get nrepl-endpoint :port) - (cider--version) - (cider--nrepl-version) - (cider--clojure-version) - (cider--java-version))) - -(defun cider-repl--babashka-banner () - "Generate the welcome REPL buffer banner for Babashka." - (format ";; Connected to nREPL server - nrepl://%s:%s -;; CIDER %s, babashka.nrepl %s -;; Babashka %s -;; Docs: (doc function-name) -;; (find-doc part-of-name) -;; Source: (source function-name) -;; Javadoc: (javadoc java-object-or-class) -;; Exit: -;; Results: Stored in vars *1, *2, *3, an exception in *e; -" - (plist-get nrepl-endpoint :host) - (plist-get nrepl-endpoint :port) - (cider--version) - (cider--babashka-nrepl-version) - (cider--babashka-version))) - -(defun cider-repl--basic-banner () - "Generate a basic banner with minimal info." - (format ";; Connected to nREPL server - nrepl://%s:%s -;; CIDER %s -" - (plist-get nrepl-endpoint :host) - (plist-get nrepl-endpoint :port) - (cider--version))) - -(defun cider-repl--help-banner () - "Generate the help banner." - (substitute-command-keys - ";; ====================================================================== -;; If you're new to CIDER it is highly recommended to go through its -;; user manual first. Type to view it. -;; In case you're seeing any warnings you should consult the manual's -;; \"Troubleshooting\" section. -;; -;; Here are a few tips to get you started: -;; -;; * Press <\\[describe-mode]> to see a list of the keybindings available (this -;; will work in every Emacs buffer) -;; * Press <\\[cider-repl-handle-shortcut]> to quickly invoke some REPL command -;; * Press <\\[cider-switch-to-last-clojure-buffer]> to switch between the REPL and a Clojure file -;; * Press <\\[cider-find-var]> to jump to the source of something (e.g. a var, a -;; Java method) -;; * Press <\\[cider-doc]> to view the documentation for something (e.g. -;; a var, a Java method) -;; * Print CIDER's refcard and keep it close to your keyboard. -;; -;; CIDER is super customizable - try to -;; get a feel for this. If you're thirsty for knowledge you should try -;; . -;; -;; If you think you've encountered a bug (or have some suggestions for -;; improvements) use to report it. -;; -;; Above all else - don't panic! In case of an emergency - procure -;; some (hard) cider and enjoy it responsibly! -;; -;; You can remove this message with the command. -;; You can disable it from appearing on start by setting -;; `cider-repl-display-help-banner' to nil. -;; ====================================================================== -")) - - -;;; REPL interaction - -(defun cider-repl--in-input-area-p () - "Return t if in input area." - (<= cider-repl-input-start-mark (point))) - -(defun cider-repl--current-input (&optional until-point-p) - "Return the current input as string. -The input is the region from after the last prompt to the end of -buffer. If UNTIL-POINT-P is non-nil, the input is until the current -point." - (buffer-substring-no-properties cider-repl-input-start-mark - (if until-point-p - (point) - (point-max)))) - -(defun cider-repl-previous-prompt () - "Move backward to the previous prompt." - (interactive) - (cider-repl--find-prompt t)) - -(defun cider-repl-next-prompt () - "Move forward to the next prompt." - (interactive) - (cider-repl--find-prompt)) - -(defun cider-repl--find-prompt (&optional backward) - "Find the next prompt. -If BACKWARD is non-nil look backward." - (let ((origin (point)) - (cider-repl-prompt-property 'field)) - (while (progn - (cider-search-property-change cider-repl-prompt-property backward) - (not (or (cider-end-of-proprange-p cider-repl-prompt-property) (bobp) (eobp))))) - (unless (cider-end-of-proprange-p cider-repl-prompt-property) - (goto-char origin)))) - -(defun cider-search-property-change (prop &optional backward) - "Search forward for a property change to PROP. -If BACKWARD is non-nil search backward." - (cond (backward - (goto-char (previous-single-char-property-change (point) prop))) - (t - (goto-char (next-single-char-property-change (point) prop))))) - -(defun cider-end-of-proprange-p (property) - "Return t if at the the end of a property range for PROPERTY." - (and (get-char-property (max (point-min) (1- (point))) property) - (not (get-char-property (point) property)))) - -(defun cider-repl--mark-input-start () - "Mark the input start." - (set-marker cider-repl-input-start-mark (point) (current-buffer))) - -(defun cider-repl--mark-output-start () - "Mark the output start." - (set-marker cider-repl-output-start (point)) - (set-marker cider-repl-output-end (point))) - -(defun cider-repl-mode-beginning-of-defun (&optional arg) - "Move to the beginning of defun. -If given a negative value of ARG, move to the end of defun." - (if (and arg (< arg 0)) - (cider-repl-mode-end-of-defun (- arg)) - (dotimes (_ (or arg 1)) - (cider-repl-previous-prompt)))) - -(defun cider-repl-mode-end-of-defun (&optional arg) - "Move to the end of defun. -If given a negative value of ARG, move to the beginning of defun." - (if (and arg (< arg 0)) - (cider-repl-mode-beginning-of-defun (- arg)) - (dotimes (_ (or arg 1)) - (cider-repl-next-prompt)))) - -(defun cider-repl-beginning-of-defun () - "Move to beginning of defun." - (interactive) - ;; We call `beginning-of-defun' if we're at the start of a prompt - ;; already, to trigger `cider-repl-mode-beginning-of-defun' by means - ;; of the locally bound `beginning-of-defun-function', in order to - ;; jump to the start of the previous prompt. - (if (and (not (cider-repl--at-prompt-start-p)) - (cider-repl--in-input-area-p)) - (goto-char cider-repl-input-start-mark) - (beginning-of-defun))) - -(defun cider-repl-end-of-defun () - "Move to end of defun." - (interactive) - ;; C.f. `cider-repl-beginning-of-defun' - (if (and (not (= (point) (point-max))) - (cider-repl--in-input-area-p)) - (goto-char (point-max)) - (end-of-defun))) - -(defun cider-repl-bol-mark () - "Set the mark and go to the beginning of line or the prompt." - (interactive) - (unless mark-active - (set-mark (point))) - (move-beginning-of-line 1)) - -(defun cider-repl--at-prompt-start-p () - "Return t if point is at the start of prompt. -This will not work on non-current prompts." - (= (point) cider-repl-input-start-mark)) - -(defmacro cider-save-marker (marker &rest body) - "Save MARKER and execute BODY." - (declare (debug t)) - (let ((pos (make-symbol "pos"))) - `(let ((,pos (marker-position ,marker))) - (prog1 (progn . ,body) - (set-marker ,marker ,pos))))) - -(put 'cider-save-marker 'lisp-indent-function 1) - -(defun cider-repl-prompt-default (namespace) - "Return a prompt string that mentions NAMESPACE." - (format "%s> " namespace)) - -(defun cider-repl-prompt-abbreviated (namespace) - "Return a prompt string that abbreviates NAMESPACE." - (format "%s> " (cider-abbreviate-ns namespace))) - -(defun cider-repl-prompt-lastname (namespace) - "Return a prompt string with the last name in NAMESPACE." - (format "%s> " (cider-last-ns-segment namespace))) - -(defcustom cider-repl-prompt-function #'cider-repl-prompt-default - "A function that returns a prompt string. -Takes one argument, a namespace name. -For convenience, three functions are already provided for this purpose: -`cider-repl-prompt-lastname', `cider-repl-prompt-abbreviated', and -`cider-repl-prompt-default'." - :type '(choice (const :tag "Full namespace" cider-repl-prompt-default) - (const :tag "Abbreviated namespace" cider-repl-prompt-abbreviated) - (const :tag "Last name in namespace" cider-repl-prompt-lastname) - (function :tag "Custom function")) - :package-version '(cider . "0.9.0")) - -(defun cider-repl--insert-prompt (namespace) - "Insert the prompt (before markers!), taking into account NAMESPACE. -Set point after the prompt. -Return the position of the prompt beginning." - (goto-char cider-repl-input-start-mark) - (cider-save-marker cider-repl-output-start - (cider-save-marker cider-repl-output-end - (unless (bolp) (insert-before-markers "\n")) - (let ((prompt-start (point)) - (prompt (funcall cider-repl-prompt-function namespace))) - (cider-propertize-region - '(font-lock-face cider-repl-prompt-face read-only t intangible t - field cider-repl-prompt - rear-nonsticky (field read-only font-lock-face intangible)) - (insert-before-markers prompt)) - (set-marker cider-repl-prompt-start-mark prompt-start) - prompt-start)))) - -(defun cider-repl--ansi-color-apply (string) - "Like `ansi-color-apply', but does not withhold non-SGR seqs found in STRING. - -Workaround for Emacs bug#53808 whereby partial ANSI control seqs present in -the input stream may block the whole colorization process." - (let* ((result (ansi-color-apply string)) - - ;; The STRING may end with a possible incomplete ANSI control seq which - ;; the call to `ansi-color-apply' stores in the `ansi-color-context' - ;; fragment. If the fragment is not an incomplete ANSI color control - ;; sequence (aka SGR seq) though then flush it out and appended it to - ;; the result. - (fragment-flush? - (when-let (fragment (and ansi-color-context (cadr ansi-color-context))) - (save-match-data - ;; Check if fragment is indeed an SGR seq in the making. The SGR - ;; seq is defined as starting with ESC followed by [ followed by - ;; zero or more [:digit:]+; followed by one or more digits and - ;; ending with m. - (when (string-match - (rx (sequence ?\e - (? (and (or ?\[ eol) - (or (+ (any (?0 . ?9))) eol) - (* (sequence ?\; (+ (any (?0 . ?9))))) - (or ?\; eol))))) - fragment) - (let* ((sgr-end-pos (match-end 0)) - (fragment-matches-whole? (or (= sgr-end-pos 0) - (= sgr-end-pos (length fragment))))) - (when (not fragment-matches-whole?) - ;; Definitely not an partial SGR seq, flush it out of - ;; `ansi-color-context'. - t))))))) - - (if (not fragment-flush?) - result - - (progn - ;; Temporarily replace the ESC char in the fragment so that is flushed - ;; out of `ansi-color-context' by `ansi-color-apply' and append it to - ;; the result. - (aset (cadr ansi-color-context) 0 ?\0) - (let ((result-fragment (ansi-color-apply ""))) - (aset result-fragment 0 ?\e) - (concat result result-fragment)))))) - -(defvar-local cider-repl--ns-forms-plist nil - "Plist holding ns->ns-form mappings within each connection.") - -(defun cider-repl--ns-form-changed-p (ns-form connection) - "Return non-nil if NS-FORM for CONNECTION changed since last eval." - (when-let* ((ns (cider-ns-from-form ns-form))) - (not (string= ns-form - (lax-plist-get - (buffer-local-value 'cider-repl--ns-forms-plist connection) - ns))))) - -(defvar cider-repl--root-ns-highlight-template "\\_<\\(%s\\)[^$/: \t\n()]+" - "Regexp used to highlight root ns in REPL buffers.") - -(defvar-local cider-repl--root-ns-regexp nil - "Cache of root ns regexp in REPLs.") - -(defvar-local cider-repl--ns-roots nil - "List holding all past root namespaces seen during interactive eval.") - -(defun cider-repl--cache-ns-form (ns-form connection) - "Given NS-FORM cache root ns in CONNECTION." - (with-current-buffer connection - (when-let* ((ns (cider-ns-from-form ns-form))) - ;; cache ns-form - (setq cider-repl--ns-forms-plist - (lax-plist-put cider-repl--ns-forms-plist ns ns-form)) - ;; cache ns roots regexp - (when (string-match "\\([^.]+\\)" ns) - (let ((root (match-string-no-properties 1 ns))) - (unless (member root cider-repl--ns-roots) - (push root cider-repl--ns-roots) - (let ((roots (mapconcat - ;; Replace _ or - with regexp pattern to accommodate "raw" namespaces - (lambda (r) (replace-regexp-in-string "[_-]+" "[_-]+" r)) - cider-repl--ns-roots "\\|"))) - (setq cider-repl--root-ns-regexp - (format cider-repl--root-ns-highlight-template roots))))))))) - -(defvar cider-repl-spec-keywords-regexp - (concat - (regexp-opt '("In:" " val:" - " at:" "fails at:" - " spec:" "fails spec:" - " predicate:" "fails predicate:")) - "\\|^" - (regexp-opt '(":clojure.spec.alpha/spec" - ":clojure.spec.alpha/value") - "\\(")) - "Regexp matching clojure.spec `explain` keywords.") - -(defun cider-repl-highlight-spec-keywords (string) - "Highlight clojure.spec `explain` keywords in STRING. -Foreground of `clojure-keyword-face' is used for highlight." - (cider-add-face cider-repl-spec-keywords-regexp - 'clojure-keyword-face t nil string) - string) - -(defun cider-repl-highlight-current-project (string) - "Fontify project's root namespace to make stacktraces more readable. -Foreground of `cider-stacktrace-ns-face' is used to propertize matched -namespaces. STRING is REPL's output." - (cider-add-face cider-repl--root-ns-regexp 'cider-stacktrace-ns-face - t nil string) - string) - -(defun cider-repl-add-locref-help-echo (string) - "Set help-echo property of STRING to `cider-locref-help-echo'." - (put-text-property 0 (length string) 'help-echo 'cider-locref-help-echo string) - string) - -(defvar cider-repl-preoutput-hook `(,(if (< emacs-major-version 29) - 'cider-repl--ansi-color-apply - 'ansi-color-apply) - cider-repl-highlight-current-project - cider-repl-highlight-spec-keywords - cider-repl-add-locref-help-echo) - "Hook run on output string before it is inserted into the REPL buffer. -Each functions takes a string and must return a modified string. Also see -`cider-run-chained-hook'.") - -(defcustom cider-repl-buffer-size-limit nil - "The max size of the REPL buffer. -Setting this to nil removes the limit." - :group 'cider - :type 'integer - :package-version '(cider . "0.26.0")) - -(defun cider-start-of-next-prompt (point) - "Return the position of the first char of the next prompt from POINT." - (let ((next-prompt-or-input (next-single-char-property-change point 'field))) - (if (eq (get-char-property next-prompt-or-input 'field) 'cider-repl-prompt) - next-prompt-or-input - (next-single-char-property-change next-prompt-or-input 'field)))) - -(defun cider-repl-trim-top-of-buffer (buffer) - "Trims REPL output from beginning of BUFFER. -Trims by one fifth of `cider-repl-buffer-size-limit'. -Also clears remaining partial input or results." - (with-current-buffer buffer - (let* ((to-trim (ceiling (* cider-repl-buffer-size-limit 0.2))) - (start-of-next-prompt (cider-start-of-next-prompt to-trim)) - (inhibit-read-only t)) - (cider-repl--clear-region (point-min) start-of-next-prompt)))) - -(defun cider-repl-trim-buffer () - "Trim the currently visited REPL buffer partially from the top. -See also `cider-repl-clear-buffer'." - (interactive) - (if cider-repl-buffer-size-limit - (cider-repl-trim-top-of-buffer (current-buffer)) - (user-error "The variable `cider-repl-buffer-size-limit' is not set"))) - -(defun cider-repl-maybe-trim-buffer (buffer) - "Clear portion of printed output in BUFFER. -Clear the part where `cider-repl-buffer-size-limit' is exceeded." - (when (> (buffer-size) cider-repl-buffer-size-limit) - (cider-repl-trim-top-of-buffer buffer))) - -(defun cider-repl--emit-output (buffer string face) - "Using BUFFER, emit STRING as output font-locked using FACE. -Before inserting, run `cider-repl-preoutput-hook' on STRING." - (with-current-buffer buffer - (save-excursion - (cider-save-marker cider-repl-output-start - (goto-char cider-repl-output-end) - (setq string (propertize string - 'font-lock-face face - 'rear-nonsticky '(font-lock-face))) - (setq string (cider-run-chained-hook 'cider-repl-preoutput-hook string)) - (insert-before-markers string)) - (when (and (= (point) cider-repl-prompt-start-mark) - (not (bolp))) - (insert-before-markers "\n") - (set-marker cider-repl-output-end (1- (point)))))) - (when cider-repl-display-output-before-window-boundaries - ;; FIXME: The code below is super slow, that's why it's disabled by default. - (when-let* ((window (get-buffer-window buffer t))) - ;; If the prompt is on the first line of the window, then scroll the window - ;; down by a single line to make the emitted output visible. - (when (and (pos-visible-in-window-p cider-repl-prompt-start-mark window) - (< 1 cider-repl-prompt-start-mark) - (not (pos-visible-in-window-p (1- cider-repl-prompt-start-mark) window))) - (with-selected-window window - (scroll-down 1)))))) - -(defun cider-repl--emit-interactive-output (string face) - "Emit STRING as interactive output using FACE." - (cider-repl--emit-output (cider-current-repl) string face)) - -(defun cider-repl-emit-interactive-stdout (string) - "Emit STRING as interactive output." - (cider-repl--emit-interactive-output string 'cider-repl-stdout-face)) - -(defun cider-repl-emit-interactive-stderr (string) - "Emit STRING as interactive err output." - (cider-repl--emit-interactive-output string 'cider-repl-stderr-face)) - -(defun cider-repl-emit-stdout (buffer string) - "Using BUFFER, emit STRING as standard output." - (cider-repl--emit-output buffer string 'cider-repl-stdout-face)) - -(defun cider-repl-emit-stderr (buffer string) - "Using BUFFER, emit STRING as error output." - (cider-repl--emit-output buffer string 'cider-repl-stderr-face)) - -(defun cider-repl-emit-prompt (buffer) - "Emit the REPL prompt into BUFFER." - (with-current-buffer buffer - (save-excursion - (cider-repl--insert-prompt cider-buffer-ns)))) - -(defun cider-repl-emit-result (buffer string show-prefix &optional bol) - "Emit into BUFFER the result STRING and mark it as an evaluation result. -If SHOW-PREFIX is non-nil insert `cider-repl-result-prefix' at the beginning -of the line. If BOL is non-nil insert at the beginning of the line." - (with-current-buffer buffer - (save-excursion - (cider-save-marker cider-repl-output-start - (goto-char cider-repl-output-end) - (when (and bol (not (bolp))) - (insert-before-markers "\n")) - (when show-prefix - (insert-before-markers (propertize cider-repl-result-prefix 'font-lock-face 'font-lock-comment-face))) - (if cider-repl-use-clojure-font-lock - (insert-before-markers (cider-font-lock-as-clojure string)) - (cider-propertize-region - '(font-lock-face cider-repl-result-face rear-nonsticky (font-lock-face)) - (insert-before-markers string))))))) - -(defun cider-repl-newline-and-indent () - "Insert a newline, then indent the next line. -Restrict the buffer from the prompt for indentation, to avoid being -confused by strange characters (like unmatched quotes) appearing -earlier in the buffer." - (interactive) - (save-restriction - (narrow-to-region cider-repl-prompt-start-mark (point-max)) - (insert "\n") - (lisp-indent-line))) - -(defun cider-repl-indent-and-complete-symbol () - "Indent the current line and perform symbol completion. -First indent the line. If indenting doesn't move point, complete -the symbol." - (interactive) - (let ((pos (point))) - (lisp-indent-line) - (when (= pos (point)) - (if (save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t)) - (completion-at-point))))) - -(defun cider-repl-kill-input () - "Kill all text from the prompt to point." - (interactive) - (cond ((< (marker-position cider-repl-input-start-mark) (point)) - (kill-region cider-repl-input-start-mark (point))) - ((= (point) (marker-position cider-repl-input-start-mark)) - (cider-repl-delete-current-input)))) - -(defun cider-repl--input-complete-p (start end) - "Return t if the region from START to END is a complete sexp." - (save-excursion - (goto-char start) - (cond ((looking-at-p "\\s *[@'`#]?[(\"]") - (ignore-errors - (save-restriction - (narrow-to-region start end) - ;; Keep stepping over blanks and sexps until the end of - ;; buffer is reached or an error occurs. Tolerate extra - ;; close parens. - (cl-loop do (skip-chars-forward " \t\r\n)") - until (eobp) - do (forward-sexp)) - t))) - (t t)))) - -(defun cider-repl--display-image (buffer image &optional show-prefix bol) - "Insert IMAGE into BUFFER at the current point. - -For compatibility with the rest of CIDER's REPL machinery, supports -SHOW-PREFIX and BOL." - (with-current-buffer buffer - (save-excursion - (cider-save-marker cider-repl-output-start - (goto-char cider-repl-output-end) - (when (and bol (not (bolp))) - (insert-before-markers "\n")) - (when show-prefix - (insert-before-markers - (propertize cider-repl-result-prefix 'font-lock-face 'font-lock-comment-face))) - ;; The below is inlined from `insert-image' and changed to use - ;; `insert-before-markers' rather than `insert' - (let ((start (point)) - (props (nconc `(display ,image rear-nonsticky (display)) - (when (boundp 'image-map) - `(keymap ,image-map))))) - (insert-before-markers " ") - (add-text-properties start (point) props))))) - t) - -(defcustom cider-repl-image-margin 10 - "Specifies the margin to be applied to images displayed in the REPL. -Either a single number of pixels - interpreted as a symmetric margin, or -pair of numbers `(x . y)' encoding an arbitrary margin." - :type '(choice integer (vector integer integer)) - :package-version '(cider . "0.17.0")) - -(defun cider-repl--image (data type datap) - "A helper for creating images with CIDER's image options. -DATA is either the path to an image or its base64 coded data. TYPE is a -symbol indicating the image type. DATAP indicates whether the image is the -raw image data or a filename. Returns an image instance with a margin per -`cider-repl-image-margin'." - (create-image data type datap - :margin cider-repl-image-margin)) - -(defun cider-repl-handle-jpeg (_type buffer image &optional show-prefix bol) - "A handler for inserting a jpeg IMAGE into a repl BUFFER. -Part of the default `cider-repl-content-type-handler-alist'." - (cider-repl--display-image buffer - (cider-repl--image image 'jpeg t) - show-prefix bol)) - -(defun cider-repl-handle-png (_type buffer image &optional show-prefix bol) - "A handler for inserting a png IMAGE into a repl BUFFER. -Part of the default `cider-repl-content-type-handler-alist'." - (cider-repl--display-image buffer - (cider-repl--image image 'png t) - show-prefix bol)) - -(defun cider-repl-handle-svg (_type buffer image &optional show-prefix bol) - "A handler for inserting an svg IMAGE into a repl BUFFER. -Part of the default `cider-repl-content-type-handler-alist'." - (cider-repl--display-image buffer - (cider-repl--image image 'svg t) - show-prefix bol)) - -(defun cider-repl-handle-external-body (type buffer _ &optional _show-prefix _bol) - "Handler for slurping external content into BUFFER. -Handles an external-body TYPE by issuing a slurp request to fetch the content." - (if-let* ((args (cadr type)) - (access-type (nrepl-dict-get args "access-type"))) - (nrepl-send-request - (list "op" "slurp" "url" (nrepl-dict-get args access-type)) - (cider-repl-handler buffer) - (cider-current-repl))) - nil) - -(defvar cider-repl-content-type-handler-alist - `(("message/external-body" . ,#'cider-repl-handle-external-body) - ("image/jpeg" . ,#'cider-repl-handle-jpeg) - ("image/png" . ,#'cider-repl-handle-png) - ("image/svg+xml" . ,#'cider-repl-handle-svg)) - "Association list from content-types to handlers. -Handlers must be functions of two required and two optional arguments - the -REPL buffer to insert into, the value of the given content type as a raw -string, the REPL's show prefix as any and an `end-of-line' flag. - -The return value of the handler should be a flag, indicating whether or not -the REPL is ready for a prompt to be displayed. Most handlers should return -t, as the content-type response is (currently) an alternative to the -value response. However for handlers which themselves issue subsequent -nREPL ops, it may be convenient to prevent inserting a prompt.") - -(defun cider-repl-handler (buffer) - "Make an nREPL evaluation handler for the REPL BUFFER." - (let ((show-prompt t)) - (nrepl-make-response-handler - buffer - (lambda (buffer value) - (cider-repl-emit-result buffer value t)) - (lambda (buffer out) - (cider-repl-emit-stdout buffer out)) - (lambda (buffer err) - (cider-repl-emit-stderr buffer err)) - (lambda (buffer) - (when show-prompt - (cider-repl-emit-prompt buffer)) - (when cider-repl-buffer-size-limit - (cider-repl-maybe-trim-buffer buffer))) - nrepl-err-handler - (lambda (buffer value content-type) - (if-let* ((content-attrs (cadr content-type)) - (content-type* (car content-type)) - (handler (cdr (assoc content-type* - cider-repl-content-type-handler-alist)))) - (setq show-prompt (funcall handler content-type buffer value nil t)) - (cider-repl-emit-result buffer value t t))) - (lambda (buffer warning) - (cider-repl-emit-stderr buffer warning))))) - -(defun cider--repl-request-map (right-margin) - "Map to be merged into REPL eval requests. -RIGHT-MARGIN is as in `cider--nrepl-print-request-map'." - (map-merge 'hash-table - (cider--nrepl-print-request-map right-margin) - (unless cider-repl-use-pretty-printing - '(("nrepl.middleware.print/print" "cider.nrepl.pprint/pr"))) - (when cider-repl-use-content-types - (cider--nrepl-content-type-map)))) - -(defun cider-repl--send-input (&optional newline) - "Go to the end of the input and send the current input. -If NEWLINE is true then add a newline at the end of the input." - (unless (cider-repl--in-input-area-p) - (error "No input at point")) - (let ((input (cider-repl--current-input))) - (if (string-blank-p input) - ;; don't evaluate a blank string, but erase it and emit - ;; a fresh prompt to acknowledge to the user. - (progn - (cider-repl--replace-input "") - (cider-repl-emit-prompt (current-buffer))) - ;; otherwise evaluate the input - (goto-char (point-max)) - (let ((end (point))) ; end of input, without the newline - (cider-repl--add-to-input-history input) - (when newline - (insert "\n")) - (let ((inhibit-modification-hooks t)) - (add-text-properties cider-repl-input-start-mark - (point) - `(cider-old-input - ,(cl-incf cider-repl-old-input-counter)))) - (unless cider-repl-use-clojure-font-lock - (let ((overlay (make-overlay cider-repl-input-start-mark end))) - ;; These properties are on an overlay so that they won't be taken - ;; by kill/yank. - (overlay-put overlay 'read-only t) - (overlay-put overlay 'font-lock-face 'cider-repl-input-face)))) - (let ((input-start (save-excursion (cider-repl-beginning-of-defun) (point)))) - (goto-char (point-max)) - (cider-repl--mark-input-start) - (cider-repl--mark-output-start) - (cider-nrepl-request:eval - input - (cider-repl-handler (current-buffer)) - (cider-current-ns) - (line-number-at-pos input-start) - (cider-column-number-at-pos input-start) - (thread-last - (cider--repl-request-map fill-column) - (map-pairs) - (seq-mapcat #'identity))))))) - -(defun cider-repl-return (&optional end-of-input) - "Evaluate the current input string, or insert a newline. -Send the current input only if a whole expression has been entered, -i.e. the parenthesis are matched. -When END-OF-INPUT is non-nil, send the input even if the parentheses -are not balanced." - (interactive "P") - (cond - (end-of-input - (cider-repl--send-input)) - ((and (get-text-property (point) 'cider-old-input) - (< (point) cider-repl-input-start-mark)) - (cider-repl--grab-old-input end-of-input)) - ((cider-repl--input-complete-p cider-repl-input-start-mark (point-max)) - (cider-repl--send-input t)) - (t - (cider-repl-newline-and-indent) - (message "[input not complete]")))) - -(defun cider-repl--grab-old-input (replace) - "Resend the old REPL input at point. -If REPLACE is non-nil the current input is replaced with the old -input; otherwise the new input is appended. The old input has the -text property `cider-old-input'." - (cl-multiple-value-bind (beg end) (cider-property-bounds 'cider-old-input) - (let ((old-input (buffer-substring beg end)) ;;preserve - ;;properties, they will be removed later - (offset (- (point) beg))) - ;; Append the old input or replace the current input - (cond (replace (goto-char cider-repl-input-start-mark)) - (t (goto-char (point-max)) - (unless (eq (char-before) ?\ ) - (insert " ")))) - (delete-region (point) (point-max)) - (save-excursion - (insert old-input) - (when (equal (char-before) ?\n) - (delete-char -1))) - (forward-char offset)))) - -(defun cider-repl-closing-return () - "Evaluate the current input string after closing input. -Closes all open parentheses or bracketed expressions." - (interactive) - (goto-char (point-max)) - (save-restriction - (narrow-to-region cider-repl-input-start-mark (point)) - (let ((matching-delimiter nil)) - (while (ignore-errors - (save-excursion - (backward-up-list 1) - (setq matching-delimiter (cdr (syntax-after (point))))) - t) - (insert-char matching-delimiter)))) - (cider-repl-return)) - -(defun cider-repl-toggle-pretty-printing () - "Toggle pretty-printing in the REPL." - (interactive) - (setq cider-repl-use-pretty-printing (not cider-repl-use-pretty-printing)) - (message "Pretty printing in REPL %s." - (if cider-repl-use-pretty-printing "enabled" "disabled"))) - -(defun cider-repl-toggle-content-types () - "Toggle content-type rendering in the REPL." - (interactive) - (setq cider-repl-use-content-types (not cider-repl-use-content-types)) - (message "Content-type support in REPL %s." - (if cider-repl-use-content-types "enabled" "disabled"))) - -(defun cider-repl-toggle-clojure-font-lock () - "Toggle pretty-printing in the REPL." - (interactive) - (setq cider-repl-use-clojure-font-lock (not cider-repl-use-clojure-font-lock)) - (message "Clojure font-locking in REPL %s." - (if cider-repl-use-clojure-font-lock "enabled" "disabled"))) - -(defun cider-repl-switch-to-other () - "Switch between the Clojure and ClojureScript REPLs for the current project." - (interactive) - ;; FIXME: implement cycling as session can hold more than two REPLs - (let* ((this-repl (cider-current-repl nil 'ensure)) - (other-repl (car (seq-remove (lambda (r) (eq r this-repl)) (cider-repls nil t))))) - (if other-repl - (switch-to-buffer other-repl) - (user-error "No other REPL in current session (%s)" - (car (sesman-current-session 'CIDER)))))) - -(defvar cider-repl-clear-buffer-hook) - -(defun cider-repl--clear-region (start end) - "Delete the output and its overlays between START and END." - (mapc #'delete-overlay (overlays-in start end)) - (delete-region start end)) - -(defun cider-repl-clear-buffer () - "Clear the currently visited REPL buffer completely. -See also the related commands `cider-repl-clear-output' and -`cider-find-and-clear-repl-output'." - (interactive) - (let ((inhibit-read-only t)) - (cider-repl--clear-region (point-min) cider-repl-prompt-start-mark) - (cider-repl--clear-region cider-repl-output-start cider-repl-output-end) - (when (< (point) cider-repl-input-start-mark) - (goto-char cider-repl-input-start-mark)) - (recenter t)) - (run-hooks 'cider-repl-clear-buffer-hook)) - -(defun cider-repl-clear-output (&optional clear-repl) - "Delete the output inserted since the last input. -With a prefix argument CLEAR-REPL it will clear the entire REPL buffer instead." - (interactive "P") - (if clear-repl - (cider-repl-clear-buffer) - (let ((inhibit-read-only t)) - (cider-repl--clear-region cider-repl-output-start cider-repl-output-end) - (save-excursion - (goto-char cider-repl-output-end) - (insert-before-markers - (propertize ";; output cleared\n" 'font-lock-face 'font-lock-comment-face)))))) - -(defun cider-repl-clear-banners () - "Delete the REPL banners." - (interactive) - ;; TODO: Improve the boundaries detecting logic - ;; probably it should be based on text properties - ;; the current implementation will clear warnings as well - (let ((start (point-min)) - (end (save-excursion - (goto-char (point-min)) - (cider-repl-next-prompt) - (forward-line -1) - (end-of-line) - (point)))) - (when (< start end) - (let ((inhibit-read-only t)) - (cider-repl--clear-region start (1+ end)))))) - -(defun cider-repl-clear-help-banner () - "Delete the help REPL banner." - (interactive) - ;; TODO: Improve the boundaries detecting logic - ;; probably it should be based on text properties - (let ((start (save-excursion - (goto-char (point-min)) - (search-forward ";; =") - (beginning-of-line) - (point))) - (end (save-excursion - (goto-char (point-min)) - (cider-repl-next-prompt) - (search-backward ";; =") - (end-of-line) - (point)))) - (when (< start end) - (let ((inhibit-read-only t)) - (cider-repl--clear-region start (1+ end)))))) - -(defun cider-repl-switch-ns-handler (buffer) - "Make an nREPL evaluation handler for the REPL BUFFER's ns switching." - (nrepl-make-response-handler buffer - (lambda (_buffer _value)) - (lambda (buffer out) - (cider-repl-emit-stdout buffer out)) - (lambda (buffer err) - (cider-repl-emit-stderr buffer err)) - (lambda (buffer) - (cider-repl-emit-prompt buffer)))) - -(defun cider-repl-set-ns (ns) - "Switch the namespace of the REPL buffer to NS. -If called from a cljc buffer act on both the Clojure and ClojureScript REPL -if there are more than one REPL present. If invoked in a REPL buffer the -command will prompt for the name of the namespace to switch to." - (interactive (list (if (or (derived-mode-p 'cider-repl-mode) - (null (cider-ns-form))) - (completing-read "Switch to namespace: " - (cider-sync-request:ns-list)) - (cider-current-ns)))) - (when (or (not ns) (equal ns "")) - (user-error "No namespace selected")) - (cider-map-repls :auto - (lambda (connection) - ;; NOTE: `require' and `in-ns' are special forms in ClojureScript. - ;; That's why we eval them separately instead of combining them with `do'. - (when cider-repl-require-ns-on-set - (cider-sync-tooling-eval (format "(require '%s)" ns) nil connection)) - (cider-tooling-eval (format "(in-ns '%s)" ns) - (cider-repl-switch-ns-handler connection))))) - - -;;; Location References - -(defcustom cider-locref-regexp-alist - '((stdout-stacktrace "[ \t]\\(at \\([^$(]+\\).*(\\([^:()]+\\):\\([0-9]+\\))\\)" 1 2 3 4) - (aviso-stacktrace "^[ \t]*\\(\\([^$/ \t]+\\).*? +\\([^:]+\\): +\\([0-9]+\\)\\)" 1 2 3 4) - (print-stacktrace "\\[\\([^][$ \t]+\\).* +\\([^ \t]+\\) +\\([0-9]+\\)\\]" 0 1 2 3) - (timbre-log "\\(TRACE\\|INFO\\|DEBUG\\|WARN\\|ERROR\\) +\\(\\[\\([^:]+\\):\\([0-9]+\\)\\]\\)" 2 3 nil 4) - (cljs-message "at line \\([0-9]+\\) +\\(.*\\)$" 0 nil 2 1) - (warning "warning,? +\\(\\([^\n:]+\\):\\([0-9]+\\):[0-9]+\\)" 1 nil 2 3) - (compilation ".*compiling:(\\([^\n:)]+\\):\\([0-9]+\\):[0-9]+)" 0 nil 1 2)) - "Alist holding regular expressions for inline location references. -Each element in the alist has the form (NAME REGEXP HIGHLIGHT VAR FILE -LINE), where NAME is the identifier of the regexp, REGEXP - regexp matching -a location, HIGHLIGHT - sub-expression matching region to highlight on -mouse-over, VAR - sub-expression giving Clojure VAR to look up. FILE is -currently only used when VAR is nil and must be full resource path in that -case." - :type '(alist :key-type sexp) - :package-version '(cider. "0.16.0")) - -(defun cider--locref-at-point-1 (reg-list) - "Workhorse for getting locref at point. -REG-LIST is an entry in `cider-locref-regexp-alist'." - (beginning-of-line) - (when (re-search-forward (nth 1 reg-list) (point-at-eol) t) - (let ((ix-highlight (or (nth 2 reg-list) 0)) - (ix-var (nth 3 reg-list)) - (ix-file (nth 4 reg-list)) - (ix-line (nth 5 reg-list))) - (list - :type (car reg-list) - :highlight (cons (match-beginning ix-highlight) (match-end ix-highlight)) - :var (and ix-var - (replace-regexp-in-string "_" "-" - (match-string-no-properties ix-var) - nil t)) - :file (and ix-file (match-string-no-properties ix-file)) - :line (and ix-line (string-to-number (match-string-no-properties ix-line))))))) - -(defun cider-locref-at-point (&optional pos) - "Return a plist of components of the location reference at POS. -Limit search to current line only and return nil if no location has been -found. Returned keys are :type, :highlight, :var, :file, :line, where -:highlight is a cons of positions, :var and :file are strings or nil, :line -is a number. See `cider-locref-regexp-alist' for how to specify regexes -for locref look up." - (save-excursion - (goto-char (or pos (point))) - ;; Regexp lookup on long lines can result in significant hangs #2532. We - ;; assume that lines longer than 300 don't contain source references. - (when (< (- (point-at-eol) (point-at-bol)) 300) - (seq-some (lambda (rl) (cider--locref-at-point-1 rl)) - cider-locref-regexp-alist)))) - -(defun cider-jump-to-locref-at-point (&optional pos) - "Identify location reference at POS and navigate to it. -This function is used from help-echo property inside REPL buffers and uses -regexes from `cider-locref-regexp-alist' to infer locations at point." - (interactive) - (if-let* ((loc (cider-locref-at-point pos))) - (let* ((var (plist-get loc :var)) - (line (plist-get loc :line)) - (file (or - ;; 1) retrieve from info middleware - (when var - (or (cider-sync-request:ns-path var) - (nrepl-dict-get (cider-sync-request:info var) "file"))) - (when-let* ((file (plist-get loc :file))) - ;; 2) file detected by the regexp - (or - (if (file-name-absolute-p file) - file - ;; when not absolute, expand within the current project - (when-let* ((proj (clojure-project-dir))) - (let ((path (expand-file-name file proj))) - (when (file-exists-p path) - path)))) - ;; 3) infer ns from the abbreviated path (common in - ;; reflection warnings) - (let ((ns (cider-path-to-ns file))) - (cider-sync-request:ns-path ns))))))) - (if file - (cider--jump-to-loc-from-info (nrepl-dict "file" file "line" line) t) - (error "No source location for %s" var))) - (user-error "No location reference at point"))) - -(defvar cider-locref-hoover-overlay - (let ((o (make-overlay 1 1))) - (overlay-put o 'category 'cider-error-hoover) - ;; (overlay-put o 'face 'highlight) - (overlay-put o 'pointer 'hand) - (overlay-put o 'mouse-face 'highlight) - (overlay-put o 'follow-link 'mouse) - (overlay-put o 'keymap - (let ((map (make-sparse-keymap))) - (define-key map [return] #'cider-jump-to-locref-at-point) - (define-key map [mouse-2] #'cider-jump-to-locref-at-point) - map)) - o) - "Overlay used during hoovering on location references in REPL buffers. -One for all REPLs.") - -(defun cider-locref-help-echo (_win buffer pos) - "Function for help-echo property in REPL buffers. -WIN, BUFFER and POS are the window, buffer and point under mouse position." - (with-current-buffer buffer - (if-let* ((hl (plist-get (cider-locref-at-point pos) :highlight))) - (move-overlay cider-locref-hoover-overlay (car hl) (cdr hl) buffer) - (delete-overlay cider-locref-hoover-overlay)) - nil)) - - -;;; History - -(defcustom cider-repl-wrap-history nil - "T to wrap history around when the end is reached." - :type 'boolean) - -;; These two vars contain the state of the last history search. We -;; only use them if `last-command' was `cider-repl--history-replace', -;; otherwise we reinitialize them. - -(defvar cider-repl-input-history-position -1 - "Newer items have smaller indices.") - -(defvar cider-repl-history-pattern nil - "The regexp most recently used for finding input history.") - -(defun cider-repl--add-to-input-history (string) - "Add STRING to the input history. -Empty strings and duplicates are ignored." - (unless (or (equal string "") - (equal string (car cider-repl-input-history))) - (push string cider-repl-input-history) - (cl-incf cider-repl-input-history-items-added))) - -(defun cider-repl-delete-current-input () - "Delete all text after the prompt." - (goto-char (point-max)) - (delete-region cider-repl-input-start-mark (point-max))) - -(defun cider-repl--replace-input (string) - "Replace the current REPL input with STRING." - (cider-repl-delete-current-input) - (insert-and-inherit string)) - -(defun cider-repl--position-in-history (start-pos direction regexp) - "Return the position of the history item starting at START-POS. -Search in DIRECTION for REGEXP. -Return -1 resp the length of the history if no item matches." - ;; Loop through the history list looking for a matching line - (let* ((step (cl-ecase direction - (forward -1) - (backward 1))) - (history cider-repl-input-history) - (len (length history))) - (cl-loop for pos = (+ start-pos step) then (+ pos step) - if (< pos 0) return -1 - if (<= len pos) return len - if (string-match-p regexp (nth pos history)) return pos))) - -(defun cider-repl--history-replace (direction &optional regexp) - "Replace the current input with the next line in DIRECTION. -DIRECTION is 'forward' or 'backward' (in the history list). -If REGEXP is non-nil, only lines matching REGEXP are considered." - (setq cider-repl-history-pattern regexp) - (let* ((min-pos -1) - (max-pos (length cider-repl-input-history)) - (pos0 (cond ((cider-history-search-in-progress-p) - cider-repl-input-history-position) - (t min-pos))) - (pos (cider-repl--position-in-history pos0 direction (or regexp ""))) - (msg nil)) - (cond ((and (< min-pos pos) (< pos max-pos)) - (cider-repl--replace-input (nth pos cider-repl-input-history)) - (setq msg (format "History item: %d" pos))) - ((not cider-repl-wrap-history) - (setq msg (cond ((= pos min-pos) "End of history") - ((= pos max-pos) "Beginning of history")))) - (cider-repl-wrap-history - (setq pos (if (= pos min-pos) max-pos min-pos)) - (setq msg "Wrapped history"))) - (when (or (<= pos min-pos) (<= max-pos pos)) - (when regexp - (setq msg (concat msg "; no matching item")))) - (message "%s%s" msg (cond ((not regexp) "") - (t (format "; current regexp: %s" regexp)))) - (setq cider-repl-input-history-position pos) - (setq this-command 'cider-repl--history-replace))) - -(defun cider-history-search-in-progress-p () - "Return t if a current history search is in progress." - (eq last-command 'cider-repl--history-replace)) - -(defun cider-terminate-history-search () - "Terminate the current history search." - (setq last-command this-command)) - -(defun cider-repl-previous-input () - "Cycle backwards through input history. -If the `last-command' was a history navigation command use the -same search pattern for this command. -Otherwise use the current input as search pattern." - (interactive) - (cider-repl--history-replace 'backward (cider-repl-history-pattern t))) - -(defun cider-repl-next-input () - "Cycle forwards through input history. -See `cider-previous-input'." - (interactive) - (cider-repl--history-replace 'forward (cider-repl-history-pattern t))) - -(defun cider-repl-forward-input () - "Cycle forwards through input history." - (interactive) - (cider-repl--history-replace 'forward (cider-repl-history-pattern))) - -(defun cider-repl-backward-input () - "Cycle backwards through input history." - (interactive) - (cider-repl--history-replace 'backward (cider-repl-history-pattern))) - -(defun cider-repl-previous-matching-input (regexp) - "Find the previous input matching REGEXP." - (interactive "sPrevious element matching (regexp): ") - (cider-terminate-history-search) - (cider-repl--history-replace 'backward regexp)) - -(defun cider-repl-next-matching-input (regexp) - "Find then next input matching REGEXP." - (interactive "sNext element matching (regexp): ") - (cider-terminate-history-search) - (cider-repl--history-replace 'forward regexp)) - -(defun cider-repl-history-pattern (&optional use-current-input) - "Return the regexp for the navigation commands. -If USE-CURRENT-INPUT is non-nil, use the current input." - (cond ((cider-history-search-in-progress-p) - cider-repl-history-pattern) - (use-current-input - (cl-assert (<= cider-repl-input-start-mark (point))) - (let ((str (cider-repl--current-input t))) - (cond ((string-match-p "^[ \n]*$" str) nil) - (t (concat "^" (regexp-quote str)))))) - (t nil))) - -;;; persistent history -(defcustom cider-repl-history-size 500 - "The maximum number of items to keep in the REPL history." - :type 'integer - :safe #'integerp) - -(defcustom cider-repl-history-file nil - "File to save the persistent REPL history to." - :type 'string - :safe #'stringp) - -(defun cider-repl--history-read-filename () - "Ask the user which file to use, defaulting `cider-repl-history-file'." - (read-file-name "Use CIDER REPL history file: " - cider-repl-history-file)) - -(defun cider-repl--history-read (filename) - "Read history from FILENAME and return it. -It does not yet set the input history." - (if (file-readable-p filename) - (with-temp-buffer - (insert-file-contents filename) - (when (> (buffer-size (current-buffer)) 0) - (read (current-buffer)))) - '())) - -(defun cider-repl-history-load (&optional filename) - "Load history from FILENAME into current session. -FILENAME defaults to the value of `cider-repl-history-file' but user -defined filenames can be used to read special history files. - -The value of `cider-repl-input-history' is set by this function." - (interactive (list (cider-repl--history-read-filename))) - (let ((f (or filename cider-repl-history-file))) - ;; TODO: probably need to set cider-repl-input-history-position as well. - ;; in a fresh connection the newest item in the list is currently - ;; not available. After sending one input, everything seems to work. - (setq cider-repl-input-history (cider-repl--history-read f)))) - -(defun cider-repl--history-write (filename) - "Write history to FILENAME. -Currently coding system for writing the contents is hardwired to -utf-8-unix." - (let* ((mhist (cider-repl--histories-merge cider-repl-input-history - cider-repl-input-history-items-added - (cider-repl--history-read filename))) - ;; newest items are at the beginning of the list, thus 0 - (hist (cl-subseq mhist 0 (min (length mhist) cider-repl-history-size)))) - (unless (file-writable-p filename) - (error (format "History file not writable: %s" filename))) - (let ((print-length nil) (print-level nil)) - (with-temp-file filename - ;; TODO: really set cs for output - ;; TODO: does cs need to be customizable? - (insert ";; -*- coding: utf-8-unix -*-\n") - (insert ";; Automatically written history of CIDER REPL session\n") - (insert ";; Edit at your own risk\n\n") - (prin1 (mapcar #'substring-no-properties hist) (current-buffer)))))) - -(defun cider-repl-history-save (&optional filename) - "Save the current REPL input history to FILENAME. -FILENAME defaults to the value of `cider-repl-history-file'." - (interactive (list (cider-repl--history-read-filename))) - (let* ((file (or filename cider-repl-history-file))) - (cider-repl--history-write file))) - -(defun cider-repl-history-just-save () - "Just save the history to `cider-repl-history-file'. -This function is meant to be used in hooks to avoid lambda -constructs." - (cider-repl-history-save cider-repl-history-file)) - -;; SLIME has different semantics and will not save any duplicates. -;; we keep track of how many items were added to the history in the -;; current session in `cider-repl--add-to-input-history' and merge only the -;; new items with the current history found in the file, which may -;; have been changed in the meantime by another session. -(defun cider-repl--histories-merge (session-hist n-added-items file-hist) - "Merge histories from SESSION-HIST adding N-ADDED-ITEMS into FILE-HIST." - (append (cl-subseq session-hist 0 n-added-items) - file-hist)) - - -;;; REPL shortcuts -(defcustom cider-repl-shortcut-dispatch-char ?\, - "Character used to distinguish REPL commands from Lisp forms." - :type '(character)) - -(defvar cider-repl-shortcuts (make-hash-table :test 'equal)) - -(defun cider-repl-add-shortcut (name handler) - "Add a REPL shortcut command, defined by NAME and HANDLER." - (puthash name handler cider-repl-shortcuts)) - -(declare-function cider-toggle-trace-ns "cider-tracing") -(declare-function cider-undef "cider-eval") -(declare-function cider-browse-ns "cider-browse-ns") -(declare-function cider-classpath "cider-classpath") -(declare-function cider-repl-history "cider-repl-history") -(declare-function cider-run "cider-mode") -(declare-function cider-ns-refresh "cider-ns") -(declare-function cider-ns-reload "cider-ns") -(declare-function cider-find-var "cider-find") -(declare-function cider-version "cider") -(declare-function cider-test-run-loaded-tests "cider-test") -(declare-function cider-test-run-project-tests "cider-test") -(declare-function cider-sideloader-start "cider-eval") -(cider-repl-add-shortcut "clear-output" #'cider-repl-clear-output) -(cider-repl-add-shortcut "clear" #'cider-repl-clear-buffer) -(cider-repl-add-shortcut "clear-banners" #'cider-repl-clear-banners) -(cider-repl-add-shortcut "clear-help-banner" #'cider-repl-clear-help-banner) -(cider-repl-add-shortcut "trim" #'cider-repl-trim-buffer) -(cider-repl-add-shortcut "ns" #'cider-repl-set-ns) -(cider-repl-add-shortcut "toggle-pprint" #'cider-repl-toggle-pretty-printing) -(cider-repl-add-shortcut "toggle-font-lock" #'cider-repl-toggle-clojure-font-lock) -(cider-repl-add-shortcut "toggle-content-types" #'cider-repl-toggle-content-types) -(cider-repl-add-shortcut "browse-ns" (lambda () (interactive) (cider-browse-ns (cider-current-ns)))) -(cider-repl-add-shortcut "classpath" #'cider-classpath) -(cider-repl-add-shortcut "history" #'cider-repl-history) -(cider-repl-add-shortcut "trace-ns" #'cider-toggle-trace-ns) -(cider-repl-add-shortcut "sideloader-start" #'cider-sideloader-start) -(cider-repl-add-shortcut "undef" #'cider-undef) -(cider-repl-add-shortcut "refresh" #'cider-ns-refresh) -(cider-repl-add-shortcut "reload" #'cider-ns-reload) -(cider-repl-add-shortcut "find-var" #'cider-find-var) -(cider-repl-add-shortcut "doc" #'cider-doc) -(cider-repl-add-shortcut "help" #'cider-repl-shortcuts-help) -(cider-repl-add-shortcut "test-ns" #'cider-test-run-ns-tests) -(cider-repl-add-shortcut "test-all" #'cider-test-run-loaded-tests) -(cider-repl-add-shortcut "test-project" #'cider-test-run-project-tests) -(cider-repl-add-shortcut "test-ns-with-filters" #'cider-test-run-ns-tests-with-filters) -(cider-repl-add-shortcut "test-all-with-filters" (lambda () (interactive) (cider-test-run-loaded-tests 'prompt-for-filters))) -(cider-repl-add-shortcut "test-project-with-filters" (lambda () (interactive) (cider-test-run-project-tests 'prompt-for-filters))) -(cider-repl-add-shortcut "test-report" #'cider-test-show-report) -(cider-repl-add-shortcut "run" #'cider-run) -(cider-repl-add-shortcut "conn-info" #'cider-describe-connection) -(cider-repl-add-shortcut "version" #'cider-version) -(cider-repl-add-shortcut "require-repl-utils" #'cider-repl-require-repl-utils) -;; So many ways to quit :-) -(cider-repl-add-shortcut "adios" #'cider-quit) -(cider-repl-add-shortcut "sayonara" #'cider-quit) -(cider-repl-add-shortcut "quit" #'cider-quit) -(cider-repl-add-shortcut "restart" #'cider-restart) - -(defconst cider-repl-shortcuts-help-buffer "*CIDER REPL Shortcuts Help*") - -(defun cider-repl-shortcuts-help () - "Display a help buffer." - (interactive) - (ignore-errors (kill-buffer cider-repl-shortcuts-help-buffer)) - (with-current-buffer (get-buffer-create cider-repl-shortcuts-help-buffer) - (insert "CIDER REPL shortcuts:\n\n") - (maphash (lambda (k v) (insert (format "%s:\n\t%s\n" k v))) cider-repl-shortcuts) - (goto-char (point-min)) - (help-mode) - (display-buffer (current-buffer) t)) - (cider-repl-handle-shortcut) - (current-buffer)) - -(defun cider-repl--available-shortcuts () - "Return the available REPL shortcuts." - (cider-util--hash-keys cider-repl-shortcuts)) - -(defun cider-repl-handle-shortcut () - "Execute a REPL shortcut." - (interactive) - (if (> (point) cider-repl-input-start-mark) - (insert (string cider-repl-shortcut-dispatch-char)) - (let ((command (completing-read "Command: " - (cider-repl--available-shortcuts)))) - (if (not (equal command "")) - (let ((command-func (gethash command cider-repl-shortcuts))) - (if command-func - (call-interactively command-func) - (error "Unknown command %S. Available commands: %s" - command-func - (mapconcat #'identity (cider-repl--available-shortcuts) ", ")))) - (error "No command selected"))))) - - -;;;;; CIDER REPL mode -(defvar cider-repl-mode-hook nil - "Hook executed when entering `cider-repl-mode'.") - -(defvar cider-repl-mode-syntax-table - (copy-syntax-table clojure-mode-syntax-table)) - -(declare-function cider-eval-last-sexp "cider-eval") -(declare-function cider-toggle-trace-ns "cider-tracing") -(declare-function cider-toggle-trace-var "cider-tracing") -(declare-function cider-find-resource "cider-find") -(declare-function cider-find-ns "cider-find") -(declare-function cider-find-keyword "cider-find") -(declare-function cider-find-var "cider-find") -(declare-function cider-switch-to-last-clojure-buffer "cider-mode") -(declare-function cider-macroexpand-1 "cider-macroexpansion") -(declare-function cider-macroexpand-all "cider-macroexpansion") -(declare-function cider-selector "cider-selector") -(declare-function cider-jack-in-clj "cider") -(declare-function cider-jack-in-cljs "cider") -(declare-function cider-connect-clj "cider") -(declare-function cider-connect-cljs "cider") - -(defvar cider-repl-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c C-d") 'cider-doc-map) - (define-key map (kbd "C-c ,") 'cider-test-commands-map) - (define-key map (kbd "C-c C-t") 'cider-test-commands-map) - (define-key map (kbd "M-.") #'cider-find-var) - (define-key map (kbd "C-c C-.") #'cider-find-ns) - (define-key map (kbd "C-c C-:") #'cider-find-keyword) - (define-key map (kbd "M-,") #'cider-pop-back) - (define-key map (kbd "C-c M-.") #'cider-find-resource) - (define-key map (kbd "RET") #'cider-repl-return) - (define-key map (kbd "TAB") #'cider-repl-tab) - (define-key map (kbd "C-") #'cider-repl-closing-return) - (define-key map (kbd "C-j") #'cider-repl-newline-and-indent) - (define-key map (kbd "C-c C-o") #'cider-repl-clear-output) - (define-key map (kbd "C-c M-n") #'cider-repl-set-ns) - (define-key map (kbd "C-c C-u") #'cider-repl-kill-input) - (define-key map (kbd "C-S-a") #'cider-repl-bol-mark) - (define-key map [S-home] #'cider-repl-bol-mark) - (define-key map (kbd "C-") #'cider-repl-backward-input) - (define-key map (kbd "C-") #'cider-repl-forward-input) - (define-key map (kbd "M-p") #'cider-repl-previous-input) - (define-key map (kbd "M-n") #'cider-repl-next-input) - (define-key map (kbd "M-r") #'cider-repl-previous-matching-input) - (define-key map (kbd "M-s") #'cider-repl-next-matching-input) - (define-key map (kbd "C-c C-n") #'cider-repl-next-prompt) - (define-key map (kbd "C-c C-p") #'cider-repl-previous-prompt) - (define-key map (kbd "C-c C-b") #'cider-interrupt) - (define-key map (kbd "C-c C-c") #'cider-interrupt) - (define-key map (kbd "C-c C-m") #'cider-macroexpand-1) - (define-key map (kbd "C-c M-m") #'cider-macroexpand-all) - (define-key map (kbd "C-c C-s") #'sesman-map) - (define-key map (kbd "C-c C-z") #'cider-switch-to-last-clojure-buffer) - (define-key map (kbd "C-c M-o") #'cider-repl-switch-to-other) - (define-key map (kbd "C-c M-s") #'cider-selector) - (define-key map (kbd "C-c M-d") #'cider-describe-connection) - (define-key map (kbd "C-c C-q") #'cider-quit) - (define-key map (kbd "C-c M-r") #'cider-restart) - (define-key map (kbd "C-c M-i") #'cider-inspect) - (define-key map (kbd "C-c M-p") #'cider-repl-history) - (define-key map (kbd "C-c M-t v") #'cider-toggle-trace-var) - (define-key map (kbd "C-c M-t n") #'cider-toggle-trace-ns) - (define-key map (kbd "C-c C-x") 'cider-start-map) - (define-key map (kbd "C-x C-e") #'cider-eval-last-sexp) - (define-key map (kbd "C-c C-r") 'clojure-refactor-map) - (define-key map (kbd "C-c C-v") 'cider-eval-commands-map) - (define-key map (kbd "C-c M-j") #'cider-jack-in-clj) - (define-key map (kbd "C-c M-J") #'cider-jack-in-cljs) - (define-key map (kbd "C-c M-c") #'cider-connect-clj) - (define-key map (kbd "C-c M-C") #'cider-connect-cljs) - - (define-key map (string cider-repl-shortcut-dispatch-char) #'cider-repl-handle-shortcut) - (easy-menu-define cider-repl-mode-menu map - "Menu for CIDER's REPL mode" - `("REPL" - ["Complete symbol" complete-symbol] - "--" - ,cider-doc-menu - "--" - ("Find" - ["Find definition" cider-find-var] - ["Find namespace" cider-find-ns] - ["Find resource" cider-find-resource] - ["Find keyword" cider-find-keyword] - ["Go back" cider-pop-back]) - "--" - ["Switch to Clojure buffer" cider-switch-to-last-clojure-buffer] - ["Switch to other REPL" cider-repl-switch-to-other] - "--" - ("Macroexpand" - ["Macroexpand-1" cider-macroexpand-1] - ["Macroexpand-all" cider-macroexpand-all]) - "--" - ,cider-test-menu - "--" - ["Run project (-main function)" cider-run] - ["Inspect" cider-inspect] - ["Toggle var tracing" cider-toggle-trace-var] - ["Toggle ns tracing" cider-toggle-trace-ns] - ["Refresh loaded code" cider-ns-refresh] - "--" - ["Set REPL ns" cider-repl-set-ns] - ["Toggle pretty printing" cider-repl-toggle-pretty-printing] - ["Toggle Clojure font-lock" cider-repl-toggle-clojure-font-lock] - ["Toggle rich content types" cider-repl-toggle-content-types] - ["Require REPL utils" cider-repl-require-repl-utils] - "--" - ["Browse classpath" cider-classpath] - ["Browse classpath entry" cider-open-classpath-entry] - ["Browse namespace" cider-browse-ns] - ["Browse all namespaces" cider-browse-ns-all] - ["Browse spec" cider-browse-spec] - ["Browse all specs" cider-browse-spec-all] - "--" - ["Next prompt" cider-repl-next-prompt] - ["Previous prompt" cider-repl-previous-prompt] - ["Clear output" cider-repl-clear-output] - ["Clear buffer" cider-repl-clear-buffer] - ["Trim buffer" cider-repl-trim-buffer] - ["Clear banners" cider-repl-clear-banners] - ["Clear help banner" cider-repl-clear-help-banner] - ["Kill input" cider-repl-kill-input] - "--" - ["Interrupt evaluation" cider-interrupt] - "--" - ["Connection info" cider-describe-connection] - "--" - ["Close ancillary buffers" cider-close-ancillary-buffers] - ["Quit" cider-quit] - ["Restart" cider-restart] - "--" - ["Clojure Cheatsheet" cider-cheatsheet] - "--" - ["A sip of CIDER" cider-drink-a-sip] - ["View user manual" cider-view-manual] - ["View quick reference card" cider-view-refcard] - ["Report a bug" cider-report-bug] - ["Version info" cider-version])) - map)) - -(sesman-install-menu cider-repl-mode-map) - -(defun cider-repl-wrap-fontify-function (func) - "Return a function that will call FUNC narrowed to input region." - (lambda (beg end &rest rest) - (when (and cider-repl-input-start-mark - (> end cider-repl-input-start-mark)) - (save-restriction - (narrow-to-region cider-repl-input-start-mark (point-max)) - (let ((font-lock-dont-widen t)) - (apply func (max beg cider-repl-input-start-mark) end rest)))))) - -(declare-function cider-complete-at-point "cider-completion") -(defvar cider--static-font-lock-keywords) - -(defun cider-repl-setup-paredit () - "Override the paredit-RET binding in cider-repl-mode." - (let ((oldmap (cdr (assoc 'paredit-mode minor-mode-map-alist))) - (newmap (make-sparse-keymap))) - (set-keymap-parent newmap oldmap) - (define-key newmap (kbd "RET") nil) - (make-local-variable 'minor-mode-overriding-map-alist) - (push `(paredit-mode . ,newmap) minor-mode-overriding-map-alist))) - -(define-derived-mode cider-repl-mode fundamental-mode "REPL" - "Major mode for Clojure REPL interactions. - -\\{cider-repl-mode-map}" - (clojure-mode-variables) - (clojure-font-lock-setup) - (font-lock-add-keywords nil cider--static-font-lock-keywords) - (setq-local sesman-system 'CIDER) - (setq-local font-lock-fontify-region-function - (cider-repl-wrap-fontify-function font-lock-fontify-region-function)) - (setq-local font-lock-unfontify-region-function - (cider-repl-wrap-fontify-function font-lock-unfontify-region-function)) - (set-syntax-table cider-repl-mode-syntax-table) - (cider-eldoc-setup) - ;; At the REPL, we define beginning-of-defun and end-of-defun to be - ;; the start of the previous prompt or next prompt respectively. - ;; Notice the interplay with `cider-repl-beginning-of-defun'. - (setq-local beginning-of-defun-function #'cider-repl-mode-beginning-of-defun) - (setq-local end-of-defun-function #'cider-repl-mode-end-of-defun) - (setq-local prettify-symbols-alist clojure--prettify-symbols-alist) - ;; apply dir-local variables to REPL buffers - (hack-dir-local-variables-non-file-buffer) - (when cider-repl-history-file - (cider-repl-history-load cider-repl-history-file) - (add-hook 'kill-buffer-hook #'cider-repl-history-just-save t t) - (add-hook 'kill-emacs-hook #'cider-repl-history-just-save)) - (add-hook 'completion-at-point-functions #'cider-complete-at-point nil t) - (add-hook 'paredit-mode-hook (lambda () (clojure-paredit-setup cider-repl-mode-map))) - (cider-repl-setup-paredit)) - -(provide 'cider-repl) - -;;; cider-repl.el ends here diff --git a/elpa/cider-20230707.640/cider-resolve.el b/elpa/cider-20230707.640/cider-resolve.el deleted file mode 100644 index 783ddbf0..00000000 --- a/elpa/cider-20230707.640/cider-resolve.el +++ /dev/null @@ -1,130 +0,0 @@ -;;; cider-resolve.el --- Resolve clojure symbols according to current nREPL connection -*- lexical-binding: t; -*- - -;; Copyright © 2015-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors - -;; Author: Artur Malabarba - -;; 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 . - -;;; Commentary: - -;; The ns cache is a dict of namespaces stored in the connection buffer. This -;; file offers functions to easily get information about variables from this -;; cache, given the variable's name and the file's namespace. This -;; functionality is similar to that offered by the `cider-var-info' function -;; (and others). The difference is that all functions in this file operate -;; without contacting the server (they still rely on an active connection -;; buffer, but no messages are actually exchanged). - -;; For this reason, the functions here are well suited for very -;; performance-sentitive operations, such as font-locking or -;; indentation. Meanwhile, operations like code-jumping are better off -;; communicating with the middleware, just in the off chance that the cache is -;; outdated. - -;; Below is a typical entry on this cache dict. Note that clojure.core symbols -;; are excluded from the refers to save space. - -;; "cider.nrepl.middleware.track-state" -;; (dict "aliases" -;; (dict "cljs" "cider.nrepl.middleware.util.cljs" -;; "misc" "cider.nrepl.middleware.util.misc" -;; "set" "clojure.set") -;; "interns" (dict a -;; "assoc-state" (dict "arglists" -;; (("response" -;; (dict "as" "msg" "keys" -;; ("session"))))) -;; "filter-core" (dict "arglists" -;; (("refers"))) -;; "make-transport" (dict "arglists" -;; (((dict "as" "msg" "keys" -;; ("transport"))))) -;; "ns-as-map" (dict "arglists" -;; (("ns"))) -;; "ns-cache" (dict) -;; "relevant-meta" (dict "arglists" -;; (("var"))) -;; "update-vals" (dict "arglists" -;; (("m" "f"))) -;; "wrap-tracker" (dict "arglists" -;; (("handler")))) -;; "refers" (dict "set-descriptor!" "#'nrepl.middleware/set-descriptor!")) - -;;; Code: - -(require 'cider-client) -(require 'nrepl-dict) -(require 'cider-util) - -(defvar cider-repl-ns-cache) - -(defun cider-resolve--get-in (&rest keys) - "Return (nrepl-dict-get-in cider-repl-ns-cache KEYS)." - (when-let* ((conn (cider-current-repl))) - (with-current-buffer conn - (nrepl-dict-get-in cider-repl-ns-cache keys)))) - -(defun cider-resolve-alias (ns alias) - "Return the namespace that ALIAS refers to in namespace NS. -If it doesn't point anywhere, returns ALIAS." - (or (cider-resolve--get-in ns "aliases" alias) - alias)) - -(defconst cider-resolve--prefix-regexp "\\`\\(?:#'\\)?\\([^/]+\\)/") - -(defun cider-resolve-var (ns var) - "Return a dict of the metadata of a clojure var VAR in namespace NS. -VAR is a string. -Return nil only if VAR cannot be resolved." - (let* ((var-ns (when (string-match cider-resolve--prefix-regexp var) - (cider-resolve-alias ns (match-string 1 var)))) - (name (replace-regexp-in-string cider-resolve--prefix-regexp "" var))) - (or - (cider-resolve--get-in (or var-ns ns) "interns" name) - (unless var-ns - ;; If the var had no prefix, it might be referred. - (if-let* ((referral (cider-resolve--get-in ns "refers" name))) - (cider-resolve-var ns referral) - ;; Or it might be from core. - (unless (equal ns "clojure.core") - (cider-resolve-var "clojure.core" name))))))) - -(defun cider-resolve-core-ns () - "Return a dict of the core namespace for current connection. -This will be clojure.core or cljs.core depending on the return value of the -function `cider-repl-type'." - (when-let* ((repl (cider-current-repl))) - (with-current-buffer repl - (cider-resolve--get-in (if (eq cider-repl-type 'cljs) - "cljs.core" - "clojure.core"))))) - -(defun cider-resolve-ns-symbols (ns) - "Return a plist of all valid symbols in NS. -Each entry's value is the metadata of the var that the symbol refers to. -NS can be the namespace name, or a dict of the namespace itself." - (when-let* ((dict (if (stringp ns) - (cider-resolve--get-in ns) - ns))) - (nrepl-dbind-response dict (interns _refers aliases) - (append (cdr interns) - (nrepl-dict-flat-map (lambda (alias namespace) - (nrepl-dict-flat-map (lambda (sym meta) - (list (concat alias "/" sym) meta)) - (cider-resolve--get-in namespace "interns"))) - aliases))))) - -(provide 'cider-resolve) -;;; cider-resolve.el ends here diff --git a/elpa/cider-20230707.640/cider-scratch.el b/elpa/cider-20230707.640/cider-scratch.el deleted file mode 100644 index 6366abb7..00000000 --- a/elpa/cider-20230707.640/cider-scratch.el +++ /dev/null @@ -1,99 +0,0 @@ -;;; cider-scratch.el --- *scratch* buffer for Clojure -*- lexical-binding: t -*- - -;; Copyright © 2014-2023 Bozhidar Batsov and CIDER contributors -;; -;; Author: Tim King -;; Phil Hagelberg -;; Bozhidar Batsov -;; Artur Malabarba -;; Hugo Duncan -;; Steve Purcell - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Imitate Emacs's *scratch* buffer. - -;;; Code: - -(require 'cider-eval) -(require 'clojure-mode) -(require 'easymenu) - -(defcustom cider-scratch-initial-message - ";; This buffer is for Clojure experiments and evaluation.\n -;; Press C-j to evaluate the last expression.\n -;; You can also press C-u C-j to evaluate the expression and pretty-print its result.\n\n" - "The initial message displayed in new scratch buffers." - :type 'string - :group 'cider - :package-version '(cider . "0.18.0")) - -(defvar cider-clojure-interaction-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map clojure-mode-map) - (define-key map (kbd "C-j") #'cider-eval-print-last-sexp) - (define-key map [remap paredit-newline] #'cider-eval-print-last-sexp) - (easy-menu-define cider-clojure-interaction-mode-menu map - "Menu for Clojure Interaction mode" - '("Clojure Interaction" - (["Eval and print last sexp" #'cider-eval-print-last-sexp] - "--" - ["Reset" #'cider-scratch-reset]))) - map)) - -(defconst cider-scratch-buffer-name "*cider-scratch*") - -;;;###autoload -(defun cider-scratch () - "Go to the scratch buffer named `cider-scratch-buffer-name'." - (interactive) - (pop-to-buffer (cider-scratch-find-or-create-buffer))) - -(defun cider-scratch-find-or-create-buffer () - "Find or create the scratch buffer." - (or (get-buffer cider-scratch-buffer-name) - (cider-scratch--create-buffer))) - -(define-derived-mode cider-clojure-interaction-mode clojure-mode "Clojure Interaction" - "Major mode for typing and evaluating Clojure forms. -Like `clojure-mode' except that \\[cider-eval-print-last-sexp] evals the Lisp expression -before point, and prints its value into the buffer, advancing point. - -\\{cider-clojure-interaction-mode-map}" - (setq-local sesman-system 'CIDER)) - -(defun cider-scratch--insert-welcome-message () - "Insert the welcome message for the scratch buffer." - (insert cider-scratch-initial-message)) - -(defun cider-scratch--create-buffer () - "Create a new scratch buffer." - (with-current-buffer (get-buffer-create cider-scratch-buffer-name) - (cider-clojure-interaction-mode) - (cider-scratch--insert-welcome-message) - (current-buffer))) - -(defun cider-scratch-reset () - "Reset the current scratch buffer." - (interactive) - (erase-buffer) - (cider-scratch--insert-welcome-message)) - -(provide 'cider-scratch) - -;;; cider-scratch.el ends here diff --git a/elpa/cider-20230707.640/cider-selector.el b/elpa/cider-20230707.640/cider-selector.el deleted file mode 100644 index afe0b567..00000000 --- a/elpa/cider-20230707.640/cider-selector.el +++ /dev/null @@ -1,174 +0,0 @@ -;;; cider-selector.el --- Buffer selection command inspired by SLIME's selector -*- lexical-binding: t -*- - -;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Tim King -;; Phil Hagelberg -;; Bozhidar Batsov -;; Artur Malabarba -;; Hugo Duncan -;; Steve Purcell - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Buffer selection command inspired by SLIME's selector. - -;;; Code: - -(require 'cider-client) -(require 'cider-eval) -(require 'cider-scratch) -(require 'cider-profile) - -(defconst cider-selector-help-buffer "*CIDER Selector Help*" - "The name of the selector's help buffer.") - -(defvar cider-selector-methods nil - "List of buffer-selection methods for the `cider-selector' command. -Each element is a list (KEY DESCRIPTION FUNCTION). -DESCRIPTION is a one-line description of what the key selects.") - -(defvar cider-selector-other-window nil - "If non-nil use `switch-to-buffer-other-window'. -Not meant to be set by users. It's used internally -by `cider-selector'.") - -(defun cider-selector--recently-visited-buffer (mode &optional consider-visible-p) - "Return the most recently visited buffer, deriving its `major-mode' from MODE. -CONSIDER-VISIBLE-P will allow handling of visible windows as well. -First pass only considers buffers that are not already visible. -Second pass will attempt one of visible ones for scenarios where the window -is visible, but not focused." - (cl-loop for buffer in (buffer-list) - when (and (with-current-buffer buffer - (derived-mode-p mode)) - ;; names starting with space are considered hidden by Emacs - (not (string-match-p "^ " (buffer-name buffer))) - (or consider-visible-p - (null (get-buffer-window buffer 'visible)))) - return buffer - finally (if consider-visible-p - (error "Can't find unshown buffer in %S" mode) - (cider-selector--recently-visited-buffer mode t)))) - -;;;###autoload -(defun cider-selector (&optional other-window) - "Select a new buffer by type, indicated by a single character. -The user is prompted for a single character indicating the method by -which to choose a new buffer. The `?' character describes the -available methods. OTHER-WINDOW provides an optional target. -See `def-cider-selector-method' for defining new methods." - (interactive) - (message "Select [%s]: " - (apply #'string (mapcar #'car cider-selector-methods))) - (let* ((cider-selector-other-window other-window) - (ch (save-window-excursion - (select-window (minibuffer-window)) - (read-char))) - (method (cl-find ch cider-selector-methods :key #'car))) - (cond (method - (funcall (cl-caddr method))) - (t - (message "No method for character: ?\\%c" ch) - (ding) - (sleep-for 1) - (discard-input) - (cider-selector))))) - -(defmacro def-cider-selector-method (key description &rest body) - "Define a new `cider-select' buffer selection method. -KEY is the key the user will enter to choose this method. - -DESCRIPTION is a one-line sentence describing how the method -selects a buffer. - -BODY is a series of forms which are evaluated when the selector -is chosen. The returned buffer is selected with -`switch-to-buffer'." - (let ((method `(lambda () - (let ((buffer (progn ,@body))) - (cond ((not (and buffer (get-buffer buffer))) - (message "No such buffer: %S" buffer) - (ding)) - ((get-buffer-window buffer) - (select-window (get-buffer-window buffer))) - (cider-selector-other-window - (switch-to-buffer-other-window buffer)) - (t - (switch-to-buffer buffer))))))) - `(setq cider-selector-methods - (cl-sort (cons (list ,key ,description ,method) - (cl-remove ,key cider-selector-methods :key #'car)) - #'< :key #'car)))) - -(def-cider-selector-method ?? "Selector help buffer." - (ignore-errors (kill-buffer cider-selector-help-buffer)) - (with-current-buffer (get-buffer-create cider-selector-help-buffer) - (insert "CIDER Selector Methods:\n\n") - (cl-loop for (key line nil) in cider-selector-methods - do (insert (format "%c:\t%s\n" key line))) - (goto-char (point-min)) - (help-mode) - (display-buffer (current-buffer) t)) - (cider-selector) - (current-buffer)) - -(cl-pushnew (list ?4 "Select in other window" (lambda () (cider-selector t))) - cider-selector-methods :key #'car) - -(def-cider-selector-method ?c - "Most recently visited clojure-mode buffer." - (cider-selector--recently-visited-buffer 'clojure-mode)) - -(def-cider-selector-method ?e - "Most recently visited emacs-lisp-mode buffer." - (cider-selector--recently-visited-buffer 'emacs-lisp-mode)) - -(def-cider-selector-method ?q "Abort." - (top-level)) - -(def-cider-selector-method ?r - "Current REPL buffer or as a fallback, the most recently -visited cider-repl-mode buffer." - (or (cider-current-repl) - (cider-selector--recently-visited-buffer 'cider-repl-mode))) - -(def-cider-selector-method ?m - "Current connection's *nrepl-messages* buffer." - (nrepl-messages-buffer (cider-current-repl))) - -(def-cider-selector-method ?x - "*cider-error* buffer." - cider-error-buffer) - -(def-cider-selector-method ?p - "*cider-profile* buffer." - cider-profile-buffer) - -(def-cider-selector-method ?d - "*cider-doc* buffer." - cider-doc-buffer) - -(def-cider-selector-method ?s - "*cider-scratch* buffer." - (cider-scratch-find-or-create-buffer)) - -(provide 'cider-selector) - -;;; cider-selector.el ends here diff --git a/elpa/cider-20230707.640/cider-stacktrace.el b/elpa/cider-20230707.640/cider-stacktrace.el deleted file mode 100644 index 75db9c15..00000000 --- a/elpa/cider-20230707.640/cider-stacktrace.el +++ /dev/null @@ -1,931 +0,0 @@ -;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*- - -;; Copyright © 2014-2023 Jeff Valk, Bozhidar Batsov and CIDER contributors - -;; Author: Jeff Valk - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Stacktrace filtering and stack frame source navigation - -;;; Code: - -(require 'button) -(require 'cl-lib) -(require 'easymenu) -(require 'map) -(require 'seq) -(require 'subr-x) - -(require 'cider-common) -(require 'cider-client) -(require 'cider-popup) -(require 'cider-util) - -;; Variables - -(defgroup cider-stacktrace nil - "Stacktrace filtering and navigation." - :prefix "cider-stacktrace-" - :group 'cider) - -(defcustom cider-stacktrace-fill-column t - "Fill column for error messages in stacktrace display. -If nil, messages will not be wrapped. If truthy but non-numeric, -`fill-column' will be used." - :type 'list - :package-version '(cider . "0.7.0")) - -(defcustom cider-stacktrace-default-filters '(tooling dup) - "Frame types to omit from initial stacktrace display." - :type 'list - :package-version '(cider . "0.6.0")) - -(make-obsolete 'cider-stacktrace-print-length 'cider-stacktrace-print-options "0.20") -(make-obsolete 'cider-stacktrace-print-level 'cider-stacktrace-print-options "0.20") -(make-obsolete-variable 'cider-stacktrace-print-options 'cider-print-options "0.21") - -(defvar cider-stacktrace-detail-max 2 - "The maximum detail level for causes.") - -(defvar-local cider-stacktrace-hidden-frame-count 0) -(defvar-local cider-stacktrace-filters nil) -(defvar-local cider-stacktrace-cause-visibility nil) -(defvar-local cider-stacktrace-positive-filters nil) - -(defconst cider-error-buffer "*cider-error*") - -(make-obsolete 'cider-visit-error-buffer 'cider-selector "0.18") - -(defcustom cider-stacktrace-suppressed-errors '() - "Errors that won't make the stacktrace buffer 'pop-over' your active window. -The error types are represented as strings." - :type 'list - :package-version '(cider . "0.12.0")) - -;; Faces - -(defface cider-stacktrace-error-class-face - '((t (:inherit font-lock-warning-face))) - "Face for exception class names." - :package-version '(cider . "0.6.0")) - -(defface cider-stacktrace-error-message-face - '((t (:inherit font-lock-doc-face))) - "Face for exception messages." - :package-version '(cider . "0.7.0")) - -(defface cider-stacktrace-filter-active-face - '((t (:inherit button :underline t :weight normal))) - "Face for filter buttons representing frames currently visible." - :package-version '(cider . "0.6.0")) - -(defface cider-stacktrace-filter-inactive-face - '((t (:inherit button :underline nil :weight normal))) - "Face for filter buttons representing frames currently filtered out." - :package-version '(cider . "0.6.0")) - -(defface cider-stacktrace-face - '((t (:inherit default))) - "Face for stack frame text." - :package-version '(cider . "0.6.0")) - -(defface cider-stacktrace-ns-face - '((t (:inherit font-lock-comment-face))) - "Face for stack frame namespace name." - :package-version '(cider . "0.6.0")) - -(defface cider-stacktrace-fn-face - '((t (:inherit default :weight bold))) - "Face for stack frame function name." - :package-version '(cider . "0.6.0")) - -(defface cider-stacktrace-promoted-button-face - '((((type graphic)) - :box (:line-width 3 :style released-button) - :inherit error) - (t :inverse-video t)) - "A button with this face represents a promoted (non-suppressed) error type." - :package-version '(cider . "0.12.0")) - -(defface cider-stacktrace-suppressed-button-face - '((((type graphic)) - :box (:line-width 3 :style pressed-button) - :inherit widget-inactive) - (t :inverse-video t)) - "A button with this face represents a suppressed error type." - :package-version '(cider . "0.12.0")) - -;; Colors & Theme Support - -(defvar cider-stacktrace-frames-background-color - (cider-scale-background-color) - "Background color for stacktrace frames.") - -(advice-add 'enable-theme :after #'cider--stacktrace-adapt-to-theme) -(advice-add 'disable-theme :after #'cider--stacktrace-adapt-to-theme) -(defun cider--stacktrace-adapt-to-theme (&rest _) - "When theme is changed, update `cider-stacktrace-frames-background-color'." - (setq cider-stacktrace-frames-background-color - (cider-scale-background-color))) - - -;; Mode & key bindings - -(defvar cider-stacktrace-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "M-p") #'cider-stacktrace-previous-cause) - (define-key map (kbd "M-n") #'cider-stacktrace-next-cause) - (define-key map (kbd "M-.") #'cider-stacktrace-jump) - (define-key map "q" #'cider-popup-buffer-quit-function) - (define-key map "j" #'cider-stacktrace-toggle-java) - (define-key map "c" #'cider-stacktrace-toggle-clj) - (define-key map "r" #'cider-stacktrace-toggle-repl) - (define-key map "t" #'cider-stacktrace-toggle-tooling) - (define-key map "d" #'cider-stacktrace-toggle-duplicates) - (define-key map "p" #'cider-stacktrace-show-only-project) - (define-key map "a" #'cider-stacktrace-toggle-all) - (define-key map "1" #'cider-stacktrace-cycle-cause-1) - (define-key map "2" #'cider-stacktrace-cycle-cause-2) - (define-key map "3" #'cider-stacktrace-cycle-cause-3) - (define-key map "4" #'cider-stacktrace-cycle-cause-4) - (define-key map "5" #'cider-stacktrace-cycle-cause-5) - (define-key map "0" #'cider-stacktrace-cycle-all-causes) - (define-key map (kbd "TAB") #'cider-stacktrace-cycle-current-cause) - (define-key map [backtab] #'cider-stacktrace-cycle-all-causes) - (easy-menu-define cider-stacktrace-mode-menu map - "Menu for CIDER's stacktrace mode" - '("Stacktrace" - ["Previous cause" cider-stacktrace-previous-cause] - ["Next cause" cider-stacktrace-next-cause] - "--" - ["Jump to frame source" cider-stacktrace-jump] - "--" - ["Cycle current cause detail" cider-stacktrace-cycle-current-cause] - ["Cycle cause #1 detail" cider-stacktrace-cycle-cause-1] - ["Cycle cause #2 detail" cider-stacktrace-cycle-cause-2] - ["Cycle cause #3 detail" cider-stacktrace-cycle-cause-3] - ["Cycle cause #4 detail" cider-stacktrace-cycle-cause-4] - ["Cycle cause #5 detail" cider-stacktrace-cycle-cause-5] - ["Cycle all cause detail" cider-stacktrace-cycle-all-causes] - "--" - ["Show/hide Java frames" cider-stacktrace-toggle-java] - ["Show/hide Clojure frames" cider-stacktrace-toggle-clj] - ["Show/hide REPL frames" cider-stacktrace-toggle-repl] - ["Show/hide tooling frames" cider-stacktrace-toggle-tooling] - ["Show/hide duplicate frames" cider-stacktrace-toggle-duplicates] - ["Toggle only project frames" cider-stacktrace-show-only-project] - ["Show/hide all frames" cider-stacktrace-toggle-all])) - map)) - -(define-derived-mode cider-stacktrace-mode special-mode "Stacktrace" - "Major mode for filtering and navigating CIDER stacktraces. - -\\{cider-stacktrace-mode-map}" - (when cider-special-mode-truncate-lines - (setq-local truncate-lines t)) - (setq-local sesman-system 'CIDER) - (setq-local electric-indent-chars nil) - (setq-local cider-stacktrace-hidden-frame-count 0) - (setq-local cider-stacktrace-filters cider-stacktrace-default-filters) - (setq-local cider-stacktrace-cause-visibility (make-vector 10 0)) - (buffer-disable-undo)) - - -;; Stacktrace filtering - -(defvar cider-stacktrace--all-negative-filters - '(clj tooling dup java repl) - "Filters that remove stackframes.") - -(defvar cider-stacktrace--all-positive-filters - '(project all) - "Filters that ensure stackframes are shown.") - -(defun cider-stacktrace--face-for-filter (filter neg-filters pos-filters) - "Return whether we should mark the FILTER is active or not. - -NEG-FILTERS and POS-FILTERS are lists of filters to check FILTER's type. - -NEG-FILTERS dictate which frames should be hidden while POS-FILTERS can -override this and ensure that those frames are shown." - (cond ((member filter cider-stacktrace--all-negative-filters) - (if (member filter neg-filters) - 'cider-stacktrace-filter-active-face - 'cider-stacktrace-filter-inactive-face)) - ((member filter cider-stacktrace--all-positive-filters) - (if (member filter pos-filters) - 'cider-stacktrace-filter-active-face - 'cider-stacktrace-filter-inactive-face)))) - -(defun cider-stacktrace-indicate-filters (filters pos-filters) - "Update enabled state of filter buttons. - -Find buttons with a 'filter property; if filter is a member of FILTERS, or -if filter is nil ('show all') and the argument list is non-nil, fontify the -button as disabled. Upon finding text with a 'hidden-count property, stop -searching and update the hidden count text. POS-FILTERS is the list of -positive filters to always include." - (with-current-buffer cider-error-buffer - (save-excursion - (goto-char (point-min)) - (let ((inhibit-read-only t)) - ;; Toggle buttons - (while (not (or (get-text-property (point) 'hidden-count) (eobp))) - (let ((button (button-at (point)))) - (when button - (let* ((filter (button-get button 'filter)) - (face (cider-stacktrace--face-for-filter filter - filters - pos-filters))) - (button-put button 'face face))) - (goto-char (or (next-property-change (point)) - (point-max))))) - ;; Update hidden count - (when (and (get-text-property (point) 'hidden-count) - (re-search-forward "[0-9]+" (line-end-position) t)) - (replace-match - (number-to-string cider-stacktrace-hidden-frame-count))))))) - -(defun cider-stacktrace-frame-p () - "Indicate if the text at point is a stack frame." - (get-text-property (point) 'cider-stacktrace-frame)) - -(defun cider-stacktrace-collapsed-p () - "Indicate if the stackframe was collapsed." - (get-text-property (point) 'collapsed)) - -(defun cider-stacktrace--should-hide-p (neg-filters pos-filters flags) - "Decide whether a stackframe should be hidden or not. -NEG-FILTERS dictate which frames should be hidden while POS-FILTERS can -override this and ensure that those frames are shown. -Argument FLAGS are the flags set on the stackframe, ie: clj dup, etc." - (let ((neg (seq-intersection neg-filters flags)) - (pos (seq-intersection pos-filters flags)) - (all (memq 'all pos-filters))) - (cond (all nil) ;; if all filter is on then we should not hide - ((and pos neg) nil) ;; if hidden and "resurrected" we should not hide - (pos nil) - (neg t) - (t nil)))) - -(defun cider-stacktrace--apply-filters (neg-filters pos-filters) - "Set visibility on stack frames. -Should be called by `cider-stacktrace-apply-filters' which has the logic of -how to interpret the combinations of the positive and negative filters. -For instance, the presence of the positive filter `project' requires all of -the other negative filters to be applied so that only project frames are -shown. NEG-FILTERS are the tags that should be hidden. POS-FILTERS are -the tags that must be shown." - (with-current-buffer cider-error-buffer - (save-excursion - (goto-char (point-min)) - (let ((inhibit-read-only t) - (hidden 0)) - (while (not (eobp)) - (when (and (cider-stacktrace-frame-p) - (not (cider-stacktrace-collapsed-p))) - (let* ((flags (get-text-property (point) 'flags)) - (hide (cider-stacktrace--should-hide-p neg-filters - pos-filters - flags))) - (when hide (cl-incf hidden)) - (put-text-property (point) (line-beginning-position 2) - 'invisible hide))) - (forward-line 1)) - (setq cider-stacktrace-hidden-frame-count hidden))) - (cider-stacktrace-indicate-filters neg-filters pos-filters))) - -(defun cider-stacktrace-apply-filters (filters) - "Takes a single list of filters and applies them. -Update `cider-stacktrace-hidden-frame-count' and indicate -filters applied. Currently collapsed stacktraces are ignored, and do not -contribute to the hidden count. FILTERS is the list of filters to be -applied, positive and negative all together. This function defines how -those choices interact and separates them into positive and negative -filters for the resulting machinery." - (let ((neg-filters (seq-intersection filters cider-stacktrace--all-negative-filters)) - (pos-filters (seq-intersection filters cider-stacktrace--all-positive-filters))) - ;; project and all are mutually exclusive. when both are present we check to - ;; see the most recent one (as cons onto the list would put it) and use that - ;; interaction. - (cond - ((memq 'all (memq 'project pos-filters)) ;; project is most recent - (cider-stacktrace--apply-filters cider-stacktrace--all-negative-filters '(project))) - ((memq 'project (memq 'all pos-filters)) ;; all is most recent - (cider-stacktrace--apply-filters nil '(all))) - ((memq 'all pos-filters) (cider-stacktrace--apply-filters nil '(all))) - ((memq 'project pos-filters) (cider-stacktrace--apply-filters cider-stacktrace--all-negative-filters - pos-filters)) - (t (cider-stacktrace--apply-filters neg-filters pos-filters))))) - -(defun cider-stacktrace-apply-cause-visibility () - "Apply `cider-stacktrace-cause-visibility' to causes and reapply filters." - (with-current-buffer cider-error-buffer - (save-excursion - (goto-char (point-min)) - (cl-flet ((next-detail (end) - (when-let* ((pos (next-single-property-change (point) 'detail))) - (when (< pos end) - (goto-char pos))))) - (let ((inhibit-read-only t)) - ;; For each cause... - (while (cider-stacktrace-next-cause) - (let* ((num (get-text-property (point) 'cause)) - (level (elt cider-stacktrace-cause-visibility num)) - (cause-end (cadr (cider-property-bounds 'cause)))) - ;; For each detail level within the cause, set visibility. - (while (next-detail cause-end) - (let* ((detail (get-text-property (point) 'detail)) - (detail-end (cadr (cider-property-bounds 'detail))) - (hide (if (> detail level) t nil))) - (add-text-properties (point) detail-end - (list 'invisible hide - 'collapsed hide)))))))) - (cider-stacktrace-apply-filters cider-stacktrace-filters)))) - -;;; Internal/Middleware error suppression - -(defun cider-stacktrace-some-suppressed-errors-p (error-types) - "Return intersection of ERROR-TYPES and CIDER-STACKTRACE-SUPPRESSED-ERRORS. -I.e, Return non-nil if the seq ERROR-TYPES shares any elements with -`cider-stacktrace-suppressed-errors'. This means that even a -'well-behaved' (ie, promoted) error type will be 'guilty by association' if -grouped with a suppressed error type." - (seq-intersection error-types cider-stacktrace-suppressed-errors)) - -(defun cider-stacktrace-suppress-error (error-type) - "Destructively add ERROR-TYPE to the `cider-stacktrace-suppressed-errors' set." - (setq cider-stacktrace-suppressed-errors - (cl-adjoin error-type cider-stacktrace-suppressed-errors :test 'equal))) - -(defun cider-stacktrace-promote-error (error-type) - "Destructively remove ERROR-TYPE from `cider-stacktrace-suppressed-errors'." - (setq cider-stacktrace-suppressed-errors - (remove error-type cider-stacktrace-suppressed-errors))) - -(defun cider-stacktrace-suppressed-error-p (error-type) - "Return non-nil if ERROR-TYPE is in `cider-stacktrace-suppressed-errors'." - (member error-type cider-stacktrace-suppressed-errors)) - -;; Interactive functions - -(defun cider-stacktrace-previous-cause () - "Move point to the previous exception cause, if one exists." - (interactive) - (with-current-buffer cider-error-buffer - (when-let* ((pos (previous-single-property-change (point) 'cause))) - (goto-char pos)))) - -(defun cider-stacktrace-next-cause () - "Move point to the next exception cause, if one exists." - (interactive) - (with-current-buffer cider-error-buffer - (when-let* ((pos (next-single-property-change (point) 'cause))) - (goto-char pos)))) - -(defun cider-stacktrace-cycle-cause (num &optional level) - "Update element NUM of `cider-stacktrace-cause-visibility'. -If LEVEL is specified, it is used, otherwise its current value is incremented. -When it reaches 3, it wraps to 0." - (let ((level (or level (1+ (elt cider-stacktrace-cause-visibility num))))) - (aset cider-stacktrace-cause-visibility num (mod level 3)) - (cider-stacktrace-apply-cause-visibility))) - -(defun cider-stacktrace-cycle-all-causes () - "Cycle the visibility of all exception causes." - (interactive) - (with-current-buffer cider-error-buffer - (save-excursion - ;; Find nearest cause. - (unless (get-text-property (point) 'cause) - (cider-stacktrace-next-cause) - (unless (get-text-property (point) 'cause) - (cider-stacktrace-previous-cause))) - ;; Cycle its level, and apply that to all causes. - (let* ((num (get-text-property (point) 'cause)) - (level (1+ (elt cider-stacktrace-cause-visibility num)))) - (setq-local cider-stacktrace-cause-visibility - (make-vector 10 (mod level 3))) - (cider-stacktrace-apply-cause-visibility))))) - -(defun cider-stacktrace-cycle-current-cause () - "Cycle the visibility of current exception at point, if any." - (interactive) - (with-current-buffer cider-error-buffer - (when-let* ((num (get-text-property (point) 'cause))) - (cider-stacktrace-cycle-cause num)))) - -(defun cider-stacktrace-cycle-cause-1 () - "Cycle the visibility of exception cause #1." - (interactive) - (cider-stacktrace-cycle-cause 1)) - -(defun cider-stacktrace-cycle-cause-2 () - "Cycle the visibility of exception cause #2." - (interactive) - (cider-stacktrace-cycle-cause 2)) - -(defun cider-stacktrace-cycle-cause-3 () - "Cycle the visibility of exception cause #3." - (interactive) - (cider-stacktrace-cycle-cause 3)) - -(defun cider-stacktrace-cycle-cause-4 () - "Cycle the visibility of exception cause #4." - (interactive) - (cider-stacktrace-cycle-cause 4)) - -(defun cider-stacktrace-cycle-cause-5 () - "Cycle the visibility of exception cause #5." - (interactive) - (cider-stacktrace-cycle-cause 5)) - -(defun cider-stacktrace-toggle (flag) - "Update `cider-stacktrace-filters' to add or remove FLAG, and apply filters." - (cider-stacktrace-apply-filters - (setq cider-stacktrace-filters - (if (memq flag cider-stacktrace-filters) - (remq flag cider-stacktrace-filters) - (cons flag cider-stacktrace-filters))))) - -(defun cider-stacktrace-toggle-all () - "Toggle `all' in filter list." - (interactive) - (cider-stacktrace-toggle 'all)) - -(defun cider-stacktrace-show-only-project () - "Display only the stackframes from the project." - (interactive) - (cider-stacktrace-toggle 'project)) - -(defun cider-stacktrace-toggle-java () - "Toggle display of Java stack frames." - (interactive) - (cider-stacktrace-toggle 'java)) - -(defun cider-stacktrace-toggle-clj () - "Toggle display of Clojure stack frames." - (interactive) - (cider-stacktrace-toggle 'clj)) - -(defun cider-stacktrace-toggle-repl () - "Toggle display of REPL stack frames." - (interactive) - (cider-stacktrace-toggle 'repl)) - -(defun cider-stacktrace-toggle-tooling () - "Toggle display of Tooling stack frames (compiler, nREPL middleware, etc)." - (interactive) - (cider-stacktrace-toggle 'tooling)) - -(defun cider-stacktrace-toggle-duplicates () - "Toggle display of stack frames that are duplicates of their descendents." - (interactive) - (cider-stacktrace-toggle 'dup)) - -;; Text button functions - -(defun cider-stacktrace-filter (button) - "Apply filter(s) indicated by the BUTTON." - (with-temp-message "Filters may also be toggled with the keyboard." - (let ((flag (button-get button 'filter))) - (cond ((member flag cider-stacktrace--all-negative-filters) - (cider-stacktrace-toggle flag)) - ((member flag cider-stacktrace--all-positive-filters) - (cider-stacktrace-show-only-project)) - (t (cider-stacktrace-toggle-all)))) - (sit-for 5))) - -(defun cider-stacktrace-toggle-suppression (button) - "Toggle stacktrace pop-over/pop-under behavior for the `error-type' in BUTTON. -Achieved by destructively manipulating `cider-stacktrace-suppressed-errors'." - (with-current-buffer cider-error-buffer - (let ((inhibit-read-only t) - (suppressed (button-get button 'suppressed)) - (error-type (button-get button 'error-type))) - (if suppressed - (progn - (cider-stacktrace-promote-error error-type) - (button-put button 'face 'cider-stacktrace-promoted-button-face) - (button-put button 'help-echo "Click to suppress these stacktraces.")) - (cider-stacktrace-suppress-error error-type) - (button-put button 'face 'cider-stacktrace-suppressed-button-face) - (button-put button 'help-echo "Click to promote these stacktraces.")) - (button-put button 'suppressed (not suppressed))))) - -(defun cider-stacktrace-navigate (button) - "Navigate to the stack frame source represented by the BUTTON." - (let* ((var (button-get button 'var)) - (class (button-get button 'class)) - (method (button-get button 'method)) - (info (or (and var (cider-var-info var)) - (and class method (cider-member-info class method)) - (nrepl-dict))) - ;; Stacktrace returns more accurate line numbers, but if the function's - ;; line was unreliable, then so is the stacktrace by the same amount. - ;; Set `line-shift' to the number of lines from the beginning of defn. - (line-shift (- (or (button-get button 'line) 0) - (or (nrepl-dict-get info "line") 1))) - (file (or - (nrepl-dict-get info "file") - (button-get button 'file))) - ;; give priority to `info` files as `info` returns full paths. - (info (nrepl-dict-put info "file" file))) - (cider--jump-to-loc-from-info info t) - (forward-line line-shift) - (back-to-indentation))) - -(declare-function cider-find-var "cider-find") - -(defun cider-stacktrace-jump (&optional arg) - "Find definition for stack frame at point, if available. -The prefix ARG and `cider-prompt-for-symbol' decide whether to -prompt and whether to use a new window. Similar to `cider-find-var'." - (interactive "P") - (let ((button (button-at (point)))) - (if (and button (button-get button 'line)) - (cider-stacktrace-navigate button) - (cider-find-var arg)))) - - -;; Rendering -(defvar cider-use-tooltips) -(defun cider-stacktrace-tooltip (tooltip) - "Return TOOLTIP if `cider-use-tooltips' is set to true, nil otherwise." - (when cider-use-tooltips tooltip)) - -(defun cider-stacktrace-emit-indented (text &optional indent fill fontify) - "Insert TEXT, and optionally FILL and FONTIFY as clojure the entire block. -INDENT is a string to insert before each line. When INDENT is nil, first -line is not indented and INDENT defaults to a white-spaced string with -length given by `current-column'." - (let ((text (if fontify - (cider-font-lock-as-clojure text) - text)) - (do-first indent) - (indent (or indent (make-string (current-column) ? ))) - (beg (point))) - (insert text) - (goto-char beg) - (when do-first - (insert indent)) - (forward-line) - (while (not (eobp)) - (insert indent) - (forward-line)) - (when (and fill cider-stacktrace-fill-column) - (when (and (numberp cider-stacktrace-fill-column)) - (setq-local fill-column cider-stacktrace-fill-column)) - (setq-local fill-prefix indent) - (fill-region beg (point))))) - -(defun cider-stacktrace-render-filters (buffer special-filters filters) - "Emit into BUFFER toggle buttons for each of the FILTERS. -SPECIAL-FILTERS are filters that show stack certain stack frames, hiding -others." - (with-current-buffer buffer - (insert " Show: ") - (dolist (filter special-filters) - (insert-text-button (car filter) - 'filter (cadr filter) - 'follow-link t - 'action #'cider-stacktrace-filter - 'help-echo (cider-stacktrace-tooltip - (format "Toggle %s stack frames" - (car filter)))) - (insert " ")) - (insert "\n") - (insert " Hide: ") - (dolist (filter filters) - (insert-text-button (car filter) - 'filter (cadr filter) - 'follow-link t - 'action #'cider-stacktrace-filter - 'help-echo (cider-stacktrace-tooltip - (format "Toggle %s stack frames" - (car filter)))) - (insert " ")) - - (let ((hidden "(0 frames hidden)")) - (put-text-property 0 (length hidden) 'hidden-count t hidden) - (insert " " hidden "\n")))) - -(defun cider-stacktrace-render-suppression-toggle (buffer error-types) - "Emit toggle buttons for each of the ERROR-TYPES leading this stacktrace BUFFER." - (with-current-buffer buffer - (when error-types - (insert " This is an unexpected CIDER middleware error.\n Please submit a bug report via `") - (insert-text-button "M-x cider-report-bug" - 'follow-link t - 'action (lambda (_button) (cider-report-bug)) - 'help-echo (cider-stacktrace-tooltip - "Report bug to the CIDER team.")) - (insert "`.\n\n") - (insert "\ - If these stacktraces are occurring frequently, consider using the - button(s) below to suppress these types of errors for the duration of - your current CIDER session. The stacktrace buffer will still be - generated, but it will \"pop under\" your current buffer instead of - \"popping over\". The button toggles this behavior.\n\n ") - (dolist (error-type error-types) - (let ((suppressed (cider-stacktrace-suppressed-error-p error-type))) - (insert-text-button (format "%s %s" (if suppressed "Promote" "Suppress") error-type) - 'follow-link t - 'error-type error-type - 'action #'cider-stacktrace-toggle-suppression - 'suppressed suppressed - 'face (if suppressed - 'cider-stacktrace-suppressed-button-face - 'cider-stacktrace-promoted-button-face) - 'help-echo (cider-stacktrace-tooltip - (format "Click to %s these stacktraces." - (if suppressed "promote" "suppress"))))) - (insert " "))))) - -(defun cider-stacktrace-render-frame (buffer frame) - "Emit into BUFFER function call site info for the stack FRAME. -This associates text properties to enable filtering and source navigation." - (with-current-buffer buffer - (if (null frame) ;; Probably caused by OmitStackTraceInFastThrow - (let ((url "https://docs.cider.mx/cider/troubleshooting.html#empty-java-stacktraces")) - (insert " No stacktrace available!\n Please see ") - (insert-text-button url - 'url url - 'follow-link t - 'action (lambda (x) (browse-url (button-get x 'url))))) - (nrepl-dbind-response frame (file line flags class method name var ns fn) - (when (or class file fn method ns name) - (let ((flags (mapcar #'intern flags))) ; strings -> symbols - (insert-text-button (format "%26s:%5d %s/%s" - (if (member 'repl flags) "REPL" file) (or line -1) - (if (member 'clj flags) ns class) - (if (member 'clj flags) fn method)) - 'var var 'class class 'method method - 'name name 'file file 'line line - 'flags flags 'follow-link t - 'action #'cider-stacktrace-navigate - 'help-echo (cider-stacktrace-tooltip - "View source at this location") - 'font-lock-face 'cider-stacktrace-face - 'type 'cider-plain-button) - (save-excursion - (let ((p4 (point)) - (p1 (search-backward " ")) - (p2 (search-forward "/")) - (p3 (search-forward-regexp "[^/$]+"))) - (put-text-property p1 p4 'font-lock-face 'cider-stacktrace-ns-face) - (put-text-property p2 p3 'font-lock-face 'cider-stacktrace-fn-face) - (put-text-property (line-beginning-position) (line-end-position) - 'cider-stacktrace-frame t))) - (insert "\n"))))))) - -(defun cider-stacktrace-render-compile-error (buffer cause) - "Emit into BUFFER the compile error CAUSE, and enable jumping to it." - (with-current-buffer buffer - (nrepl-dbind-response cause (file path line column) - (let ((indent " ") - (message-face 'cider-stacktrace-error-message-face)) - (insert indent) - (insert (propertize "Error compiling " 'font-lock-face message-face)) - (insert-text-button path 'compile-error t - 'file file 'line line 'column column 'follow-link t - 'action (lambda (_button) - (cider-jump-to (cider-find-file file) - (cons line column))) - 'help-echo (cider-stacktrace-tooltip - "Jump to the line that caused the error")) - (insert (propertize (format " at (%d:%d)" line column) - 'font-lock-face message-face)))))) - -(defun cider-stacktrace--toggle-visibility (id) - "Toggle visibility of the region with ID invisibility prop. -ID can also be a button, in which case button's property :id is used -instead. This function can be used directly in button actions." - (let ((id (if (or (numberp id) (symbolp id)) - ;; There is no proper way to identify buttons. Assuming that - ;; id's can be either numbers or symbols. - id - (button-get id :id)))) - (if (and (consp buffer-invisibility-spec) - (assoc id buffer-invisibility-spec)) - (remove-from-invisibility-spec (cons id t)) - (add-to-invisibility-spec (cons id t))))) - -(defun cider-stacktrace--insert-named-group (indent name &rest vals) - "Insert named group with the ability to toggle visibility. -NAME is a string naming the group. VALS are strings to be inserted after -the NAME. The whole group is prefixed by string INDENT." - (let* ((str (and vals (replace-regexp-in-string "\n+\\'" "" (apply #'concat vals)))) - (id (and str - (string-match "\n" str) - (cl-gensym name)))) - (insert indent) - (if id - (let* ((beg-link (string-match "[^ :]" name)) - (end-link (string-match "[ :]" name (1+ beg-link)))) - (insert (substring name 0 beg-link)) - (insert-text-button (substring name beg-link end-link) - :id id - 'face '((:weight bold) (:underline t)) - 'follow-link t - 'help-echo "Toggle visibility" - 'action #'cider-stacktrace--toggle-visibility) - (insert (substring name end-link))) - (insert (propertize name 'face '((:weight bold))))) - (let ((pos (point))) - (when str - (cider-stacktrace-emit-indented (concat str "\n") nil nil t) - (when id - (remove-from-invisibility-spec (cons id t)) - (let ((hide-beg (save-excursion (goto-char pos) (point-at-eol))) - (hide-end (1- (point-at-bol)))) - (overlay-put (make-overlay hide-beg hide-end) 'invisible id))))))) - -(defun cider-stacktrace--emit-spec-problems (spec-data indent) - "Emit SPEC-DATA indented with INDENT." - (nrepl-dbind-response spec-data (spec value problems) - (insert "\n") - (cider-stacktrace--insert-named-group indent " Spec: " spec) - (cider-stacktrace--insert-named-group indent " Value: " value) - (insert "\n") - (cider-stacktrace--insert-named-group indent "Problems: \n") - (let ((indent2 (concat indent " "))) - (dolist (prob problems) - (nrepl-dbind-response prob (in val predicate reason spec at extra) - (insert "\n") - (when (not (string= val value)) - (cider-stacktrace--insert-named-group indent2 " val: " val)) - (when in - (cider-stacktrace--insert-named-group indent2 " in: " in)) - (cider-stacktrace--insert-named-group indent2 "failed: " predicate) - (when spec - (cider-stacktrace--insert-named-group indent2 " spec: " spec)) - (when at - (cider-stacktrace--insert-named-group indent2 " at: " at)) - (when reason - (cider-stacktrace--insert-named-group indent2 "reason: " reason)) - (when extra - (cider-stacktrace--insert-named-group indent2 "extras: \n") - (cider-stacktrace-emit-indented extra (concat indent2 " ") nil t))))))) - -(defun cider-stacktrace-render-cause (buffer cause num note) - "Emit into BUFFER the CAUSE NUM, exception class, message, data, and NOTE." - (with-current-buffer buffer - (nrepl-dbind-response cause (class message data spec stacktrace) - (let ((indent " ") - (class-face 'cider-stacktrace-error-class-face) - (message-face 'cider-stacktrace-error-message-face)) - (cider-propertize-region `(cause ,num) - ;; Detail level 0: exception class - (cider-propertize-region '(detail 0) - (insert (format "%d. " num) - (propertize note 'font-lock-face 'font-lock-comment-face) " " - (propertize class 'font-lock-face class-face) - "\n")) - ;; Detail level 1: message + ex-data - (cider-propertize-region '(detail 1) - (if (equal class "clojure.lang.Compiler$CompilerException") - (cider-stacktrace-render-compile-error buffer cause) - (cider-stacktrace-emit-indented - (propertize (or message "(No message)") - 'font-lock-face message-face) - indent t)) - (insert "\n") - (when spec - (cider-stacktrace--emit-spec-problems spec (concat indent " "))) - (when data - (cider-stacktrace-emit-indented data indent nil t))) - ;; Detail level 2: stacktrace - (cider-propertize-region '(detail 2) - (insert "\n") - (let ((beg (point)) - (bg `(:background ,cider-stacktrace-frames-background-color :extend t))) - (dolist (frame stacktrace) - (cider-stacktrace-render-frame buffer frame)) - (overlay-put (make-overlay beg (point)) 'font-lock-face bg))) - ;; Add line break between causes, even when collapsed. - (cider-propertize-region '(detail 0) - (insert "\n"))))))) - -(defun cider-stacktrace-initialize (causes) - "Set and apply CAUSES initial visibility, filters, and cursor position." - (nrepl-dbind-response (car causes) (class) - (let ((compile-error-p (equal class "clojure.lang.Compiler$CompilerException"))) - ;; Partially display outermost cause if it's a compiler exception (the - ;; description reports reader location of the error). - (when compile-error-p - (cider-stacktrace-cycle-cause (length causes) 1)) - ;; Fully display innermost cause. This also applies visibility/filters. - (cider-stacktrace-cycle-cause 1 cider-stacktrace-detail-max) - ;; Move point (DWIM) to the compile error location if present, or to the - ;; first stacktrace frame in displayed cause otherwise. If the error - ;; buffer is visible in a window, ensure that window is selected while moving - ;; point, so as to move both the buffer's and the window's point. - (with-selected-window (or (get-buffer-window cider-error-buffer) - (selected-window)) - (with-current-buffer cider-error-buffer - (goto-char (point-min)) - (if compile-error-p - (goto-char (next-single-property-change (point) 'compile-error)) - (progn - (while (cider-stacktrace-next-cause)) - (when-let (position (next-single-property-change (point) 'flags)) - (goto-char position))))))))) - -(defun cider-stacktrace-render (buffer causes &optional error-types) - "Emit into BUFFER useful stacktrace information for the CAUSES. -Takes an optional ERROR-TYPES list which will render a 'suppression' toggle -that alters the pop-over/pop-under behavorior of the stacktrace buffers -created by these types of errors. The suppressed errors set can be customized -through the `cider-stacktrace-suppressed-errors' variable." - (with-current-buffer buffer - (let ((inhibit-read-only t)) - (erase-buffer) - (insert "\n") - ;; Stacktrace filters - (cider-stacktrace-render-filters - buffer - `(("Project-Only" project) ("All" all)) - `(("Clojure" clj) ("Java" java) ("REPL" repl) - ("Tooling" tooling) ("Duplicates" dup))) - (insert "\n") - ;; Option to suppress internal/middleware errors - (when error-types - (cider-stacktrace-render-suppression-toggle buffer error-types) - (insert "\n\n")) - ;; Stacktrace exceptions & frames - (let ((num (length causes))) - (dolist (cause causes) - (let ((note (if (= num (length causes)) "Unhandled" "Caused by"))) - (cider-stacktrace-render-cause buffer cause num note) - (setq num (1- num)))))) - (cider-stacktrace-initialize causes) - (font-lock-refresh-defaults))) - -(defun cider-stacktrace--analyze-stacktrace-op (stacktrace) - "Return the Cider NREPL op to analyze STACKTRACE." - (list "op" "analyze-stacktrace" "stacktrace" stacktrace)) - -(defun cider-stacktrace--stacktrace-request (stacktrace) - "Return the Cider NREPL request to analyze STACKTRACE." - (thread-last - (map-merge 'list - (list (cider-stacktrace--analyze-stacktrace-op stacktrace)) - (cider--nrepl-print-request-map fill-column)) - (seq-mapcat #'identity))) - -(defun cider-stacktrace--analyze-render (causes) - "Render the CAUSES of the stacktrace analysis result." - (let ((buffer (get-buffer-create cider-error-buffer))) - (with-current-buffer buffer - (cider-stacktrace-mode) - (cider-stacktrace-render buffer (reverse causes)) - (display-buffer buffer cider-jump-to-pop-to-buffer-actions)))) - -(defun cider-stacktrace-analyze-string (stacktrace) - "Analyze the STACKTRACE string and show the result." - (when (stringp stacktrace) - (set-text-properties 0 (length stacktrace) nil stacktrace)) - (let (causes) - (cider-nrepl-send-request - (cider-stacktrace--stacktrace-request stacktrace) - (lambda (response) - (setq causes (nrepl-dbind-response response (class status) - (cond (class (cons response causes)) - ((and (member "done" status) causes) - (cider-stacktrace--analyze-render causes))))))))) - -(defun cider-stacktrace-analyze-at-point () - "Analyze the stacktrace at point." - (interactive) - (cond ((thing-at-point 'sentence) - (cider-stacktrace-analyze-string (thing-at-point 'sentence))) - ((thing-at-point 'paragraph) - (cider-stacktrace-analyze-string (thing-at-point 'paragraph))) - (t (cider-stacktrace-analyze-in-region (region-beginning) (region-end))))) - -(defun cider-stacktrace-analyze-in-region (beg end) - "Analyze the stacktrace in the region between BEG and END." - (interactive (list (region-beginning) (region-end))) - (let ((stacktrace (buffer-substring beg end))) - (cider-stacktrace-analyze-string stacktrace))) - -(provide 'cider-stacktrace) - -;;; cider-stacktrace.el ends here diff --git a/elpa/cider-20230707.640/cider-test.el b/elpa/cider-20230707.640/cider-test.el deleted file mode 100644 index 50ff75f2..00000000 --- a/elpa/cider-20230707.640/cider-test.el +++ /dev/null @@ -1,839 +0,0 @@ -;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*- - -;; Copyright © 2014-2023 Jeff Valk, Bozhidar Batsov and CIDER contributors - -;; Author: Jeff Valk - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; This provides execution, reporting, and navigation support for Clojure tests, -;; specifically using the `clojure.test' machinery. This functionality replaces -;; the venerable `clojure-test-mode' (deprecated in June 2014), and relies on -;; nREPL middleware for report running and session support. - -;;; Code: - -(require 'ansi-color) -(require 'button) -(require 'cl-lib) -(require 'easymenu) -(require 'map) -(require 'seq) -(require 'subr-x) - -(require 'cider-common) -(require 'cider-client) -(require 'cider-popup) -(require 'cider-stacktrace) -(require 'cider-overlays) - -;;; Variables - -(defgroup cider-test nil - "Presentation and navigation for test results." - :prefix "cider-test-" - :group 'cider) - -(defcustom cider-test-show-report-on-success nil - "Whether to show the `*cider-test-report*` buffer on passing tests." - :type 'boolean - :package-version '(cider . "0.8.0")) - -(defcustom cider-auto-select-test-report-buffer t - "Determines if the test-report buffer should be auto-selected." - :type 'boolean - :package-version '(cider . "0.9.0")) - -(defcustom cider-test-defining-forms '("deftest" "defspec") - "Forms that define individual tests. -CIDER considers the \"top-level\" form around point to define a test if -the form starts with one of these forms. -Add to this list to have CIDER recognize additional test defining macros." - :type '(repeat string) - :package-version '(cider . "0.15.0")) - -(defvar cider-test-last-summary nil - "The summary of the last run test.") - -(defvar cider-test-last-results nil - "The results of the last run test.") - -(defconst cider-test-report-buffer "*cider-test-report*" - "Buffer name in which to display test reports.") - -;;; Faces - -(defface cider-test-failure-face - '((((class color) (background light)) - :background "orange red") - (((class color) (background dark)) - :background "firebrick")) - "Face for failed tests." - :package-version '(cider . "0.7.0")) - -(defface cider-test-error-face - '((((class color) (background light)) - :background "orange1") - (((class color) (background dark)) - :background "orange4")) - "Face for erring tests." - :package-version '(cider . "0.7.0")) - -(defface cider-test-success-face - '((((class color) (background light)) - :foreground "black" - :background "green") - (((class color) (background dark)) - :foreground "black" - :background "green")) - "Face for passing tests." - :package-version '(cider . "0.7.0")) - - -;; Colors & Theme Support - -(defvar cider-test-items-background-color - (cider-scale-background-color) - "Background color for test assertion items.") - -(advice-add 'enable-theme :after #'cider--test-adapt-to-theme) -(advice-add 'disable-theme :after #'cider--test-adapt-to-theme) -(defun cider--test-adapt-to-theme (&rest _) - "When theme is changed, update `cider-test-items-background-color'." - (setq cider-test-items-background-color (cider-scale-background-color))) - - -;;; Report mode & key bindings -;; -;; The primary mode of interacting with test results is the report buffer, which -;; allows navigation among tests, jumping to test definitions, expected/actual -;; diff-ing, and cause/stacktrace inspection for test errors. - -(defvar cider-test-commands-map - (let ((map (define-prefix-command 'cider-test-commands-map))) - ;; Duplicates of keys below with C- for convenience - (define-key map (kbd "C-r") #'cider-test-rerun-failed-tests) - (define-key map (kbd "C-t") #'cider-test-run-test) - (define-key map (kbd "C-a") #'cider-test-rerun-test) - (define-key map (kbd "C-n") #'cider-test-run-ns-tests) - (define-key map (kbd "C-s") #'cider-test-run-ns-tests-with-filters) - (define-key map (kbd "C-l") #'cider-test-run-loaded-tests) - (define-key map (kbd "C-p") #'cider-test-run-project-tests) - (define-key map (kbd "C-b") #'cider-test-show-report) - ;; Single-key bindings defined last for display in menu - (define-key map (kbd "r") #'cider-test-rerun-failed-tests) - (define-key map (kbd "t") #'cider-test-run-test) - (define-key map (kbd "a") #'cider-test-rerun-test) - (define-key map (kbd "n") #'cider-test-run-ns-tests) - (define-key map (kbd "s") #'cider-test-run-ns-tests-with-filters) - (define-key map (kbd "l") #'cider-test-run-loaded-tests) - (define-key map (kbd "p") #'cider-test-run-project-tests) - (define-key map (kbd "b") #'cider-test-show-report) - map)) - -(defconst cider-test-menu - '("Test" - ["Run test" cider-test-run-test] - ["Run namespace tests" cider-test-run-ns-tests] - ["Run namespace tests with filters" cider-test-run-ns-tests-with-filters] - ["Run all loaded tests" cider-test-run-loaded-tests] - ["Run all loaded tests with filters" (apply-partially cider-test-run-loaded-tests 'prompt-for-filters)] - ["Run all project tests" cider-test-run-project-tests] - ["Run all project tests with filters" (apply-partially cider-test-run-project-tests 'prompt-for-filters)] - ["Run tests after load-file" cider-auto-test-mode - :style toggle :selected cider-auto-test-mode] - "--" - ["Interrupt running tests" cider-interrupt] - ["Rerun failed/erring tests" cider-test-rerun-failed-tests] - ["Show test report" cider-test-show-report] - "--" - ["Configure testing" (customize-group 'cider-test)]) - "CIDER test submenu.") - -(defvar cider-test-report-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c ,") 'cider-test-commands-map) - (define-key map (kbd "C-c C-t") 'cider-test-commands-map) - (define-key map (kbd "M-p") #'cider-test-previous-result) - (define-key map (kbd "M-n") #'cider-test-next-result) - (define-key map (kbd "M-.") #'cider-test-jump) - (define-key map (kbd "") #'cider-test-previous-result) - (define-key map (kbd "TAB") #'cider-test-next-result) - (define-key map (kbd "RET") #'cider-test-jump) - (define-key map (kbd "t") #'cider-test-jump) - (define-key map (kbd "d") #'cider-test-ediff) - (define-key map (kbd "e") #'cider-test-stacktrace) - ;; `f' for "run failed". - (define-key map "f" #'cider-test-rerun-failed-tests) - (define-key map "n" #'cider-test-run-ns-tests) - (define-key map "s" #'cider-test-run-ns-tests-with-filters) - (define-key map "l" #'cider-test-run-loaded-tests) - (define-key map "p" #'cider-test-run-project-tests) - ;; `g' generally reloads the buffer. The closest thing we have to that is - ;; "run the test at point". But it's not as nice as rerunning all tests in - ;; this buffer. - (define-key map "g" #'cider-test-run-test) - (define-key map "q" #'cider-popup-buffer-quit-function) - (easy-menu-define cider-test-report-mode-menu map - "Menu for CIDER's test result mode" - '("Test-Report" - ["Previous result" cider-test-previous-result] - ["Next result" cider-test-next-result] - "--" - ["Rerun current test" cider-test-run-test] - ["Rerun failed/erring tests" cider-test-rerun-failed-tests] - ["Run all ns tests" cider-test-run-ns-tests] - ["Run all ns tests with filters" cider-test-run-ns-tests-with-filters] - ["Run all loaded tests" cider-test-run-loaded-tests] - ["Run all loaded tests with filters" (apply-partially cider-test-run-loaded-tests 'prompt-for-filters)] - ["Run all project tests" cider-test-run-project-tests] - ["Run all project tests with filters" (apply-partially cider-test-run-project-tests 'prompt-for-filters)] - "--" - ["Jump to test definition" cider-test-jump] - ["Display test error" cider-test-stacktrace] - ["Display expected/actual diff" cider-test-ediff])) - map)) - -(define-derived-mode cider-test-report-mode fundamental-mode "Test Report" - "Major mode for presenting Clojure test results. - -\\{cider-test-report-mode-map}" - (setq buffer-read-only t) - (when cider-special-mode-truncate-lines - (setq-local truncate-lines t)) - (setq-local sesman-system 'CIDER) - (setq-local electric-indent-chars nil) - (buffer-disable-undo)) - -;; Report navigation - -(defun cider-test-show-report () - "Show the test report buffer, if one exists." - (interactive) - (if-let* ((report-buffer (get-buffer cider-test-report-buffer))) - (switch-to-buffer report-buffer) - (message "No test report buffer"))) - -(defun cider-test-previous-result () - "Move point to the previous test result, if one exists." - (interactive) - (with-current-buffer (get-buffer cider-test-report-buffer) - (when-let* ((pos (previous-single-property-change (point) 'type))) - (if (get-text-property pos 'type) - (goto-char pos) - (when-let* ((pos (previous-single-property-change pos 'type))) - (goto-char pos)))))) - -(defun cider-test-next-result () - "Move point to the next test result, if one exists." - (interactive) - (with-current-buffer (get-buffer cider-test-report-buffer) - (when-let* ((pos (next-single-property-change (point) 'type))) - (if (get-text-property pos 'type) - (goto-char pos) - (when-let* ((pos (next-single-property-change pos 'type))) - (goto-char pos)))))) - -(declare-function cider-find-var "cider-find") - -(defun cider-test-jump (&optional arg) - "Find definition for test at point, if available. -The prefix ARG and `cider-prompt-for-symbol' decide whether to -prompt and whether to use a new window. Similar to `cider-find-var'." - (interactive "P") - (let ((ns (get-text-property (point) 'ns)) - (var (get-text-property (point) 'var)) - (line (get-text-property (point) 'line))) - (if (and ns var) - (cider-find-var arg (concat ns "/" var) line) - (cider-find-var arg)))) - -;;; Error stacktraces - -(defvar cider-auto-select-error-buffer) - -(defun cider-test-stacktrace-for (ns var index) - "Display stacktrace for the erring NS VAR test with the assertion INDEX." - (let (causes) - (cider-nrepl-send-request - (thread-last - (map-merge 'list - `(("op" "test-stacktrace") - ("ns" ,ns) - ("var" ,var) - ("index" ,index)) - (cider--nrepl-print-request-map fill-column)) - (seq-mapcat #'identity)) - (lambda (response) - (nrepl-dbind-response response (class status) - (cond (class (setq causes (cons response causes))) - (status (when causes - (cider-stacktrace-render - (cider-popup-buffer cider-error-buffer - cider-auto-select-error-buffer - #'cider-stacktrace-mode - 'ancillary) - (reverse causes)))))))))) - -(defun cider-test-stacktrace () - "Display stacktrace for the erring test at point." - (interactive) - (let ((ns (get-text-property (point) 'ns)) - (var (get-text-property (point) 'var)) - (index (get-text-property (point) 'index)) - (err (get-text-property (point) 'error))) - (if (and err ns var index) - (cider-test-stacktrace-for ns var index) - (message "No test error at point")))) - - -;;; Expected vs actual diffing - -(defvar cider-test-ediff-buffers nil - "The expected/actual buffers used to display diff.") - -(defun cider-test--extract-from-actual (actual n) - "Extract form N from ACTUAL, ignoring outermost not. - -ACTUAL is a string like \"(not (= 3 4))\", of the sort returned by -clojure.test. - -N = 1 => 3, N = 2 => 4, etc." - (with-temp-buffer - (insert actual) - (clojure-mode) - (goto-char (point-min)) - (re-search-forward "(" nil t 2) - (clojure-forward-logical-sexp n) - (forward-whitespace 1) - (let ((beg (point))) - (clojure-forward-logical-sexp) - (buffer-substring beg (point))))) - -(defun cider-test-ediff () - "Show diff of the expected vs actual value for the test at point. -With the actual value, the outermost '(not ...)' s-expression is removed." - (interactive) - (let* ((expected-buffer (generate-new-buffer " *expected*")) - (actual-buffer (generate-new-buffer " *actual*")) - (diffs (get-text-property (point) 'diffs)) - (actual* (get-text-property (point) 'actual)) - (expected (cond (diffs (get-text-property (point) 'expected)) - (actual* (cider-test--extract-from-actual actual* 1)))) - (actual (cond (diffs (caar diffs)) - (actual* (cider-test--extract-from-actual actual* 2))))) - (if (not (and expected actual)) - (message "No test failure at point") - (with-current-buffer expected-buffer - (insert expected) - (clojure-mode)) - (with-current-buffer actual-buffer - (insert actual) - (clojure-mode)) - (apply #'ediff-buffers - (setq cider-test-ediff-buffers - (list (buffer-name expected-buffer) - (buffer-name actual-buffer))))))) - -(defun cider-test-ediff-cleanup () - "Cleanup expected/actual buffers used for diff." - (interactive) - (mapc (lambda (b) (when (get-buffer b) (kill-buffer b))) - cider-test-ediff-buffers)) - -(add-hook 'ediff-cleanup-hook #'cider-test-ediff-cleanup) - - -;;; Report rendering - -(defun cider-test-type-face (type) - "Return the font lock face for the test result TYPE." - (pcase type - ("pass" 'cider-test-success-face) - ("fail" 'cider-test-failure-face) - ("error" 'cider-test-error-face) - (_ 'default))) - -(defun cider-test-type-simple-face (type) - "Return a face for the test result TYPE using the highlight color as foreground." - (let ((face (cider-test-type-face type))) - `(:foreground ,(face-attribute face :background)))) - -(defun cider-test-render-summary (buffer summary) - "Emit into BUFFER the report SUMMARY statistics." - (with-current-buffer buffer - (nrepl-dbind-response summary (ns var test pass fail error) - (insert (format "Tested %d namespaces\n" ns)) - (insert (format "Ran %d assertions, in %d test functions\n" test var)) - (unless (zerop fail) - (cider-insert (format "%d failures" fail) 'cider-test-failure-face t)) - (unless (zerop error) - (cider-insert (format "%d errors" error) 'cider-test-error-face t)) - (when (zerop (+ fail error)) - (cider-insert (format "%d passed" pass) 'cider-test-success-face t)) - (insert "\n\n")))) - -(defun cider-test-render-assertion (buffer test) - "Emit into BUFFER report detail for the TEST assertion." - (with-current-buffer buffer - (nrepl-dbind-response test (var context type message expected actual diffs error gen-input) - (cl-flet ((insert-label (s) - (cider-insert (format "%8s: " s) 'font-lock-comment-face)) - (insert-align-label (s) - (insert (format "%12s" s))) - (insert-rect (s) - (let ((start (point))) - (insert-rectangle (thread-first - s - cider-font-lock-as-clojure - (split-string "\n"))) - (ansi-color-apply-on-region start (point))) - (beginning-of-line))) - (cider-propertize-region (cider-intern-keys (cdr test)) - (let ((beg (point)) - (type-face (cider-test-type-simple-face type)) - (bg `(:background ,cider-test-items-background-color :extend t))) - (cider-insert (capitalize type) type-face nil " in ") - (cider-insert var 'font-lock-function-name-face t) - (when context (cider-insert context 'font-lock-doc-face t)) - (when message (cider-insert message 'font-lock-string-face t)) - (when expected - (insert-label "expected") - (insert-rect expected) - (insert "\n")) - (if diffs - (dolist (d diffs) - (cl-destructuring-bind (actual (removed added)) d - (insert-label "actual") - (insert-rect actual) - (insert-label "diff") - (insert "- ") - (insert-rect removed) - (insert-align-label "+ ") - (insert-rect added) - (insert "\n"))) - (when actual - (insert-label "actual") - (insert-rect actual))) - (when error - (insert-label "error") - (insert-text-button error - 'follow-link t - 'action '(lambda (_button) (cider-test-stacktrace)) - 'help-echo "View causes and stacktrace") - (insert "\n")) - (when gen-input - (insert-label "input") - (insert (cider-font-lock-as-clojure gen-input))) - (overlay-put (make-overlay beg (point)) 'font-lock-face bg)) - (insert "\n")))))) - -(defun cider-test-non-passing (tests) - "For a list of TESTS, each an `nrepl-dict`, return only those that did not pass." - (seq-filter (lambda (test) - (unless (equal (nrepl-dict-get test "type") "pass") - test)) - tests)) - -(defun cider-test-render-report (buffer summary results) - "Emit into BUFFER the report for the SUMMARY, and test RESULTS." - (with-current-buffer buffer - (let ((inhibit-read-only t)) - (cider-test-report-mode) - (cider-insert "Test Summary" 'bold t) - (dolist (ns (nrepl-dict-keys results)) - (insert (cider-propertize ns 'ns) "\n")) - (cider-insert "\n") - (cider-test-render-summary buffer summary) - (nrepl-dbind-response summary (fail error) - (unless (zerop (+ fail error)) - (cider-insert "Results" 'bold t "\n") - ;; Results are a nested dict, keyed first by ns, then var. Within each - ;; var is a sequence of test assertion results. - (nrepl-dict-map - (lambda (ns vars) - (nrepl-dict-map - (lambda (_var tests) - (let* ((problems (cider-test-non-passing tests)) - (count (length problems))) - (when (< 0 count) - (insert (format "%s\n%d non-passing tests:\n\n" - (cider-propertize ns 'ns) count)) - (dolist (test problems) - (cider-test-render-assertion buffer test))))) - vars)) - results))) - ;; Replace any newline chars with actual newlines to make long error - ;; messages more readable - (goto-char (point-min)) - (while (search-forward "\\n" nil t) - (replace-match " -")) - (goto-char (point-min)) - (current-buffer)))) - - -;;; Message echo - -(defun cider-test-echo-running (ns &optional test) - "Echo a running message for the test NS, which may be a keyword. -The optional arg TEST denotes an individual test name." - (if test - (message "Running test %s in %s..." - (cider-propertize test 'bold) - (cider-propertize ns 'ns)) - (message "Running tests in %s..." - (concat (cider-propertize - (cond ((stringp ns) ns) - ((eq :non-passing ns) "failing") - ((eq :loaded ns) "all loaded") - ((eq :project ns) "all project")) - 'ns) - (unless (stringp ns) " namespaces"))))) - -(defun cider-test-echo-summary (summary results) - "Echo SUMMARY statistics for a test run returning RESULTS." - (nrepl-dbind-response summary (ns test var fail error) - (if (nrepl-dict-empty-p results) - (message (concat (propertize "No assertions (or no tests) were run." 'face 'cider-test-error-face) - "Did you forget to use `is' in your tests?")) - (message (propertize - "%sRan %d assertions, in %d test functions. %d failures, %d errors." - 'face (cond ((not (zerop error)) 'cider-test-error-face) - ((not (zerop fail)) 'cider-test-failure-face) - (t 'cider-test-success-face))) - (concat (if (= 1 ns) ; ns count from summary - (cider-propertize (car (nrepl-dict-keys results)) 'ns) - (propertize (format "%d namespaces" ns) 'face 'default)) - (propertize ": " 'face 'default)) - test var fail error)))) - -;;; Test definition highlighting -;; -;; On receipt of test results, failing/erring test definitions are highlighted. -;; Highlights are cleared on the next report run, and may be cleared manually -;; by the user. - -;; NOTE If keybindings specific to test sources are desired, it would be -;; straightforward to turn this into a `cider-test-mode' minor mode, which we -;; enable on test sources, much like the legacy `clojure-test-mode'. At present, -;; though, there doesn't seem to be much value in this, since the report buffer -;; provides the primary means of interacting with test results. - -(defun cider-test-highlight-problem (buffer test) - "Highlight the BUFFER test definition for the non-passing TEST." - (with-current-buffer buffer - ;; we don't need the file name here, as we always operate on the current - ;; buffer and the line data is correct even for vars that were - ;; defined interactively - (nrepl-dbind-response test (type line message expected actual) - (when line - (save-excursion - (goto-char (point-min)) - (forward-line (1- line)) - (search-forward "(" nil t) - (let ((beg (point))) - (forward-sexp) - (cider--make-overlay beg (point) 'cider-test - 'font-lock-face (cider-test-type-face type) - 'type type - 'help-echo message - 'message message - 'expected expected - 'actual actual))))))) - -(defun cider-find-var-file (ns var) - "Return the buffer visiting the file in which the NS VAR is defined. -Or nil if not found." - (when-let* ((info (cider-var-info (concat ns "/" var))) - (file (nrepl-dict-get info "file"))) - (cider-find-file file))) - -(defun cider-test-highlight-problems (results) - "Highlight all non-passing tests in the test RESULTS." - (nrepl-dict-map - (lambda (ns vars) - (nrepl-dict-map - (lambda (var tests) - (when-let* ((buffer (cider-find-var-file ns var))) - (dolist (test tests) - (nrepl-dbind-response test (type) - (unless (equal "pass" type) - (cider-test-highlight-problem buffer test)))))) - vars)) - results)) - -(defun cider-test-clear-highlights () - "Clear highlighting of non-passing tests from the last test run." - (interactive) - (when cider-test-last-results - (nrepl-dict-map - (lambda (ns vars) - (dolist (var (nrepl-dict-keys vars)) - (when-let* ((buffer (cider-find-var-file ns var))) - (with-current-buffer buffer - (remove-overlays nil nil 'category 'cider-test))))) - cider-test-last-results))) - - -;;; Test namespaces -;; -;; Test namespace inference exists to enable DWIM test running functions: the -;; same "run-tests" function should be able to be used in a source file, and in -;; its corresponding test namespace. To provide this, we need to map the -;; relationship between those namespaces. - -(defcustom cider-test-infer-test-ns 'cider-test-default-test-ns-fn - "Function to infer the test namespace for NS. -The default implementation uses the simple Leiningen convention of appending -'-test' to the namespace name." - :type 'symbol - :package-version '(cider . "0.7.0")) - -(defun cider-test-default-test-ns-fn (ns) - "For a NS, return the test namespace, which may be the argument itself. -This uses the Leiningen convention of appending '-test' to the namespace name." - (when ns - (let ((suffix "-test")) - (if (string-suffix-p suffix ns) - ns - (concat ns suffix))))) - - -;;; Test execution - -(defcustom cider-test-default-include-selectors '() - "List of include selector strings to use when executing tests if none provided." - :type '(repeat string) - :package-version '(cider . "1.1.0")) - -(defcustom cider-test-default-exclude-selectors '() - "List of exclude selector strings to use when executing tests if none provided." - :type '(repeat string) - :package-version '(cider . "1.1.0")) - -(declare-function cider-emit-interactive-eval-output "cider-eval") -(declare-function cider-emit-interactive-eval-err-output "cider-eval") - -(defun cider-test--prompt-for-selectors (message) - "Prompt for test selectors with MESSAGE. -The selectors can be either keywords or strings." - (mapcar - (lambda (string) (replace-regexp-in-string "^:+" "" string)) - (split-string - (cider-read-from-minibuffer message)))) - -(defun cider-test-execute (ns &optional tests silent prompt-for-filters) - "Run tests for NS, which may be a keyword, optionally specifying TESTS. -This tests a single NS, or multiple namespaces when using keywords `:project', -`:loaded' or `:non-passing'. Optional TESTS are only honored when a single -namespace is specified. Upon test completion, results are echoed and a test -report is optionally displayed. When test failures/errors occur, their sources -are highlighted. -If SILENT is non-nil, suppress all messages other then test results. -If PROMPT-FOR-FILTERS is non-nil, prompt the user for a test selector filters. -The include/exclude selectors will be used to filter the tests before -running them." - (cider-test-clear-highlights) - (let ((include-selectors - (if prompt-for-filters - (cider-test--prompt-for-selectors - "Test selectors to include (space separated): ") - cider-test-default-include-selectors)) - (exclude-selectors - (if prompt-for-filters - (cider-test--prompt-for-selectors - "Test selectors to exclude (space separated): ") - cider-test-default-exclude-selectors))) - (cider-map-repls :clj-strict - (lambda (conn) - (unless silent - (if (and tests (= (length tests) 1)) - ;; we generate a different message when running individual tests - (cider-test-echo-running ns (car tests)) - (cider-test-echo-running ns))) - (let ((request `("op" ,(cond ((stringp ns) "test") - ((eq :project ns) "test-all") - ((eq :loaded ns) "test-all") - ((eq :non-passing ns) "retest"))))) - ;; we add optional parts of the request only when relevant - (when (and (listp include-selectors) include-selectors) - (setq request (append request `("include" ,include-selectors)))) - (when (and (listp exclude-selectors) exclude-selectors) - (setq request (append request `("exclude" ,exclude-selectors)))) - (when (stringp ns) - (setq request (append request `("ns" ,ns)))) - (when (stringp ns) - (setq request (append request `("tests" ,tests)))) - (when (or (stringp ns) (eq :project ns)) - (setq request (append request `("load?" ,"true")))) - (cider-nrepl-send-request - request - (lambda (response) - (nrepl-dbind-response response (summary results status out err) - (cond ((member "namespace-not-found" status) - (unless silent - (message "No test namespace: %s" (cider-propertize ns 'ns)))) - (out (cider-emit-interactive-eval-output out)) - (err (cider-emit-interactive-eval-err-output err)) - (results - (nrepl-dbind-response summary (error fail) - (setq cider-test-last-summary summary) - (setq cider-test-last-results results) - (cider-test-highlight-problems results) - (cider-test-echo-summary summary results) - (if (or (not (zerop (+ error fail))) - cider-test-show-report-on-success) - (cider-test-render-report - (cider-popup-buffer - cider-test-report-buffer - cider-auto-select-test-report-buffer) - summary - results) - (when (get-buffer cider-test-report-buffer) - (with-current-buffer cider-test-report-buffer - (let ((inhibit-read-only t)) - (erase-buffer))) - (cider-test-render-report - cider-test-report-buffer - summary results)))))))) - conn)))))) - -(defun cider-test-rerun-failed-tests () - "Rerun failed and erring tests from the last test run." - (interactive) - (if cider-test-last-summary - (nrepl-dbind-response cider-test-last-summary (fail error) - (if (not (zerop (+ error fail))) - (cider-test-execute :non-passing) - (message "No prior failures to retest"))) - (message "No prior results to retest"))) - -(defun cider-test-run-loaded-tests (prompt-for-filters) - "Run all tests defined in currently loaded namespaces. - -If PROMPT-FOR-FILTERS is non-nil, prompt the user for a test selectors to -filter the tests with." - (interactive "P") - (cider-test-execute :loaded nil nil prompt-for-filters)) - -(defun cider-test-run-project-tests (prompt-for-filters) - "Run all tests defined in all project namespaces, loading these as needed. - -If PROMPT-FOR-FILTERS is non-nil, prompt the user for a test selectors to -filter the tests with." - (interactive "P") - (cider-test-execute :project nil nil prompt-for-filters)) - -(defun cider-test-run-ns-tests-with-filters (suppress-inference) - "Run tests filtered by selectors for the current Clojure namespace context. - -With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the -current ns." - (interactive "P") - (cider-test-run-ns-tests suppress-inference nil 't)) - -(defun cider-test-run-ns-tests (suppress-inference &optional silent prompt-for-filters) - "Run all tests for the current Clojure namespace context. - -If SILENT is non-nil, suppress all messages other then test results. -With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the -current ns. If PROMPT-FOR-FILTERS is non-nil, prompt the user for -test selectors to filter the tests with." - (interactive "P") - (if-let* ((ns (if suppress-inference - (cider-current-ns t) - (funcall cider-test-infer-test-ns (cider-current-ns t))))) - (cider-test-execute ns nil silent prompt-for-filters) - (if (eq major-mode 'cider-test-report-mode) - (when (y-or-n-p (concat "Test report does not define a namespace. " - "Rerun failed/erring tests?")) - (cider-test-rerun-failed-tests)) - (unless silent - (message "No namespace to test in current context"))))) - -(defvar cider-test-last-test-ns nil - "The ns of the last test ran with `cider-test-run-test'.") -(defvar cider-test-last-test-var nil - "The var of the last test ran with `cider-test-run-test'.") - -(defun cider-test-update-last-test (ns var) - "Update the last test by setting NS and VAR. - -See `cider-test-rerun-test'." - (setq cider-test-last-test-ns ns - cider-test-last-test-var var)) - -(defun cider-test-run-test () - "Run the test at point. -The test ns/var exist as text properties on report items and on highlighted -failed/erred test definitions. When not found, a test definition at point -is searched." - (interactive) - (let ((ns (get-text-property (point) 'ns)) - (var (get-text-property (point) 'var))) - (if (and ns var) - ;; we're in a `cider-test-report-mode' buffer - ;; or on a highlighted failed/erred test definition - (progn - (cider-test-update-last-test ns var) - (cider-test-execute ns (list var))) - ;; we're in a `clojure-mode' buffer - (let* ((ns (clojure-find-ns)) - (def (clojure-find-def)) ; it's a list of the form (deftest something) - (deftype (car def)) - (var (cadr def))) - (if (and ns (member deftype cider-test-defining-forms)) - (progn - (cider-test-update-last-test ns (list var)) - (cider-test-execute ns (list var))) - (message "No test at point")))))) - -(defun cider-test-rerun-test () - "Re-run the test that was previously ran." - (interactive) - (if (and cider-test-last-test-ns cider-test-last-test-var) - (cider-test-execute cider-test-last-test-ns cider-test-last-test-var) - (user-error "No test to re-run"))) - -;;; Auto-test mode -(defun cider--test-silently () - "Like `cider-test-run-tests', but with less feedback. -Only notify the user if there actually were any tests to run and only after -the results are received." - (when (cider-connected-p) - (let ((cider-auto-select-test-report-buffer nil) - (cider-test-show-report-on-success nil)) - (cider-test-run-ns-tests nil 'soft)))) - -;;;###autoload -(define-minor-mode cider-auto-test-mode - "Toggle automatic testing of Clojure files. - -When enabled this reruns tests every time a Clojure file is loaded. -Only runs tests corresponding to the loaded file's namespace and does -nothing if no tests are defined or if the file failed to load." - :init-value nil :lighter (cider-mode " Test") :keymap nil - :global t - (if cider-auto-test-mode - (add-hook 'cider-file-loaded-hook #'cider--test-silently) - (remove-hook 'cider-file-loaded-hook #'cider--test-silently))) - -(provide 'cider-test) - -;;; cider-test.el ends here diff --git a/elpa/cider-20230707.640/cider-tracing.el b/elpa/cider-20230707.640/cider-tracing.el deleted file mode 100644 index f7a312e6..00000000 --- a/elpa/cider-20230707.640/cider-tracing.el +++ /dev/null @@ -1,90 +0,0 @@ -;;; cider-tracing.el --- Executing tracing functionality -*- lexical-binding: t -*- - -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Bozhidar Batsov -;; Artur Malabarba - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; A couple of commands for tracing the execution of functions. - -;;; Code: - -(require 'cider-client) -(require 'cider-common) ; for `cider-prompt-for-symbol-function' -(require 'cider-util) ; for `cider-propertize' -(require 'cider-connection) ; for `cider-map-repls' -(require 'nrepl-dict) - -(defun cider-sync-request:toggle-trace-var (sym) - "Toggle var tracing for SYM." - (thread-first `("op" "toggle-trace-var" - "ns" ,(cider-current-ns) - "sym" ,sym) - (cider-nrepl-send-sync-request))) - -(defun cider--toggle-trace-var (sym) - "Toggle var tracing for SYM." - (let* ((trace-response (cider-sync-request:toggle-trace-var sym)) - (var-name (nrepl-dict-get trace-response "var-name")) - (var-status (nrepl-dict-get trace-response "var-status"))) - (pcase var-status - ("not-found" (error "Var %s not found" (cider-propertize sym 'fn))) - ("not-traceable" (error "Var %s can't be traced because it's not bound to a function" (cider-propertize var-name 'fn))) - (_ (message "Var %s %s" (cider-propertize var-name 'fn) var-status))))) - -;;;###autoload -(defun cider-toggle-trace-var (arg) - "Toggle var tracing. -Prompts for the symbol to use, or uses the symbol at point, depending on -the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the -opposite of what that option dictates." - (interactive "P") - (cider-ensure-op-supported "toggle-trace-var") - (funcall (cider-prompt-for-symbol-function arg) - "Toggle trace for var" - #'cider--toggle-trace-var)) - -(defun cider-sync-request:toggle-trace-ns (ns) - "Toggle namespace tracing for NS." - (thread-first `("op" "toggle-trace-ns" - "ns" ,ns) - (cider-nrepl-send-sync-request))) - -;;;###autoload -(defun cider-toggle-trace-ns (query) - "Toggle ns tracing. -Defaults to the current ns. With prefix arg QUERY, prompts for a ns." - (interactive "P") - (cider-map-repls :clj-strict - (lambda (conn) - (with-current-buffer conn - (cider-ensure-op-supported "toggle-trace-ns") - (let ((ns (if query - (completing-read "Toggle trace for ns: " - (cider-sync-request:ns-list)) - (cider-current-ns)))) - (let* ((trace-response (cider-sync-request:toggle-trace-ns ns)) - (ns-status (nrepl-dict-get trace-response "ns-status"))) - (pcase ns-status - ("not-found" (error "Namespace %s not found" (cider-propertize ns 'ns))) - (_ (message "Namespace %s %s" (cider-propertize ns 'ns) ns-status))))))))) - -(provide 'cider-tracing) -;;; cider-tracing.el ends here diff --git a/elpa/cider-20230707.640/cider-util.el b/elpa/cider-20230707.640/cider-util.el deleted file mode 100644 index 315eca3e..00000000 --- a/elpa/cider-20230707.640/cider-util.el +++ /dev/null @@ -1,808 +0,0 @@ -;; cider-util.el --- Common utility functions that don't belong anywhere else -*- lexical-binding: t -*- - -;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Tim King -;; Phil Hagelberg -;; Bozhidar Batsov -;; Artur Malabarba -;; Hugo Duncan -;; Steve Purcell - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Common utility functions that don't belong anywhere else. - -;;; Code: - -;; Built-ins -(require 'ansi-color) -(require 'color) -(require 'seq) -(require 'subr-x) -(require 'thingatpt) - -;; clojure-mode and CIDER -(require 'clojure-mode) - -(defalias 'cider-pop-back #'pop-tag-mark) - -(defcustom cider-font-lock-max-length 10000 - "The max length of strings to fontify in `cider-font-lock-as'. - -Setting this to nil removes the fontification restriction." - :group 'cider - :type 'boolean - :package-version '(cider . "0.10.0")) - -(defun cider-util--hash-keys (hashtable) - "Return a list of keys in HASHTABLE." - (let ((keys '())) - (maphash (lambda (k _v) (setq keys (cons k keys))) hashtable) - keys)) - -(defun cider-util--clojure-buffers () - "Return a list of all existing `clojure-mode' buffers." - (seq-filter - (lambda (buffer) (with-current-buffer buffer (derived-mode-p 'clojure-mode))) - (buffer-list))) - -(defun cider-current-dir () - "Return the directory of the current buffer." - (if buffer-file-name - (file-name-directory buffer-file-name) - default-directory)) - -(defun cider-in-string-p () - "Return non-nil if point is in a string." - (let ((beg (save-excursion (beginning-of-defun) (point)))) - (nth 3 (parse-partial-sexp beg (point))))) - -(defun cider-in-comment-p () - "Return non-nil if point is in a comment." - (let ((beg (save-excursion (beginning-of-defun) (point)))) - (nth 4 (parse-partial-sexp beg (point))))) - -(defun cider--tooling-file-p (file-name) - "Return t if FILE-NAME is not a 'real' source file. -Currently, only check if the relative file name starts with 'form-init' -which nREPL uses for temporary evaluation file names." - (let ((fname (file-name-nondirectory file-name))) - (string-match-p "^form-init" fname))) - -(defun cider--cljc-buffer-p (&optional buffer) - "Return non-nil if the current buffer is visiting a cljc file. - -If BUFFER is provided act on that buffer instead." - (with-current-buffer (or buffer (current-buffer)) - (or (derived-mode-p 'clojurec-mode)))) - - -;;; Thing at point - -(defun cider--text-or-limits (bounds start end) - "Returns the substring or the bounds of text. -If BOUNDS is non-nil, returns the list (START END) of character -positions. Else returns the substring from START to END." - (funcall (if bounds #'list #'buffer-substring-no-properties) - start end)) - -(defun cider-defun-at-point (&optional bounds) - "Return the text of the top level sexp at point. -If BOUNDS is non-nil, return a list of its starting and ending position -instead." - (save-excursion - (save-match-data - (end-of-defun) - (let ((end (point))) - (clojure-backward-logical-sexp 1) - (cider--text-or-limits bounds (point) end))))) - -(defun cider-ns-form () - "Retrieve the ns form." - (when (clojure-find-ns) - (save-excursion - (goto-char (match-beginning 0)) - (cider-defun-at-point)))) - -(defun cider-symbol-at-point (&optional look-back) - "Return the name of the symbol at point, otherwise nil. -Ignores the REPL prompt. If LOOK-BACK is non-nil, move backwards trying to -find a symbol if there isn't one at point. -Does not strip the : from keywords, nor attempt to expand :: auto-resolved -keywords." - (or (when-let* ((str (thing-at-point 'symbol))) - (unless (text-property-any 0 (length str) 'field 'cider-repl-prompt str) - ;; remove font-locking - (setq str (substring-no-properties str)) - (if (member str '("." "..")) - str - ;; Remove prefix quotes, and trailing . from constructors like Record. - (thread-last - str - ;; constructors (Foo.) - (string-remove-suffix ".") - ;; quoted symbols ('sym) - (string-remove-prefix "'") - ;; var references (#'inc 2) - (string-remove-prefix "#'"))))) - (when look-back - (save-excursion - (ignore-errors - (when (looking-at "(") - (forward-char 1)) - (while (not (looking-at "\\sw\\|\\s_\\|\\`")) - (forward-sexp -1))) - (cider-symbol-at-point))))) - - -;;; sexp navigation -(defun cider-sexp-at-point (&optional bounds) - "Return the sexp at point as a string, otherwise nil. -If BOUNDS is non-nil, return a list of its starting and ending position -instead." - (when-let* ((b (or (and (equal (char-after) ?\() - (member (char-before) '(?\' ?\, ?\@)) - ;; hide stuff before ( to avoid quirks with '( etc. - (save-restriction - (narrow-to-region (point) (point-max)) - (bounds-of-thing-at-point 'sexp))) - (bounds-of-thing-at-point 'sexp)))) - (funcall (if bounds #'list #'buffer-substring-no-properties) - (car b) (cdr b)))) - -(defun cider-list-at-point (&optional bounds) - "Return the list (compound form) at point as a string, otherwise nil. -If BOUNDS is non-nil, return a list of its starting and ending position -instead." - (when-let* ((b (or (and (equal (char-after) ?\() - (member (char-before) '(?\' ?\, ?\@)) - ;; hide stuff before ( to avoid quirks with '( etc. - (save-restriction - (narrow-to-region (point) (point-max)) - (bounds-of-thing-at-point 'list))) - (bounds-of-thing-at-point 'list)))) - (funcall (if bounds #'list #'buffer-substring-no-properties) - (car b) (cdr b)))) - -(defun cider-last-sexp (&optional bounds) - "Return the sexp preceding the point. -If BOUNDS is non-nil, return a list of its starting and ending position -instead." - (apply (if bounds #'list #'buffer-substring-no-properties) - (save-excursion - (clojure-backward-logical-sexp 1) - (list (point) - (progn (clojure-forward-logical-sexp 1) - (point)))))) - -(defun cider-start-of-next-sexp (&optional skip) - "Move to the start of the next sexp. -Skip any non-logical sexps like ^metadata or #reader macros. -If SKIP is an integer, also skip that many logical sexps first. -Can only error if SKIP is non-nil." - (while (clojure--looking-at-non-logical-sexp) - (forward-sexp 1)) - (when (and skip (> skip 0)) - (dotimes (_ skip) - (forward-sexp 1) - (cider-start-of-next-sexp)))) - -(defun cider-second-sexp-in-list () - "Return the second sexp in the list at point." - (condition-case nil - (save-excursion - (backward-up-list) - (forward-char) - (forward-sexp 2) - (cider-sexp-at-point)) - (error nil))) - -;;; Text properties - -(defun cider-maybe-intern (name) - "If NAME is a symbol, return it; otherwise, intern it." - (if (symbolp name) name (intern name))) - -(defun cider-intern-keys (plist) - "Copy PLIST, with any non-symbol keys replaced with symbols." - (when plist - (cons (cider-maybe-intern (pop plist)) - (cons (pop plist) (cider-intern-keys plist))))) - -(defmacro cider-propertize-region (props &rest body) - "Execute BODY and add PROPS to all the inserted text. -More precisely, PROPS are added to the region between the point's -positions before and after executing BODY." - (declare (indent 1) - (debug (sexp body))) - (let ((start (make-symbol "start"))) - `(let ((,start (point))) - (prog1 (progn ,@body) - (add-text-properties ,start (point) ,props))))) - -(put 'cider-propertize-region 'lisp-indent-function 1) - -(defun cider-property-bounds (prop) - "Return the the positions of the previous and next change to PROP. -PROP is the name of a text property." - (let ((end (next-single-char-property-change (point) prop))) - (list (previous-single-char-property-change end prop) end))) - -(defun cider-insert (text &optional face break more-text) - "Insert TEXT with FACE, optionally followed by a line BREAK and MORE-TEXT." - (insert (if face (propertize text 'font-lock-face face) text)) - (when more-text (insert more-text)) - (when break (insert "\n"))) - - -;;; Hooks - -(defun cider-run-chained-hook (hook arg) - "Like `run-hook-with-args' but pass intermediate return values through. -HOOK is a name of a hook (a symbol). You can use `add-hook' or -`remove-hook' to add functions to this variable. ARG is passed to first -function. Its return value is passed to the second function and so forth -till all functions are called or one of them returns nil. Return the value -return by the last called function." - (let ((functions (copy-sequence (symbol-value hook)))) - (while (and functions arg) - (if (eq (car functions) t) - ;; global value of the hook - (let ((functions (default-value hook))) - (while (and functions arg) - (setq arg (funcall (car functions) arg)) - (setq functions (cdr functions)))) - (setq arg (funcall (car functions) arg))) - (setq functions (cdr functions))) - arg)) - - -;;; Font lock - -(defvar cider--mode-buffers nil - "A list of buffers for different major modes.") - -(defun cider--make-buffer-for-mode (mode) - "Return a temp buffer using `major-mode' MODE. -This buffer is not designed to display anything to the user. For that, use -`cider-make-popup-buffer' instead." - (setq cider--mode-buffers (seq-filter (lambda (x) (buffer-live-p (cdr x))) - cider--mode-buffers)) - (or (cdr (assq mode cider--mode-buffers)) - (let ((b (generate-new-buffer (format " *cider-temp %s*" mode)))) - (push (cons mode b) cider--mode-buffers) - (with-current-buffer b - ;; suppress major mode hooks as we care only about their font-locking - ;; otherwise modes like whitespace-mode and paredit might interfere - (setq-local delay-mode-hooks t) - (setq delayed-mode-hooks nil) - (funcall mode)) - b))) - -(defun cider-ansi-color-string-p (string) - "Return non-nil if STRING is an ANSI string." - (string-match "^\\[" string)) - -(defun cider-font-lock-as (mode string) - "Use MODE to font-lock the STRING." - (let ((string (if (cider-ansi-color-string-p string) - (substring-no-properties (ansi-color-apply string)) - string))) - (if (or (null cider-font-lock-max-length) - (< (length string) cider-font-lock-max-length)) - (with-current-buffer (cider--make-buffer-for-mode mode) - (erase-buffer) - (insert string) - ;; don't try to font-lock unbalanced Clojure code - (when (eq mode 'clojure-mode) - (check-parens)) - (font-lock-fontify-region (point-min) (point-max)) - (buffer-string)) - string))) - -(defun cider-font-lock-region-as (mode beg end &optional buffer) - "Use MODE to font-lock text between BEG and END. - -Unless you specify a BUFFER it will default to the current one." - (with-current-buffer (or buffer (current-buffer)) - (let ((text (buffer-substring beg end))) - (delete-region beg end) - (goto-char beg) - (insert (cider-font-lock-as mode text))))) - -(defun cider-font-lock-as-clojure (string) - "Font-lock STRING as Clojure code." - ;; If something goes wrong (e.g. the code is not balanced) - ;; we simply return the string. - (condition-case nil - (cider-font-lock-as 'clojure-mode string) - (error string))) - -;; Button allowing use of `font-lock-face', ignoring any inherited `face' -(define-button-type 'cider-plain-button - 'face nil) - -(defun cider-add-face (regexp face &optional foreground-only sub-expr object) - "Propertize all occurrences of REGEXP with FACE. -If FOREGROUND-ONLY is non-nil, change only the foreground of matched -regions. SUB-EXPR is a sub-expression of REGEXP to be -propertized (defaults to 0). OBJECT is an object to be -propertized (defaults to current buffer)." - (setq sub-expr (or sub-expr 0)) - (when (and regexp face) - (let ((beg 0) - (end 0)) - (with-current-buffer (or (and (bufferp object) object) - (current-buffer)) - (while (if (stringp object) - (string-match regexp object end) - (re-search-forward regexp nil t)) - (setq beg (match-beginning sub-expr) - end (match-end sub-expr)) - (if foreground-only - (let ((face-spec (list (cons 'foreground-color - (face-attribute face :foreground nil t))))) - (font-lock-prepend-text-property beg end 'face face-spec object)) - (put-text-property beg end 'face face object))))))) - - -;;; Colors - -(defun cider-scale-background-color () - "Scale the current background color to get a slighted muted version." - (let ((color (frame-parameter nil 'background-color)) - (darkp (eq (frame-parameter nil 'background-mode) 'dark))) - (unless (equal "unspecified-bg" color) - (color-lighten-name color (if darkp 5 -5))))) - -(defvar cider-version) -(defvar cider-codename) - -(defun cider--pkg-version () - "Extract CIDER's package version from its package metadata." - ;; Use `cond' below to avoid a compiler unused return value warning - ;; when `package-get-version' returns nil. See #3181. - ;; FIXME: Inline the logic from package-get-version and adapt it - (cond ((fboundp 'package-get-version) - (package-get-version)))) - -(defun cider--version () - "Retrieve CIDER's version. -A codename is added to stable versions." - (if (string-match-p "-snapshot" cider-version) - (let ((pkg-version (cider--pkg-version))) - (if pkg-version - ;; snapshot versions include the MELPA package version - (format "%s (package: %s)" cider-version pkg-version) - cider-version)) - ;; stable versions include the codename of the release - (format "%s (%s)" cider-version cider-codename))) - - -;;; Strings - -(defun cider-join-into-alist (candidates &optional separator) - "Make an alist from CANDIDATES. -The keys are the elements joined with SEPARATOR and values are the original -elements. Useful for `completing-read' when candidates are complex -objects." - (mapcar (lambda (el) - (if (listp el) - (cons (string-join el (or separator ":")) el) - (cons el el))) - candidates)) - -(defun cider-add-to-alist (symbol car cadr) - "Add '(CAR CADR) to the alist stored in SYMBOL. -If CAR already corresponds to an entry in the alist, destructively replace -the entry's second element with CADR. - -This can be used, for instance, to update the version of an injected -plugin or dependency with: - (cider-add-to-alist 'cider-jack-in-lein-plugins - \"plugin/artifact-name\" \"THE-NEW-VERSION\")" - (let ((alist (symbol-value symbol))) - (if-let* ((cons (assoc car alist))) - (setcdr cons (list cadr)) - (set symbol (cons (list car cadr) alist))))) - -(defun cider-namespace-qualified-p (sym) - "Return t if SYM is namespace-qualified." - (string-match-p "[^/]+/" sym)) - -(defvar cider-version) - -(defconst cider-manual-url "https://docs.cider.mx/cider/%s" - "The URL to CIDER's manual.") - -(defun cider-version-sans-patch () - "Return the version sans that patch." - (string-join (seq-take (split-string cider-version "\\.") 2) ".")) - -(defun cider--manual-version () - "Convert the version to a ReadTheDocs-friendly version." - (if (string-match-p "-snapshot" cider-version) - "" - (concat (cider-version-sans-patch) "/"))) - -(defun cider-manual-url () - "The CIDER manual's url." - (format cider-manual-url (cider--manual-version))) - -;;;###autoload -(defun cider-view-manual () - "View the manual in your default browser." - (interactive) - (browse-url (cider-manual-url))) - -(defun cider--manual-button (label section-id) - "Return a button string that links to the online manual. -LABEL is the displayed string, and SECTION-ID is where it points -to." - (with-temp-buffer - (insert-text-button - label - 'follow-link t - 'action (lambda (&rest _) (interactive) - (browse-url (concat (cider-manual-url) - section-id)))) - (buffer-string))) - -(defconst cider-refcard-url "https://github.com/clojure-emacs/cider/raw/%s/refcard/cider-refcard.pdf" - "The URL to CIDER's refcard.") - -(defun cider--github-version () - "Convert the version to a GitHub-friendly version." - (if (string-match-p "-snapshot" cider-version) - "master" - (concat "v" cider-version))) - -(defun cider-refcard-url () - "The CIDER manual's url." - (format cider-refcard-url (cider--github-version))) - -(defun cider-view-refcard () - "View the refcard in your default browser." - (interactive) - (browse-url (cider-refcard-url))) - -(defconst cider-report-bug-url "https://github.com/clojure-emacs/cider/issues/new" - "The URL to report a CIDER issue.") - -(defun cider-report-bug () - "Report a bug in your default browser." - (interactive) - (browse-url cider-report-bug-url)) - -(defun cider--project-name (dir) - "Extracts a project name from DIR, possibly nil. -The project name is the final component of DIR if not nil." - (when dir - (file-name-nondirectory (directory-file-name dir)))) - -;;; Vectors -(defun cider--deep-vector-to-list (x) - "Convert vectors in X to lists. -If X is a sequence, return a list of `cider--deep-vector-to-list' applied to -each of its elements. -Any other value is just returned." - (if (sequencep x) - (mapcar #'cider--deep-vector-to-list x) - x)) - - -;;; Help mode - -;; Same as https://github.com/emacs-mirror/emacs/blob/86d083438dba60dc00e9e96414bf7e832720c05a/lisp/help-mode.el#L355 -;; the original function uses some buffer local variables, but the buffer used -;; is not configurable. It defaults to (help-buffer) - -(defun cider--help-setup-xref (item interactive-p buffer) - "Invoked from commands using the \"*Help*\" buffer to install some xref info. - -ITEM is a (FUNCTION . ARGS) pair appropriate for recreating the help -buffer after following a reference. INTERACTIVE-P is non-nil if the -calling command was invoked interactively. In this case the stack of -items for help buffer \"back\" buttons is cleared. Use BUFFER for the -buffer local variables. - -This should be called very early, before the output buffer is cleared, -because we want to record the \"previous\" position of point so we can -restore it properly when going back." - (with-current-buffer buffer - (when help-xref-stack-item - (push (cons (point) help-xref-stack-item) help-xref-stack) - (setq help-xref-forward-stack nil)) - (when interactive-p - (let ((tail (nthcdr 10 help-xref-stack))) - ;; Truncate the stack. - (if tail (setcdr tail nil)))) - (setq help-xref-stack-item item))) - -(defcustom cider-doc-xref-regexp - (eval-and-compile - (rx-to-string - `(or (: "`" (group-n 1 (+ (not space))) "`") ; `var` - (: "[[" (group-n 1 (+ (not space))) "]]") ; [[var]] - (group-n 1 (regexp ,clojure--sym-regexp) "/" (regexp ,clojure--sym-regexp))))) ;; Fully qualified - "The regexp used to search Clojure vars in doc buffers." - :type 'regexp - :safe #'stringp - :group 'cider - :package-version '(cider . "0.13.0")) - -(defun cider--find-symbol-xref () - "Parse and return the first clojure symbol in current buffer. -Use `cider-doc-xref-regexp' for the search. Set match data and return a -string of the Clojure symbol. Return nil if there are no more matches in -the buffer." - (when (re-search-forward cider-doc-xref-regexp nil t) - (match-string 1))) - -(declare-function cider-doc-lookup "cider-doc") -(declare-function cider--eldoc-remove-dot "cider-eldoc") - -;; Taken from: https://github.com/emacs-mirror/emacs/blob/65c8c7cb96c14f9c6accd03cc8851b5a3459049e/lisp/help-mode.el#L551-L565 -(defun cider--make-back-forward-xrefs (&optional buffer) - "Insert special references `back' and `forward', as in `help-make-xrefs'. - -Optional argument BUFFER is the buffer in which to insert references. -Default is current buffer." - (with-current-buffer (or buffer (current-buffer)) - (insert "\n") - (when (or help-xref-stack help-xref-forward-stack) - (insert "\n")) - ;; Make a back-reference in this buffer if appropriate. - (when help-xref-stack - (help-insert-xref-button help-back-label 'help-back - (current-buffer))) - ;; Make a forward-reference in this buffer if appropriate. - (when help-xref-forward-stack - (when help-xref-stack - (insert "\t")) - (help-insert-xref-button help-forward-label 'help-forward - (current-buffer))) - (when (or help-xref-stack help-xref-forward-stack) - (insert "\n")))) - -;; Similar to https://github.com/emacs-mirror/emacs/blob/65c8c7cb96c14f9c6accd03cc8851b5a3459049e/lisp/help-mode.el#L404 -(defun cider--doc-make-xrefs () - "Parse and hyperlink documentation cross-references in current buffer. -Find cross-reference information in a buffer and activate such cross -references for selection with `help-xref'. Cross-references are parsed -using `cider--find-symbol-xref'. - -Special references `back' and `forward' are made to go back and forth -through a stack of help buffers. Variables `help-back-label' and -`help-forward-label' specify the text for that." - (interactive "b") - - ;; parse the docstring and create xrefs for symbols - (save-excursion - (goto-char (point-min)) - (let ((symbol)) - (while (setq symbol (cider--find-symbol-xref)) - (replace-match "") - (insert-text-button symbol - 'type 'help-xref - 'help-function (apply-partially #'cider-doc-lookup - (cider--eldoc-remove-dot symbol)))))) - (cider--make-back-forward-xrefs)) - - -;;; Words of inspiration -(defun cider-user-first-name () - "Find the current user's first name." - (let ((name (if (string= (user-full-name) "") - (user-login-name) - (user-full-name)))) - (string-match "^[^ ]*" name) - (capitalize (match-string 0 name)))) - -(defvar cider-words-of-inspiration - `("The best way to predict the future is to invent it. -Alan Kay" - "A point of view is worth 80 IQ points. -Alan Kay" - "Lisp isn't a language, it's a building material. -Alan Kay" - "Simple things should be simple, complex things should be possible. -Alan Kay" - "Everything should be as simple as possible, but not simpler. -Albert Einstein" - "Measuring programming progress by lines of code is like measuring aircraft building progress by weight. -Bill Gates" - "Controlling complexity is the essence of computer programming. -Brian Kernighan" - "The unavoidable price of reliability is simplicity. -C.A.R. Hoare" - "You're bound to be unhappy if you optimize everything. -Donald Knuth" - "Simplicity is prerequisite for reliability. -Edsger W. Dijkstra" - "Elegance is not a dispensable luxury but a quality that decides between success and failure. -Edsger W. Dijkstra" - "Deleted code is debugged code. -Jeff Sickel" - "The key to performance is elegance, not battalions of special cases. -Jon Bentley and Doug McIlroy" - "First, solve the problem. Then, write the code. -John Johnson" - "Simplicity is the ultimate sophistication. -Leonardo da Vinci" - "Programming is not about typing... it's about thinking. -Rich Hickey" - "Design is about pulling things apart. -Rich Hickey" - "Programmers know the benefits of everything and the tradeoffs of nothing. -Rich Hickey" - "Code never lies, comments sometimes do. -Ron Jeffries" - "The true delight is in the finding out rather than in the knowing. -Isaac Asimov" - "If paredit is not for you, then you need to become the sort of person that paredit is for. -Phil Hagelberg" - "Express Yourself. -Madonna" - "Put on your red shoes and dance the blues. -David Bowie" - "Do. Or do not. There is no try. -Yoda" - "The enjoyment of one's tools is an essential ingredient of successful work. -Donald E. Knuth" - "Not all those who wander are lost. -J.R.R. Tolkien" - "The best way to learn is to do. -P.R. Halmos" - "If you wish to make an apple pie from scratch, you must first invent the universe. -Carl Sagan" - "Learn the rules like a pro, so you can break them like an artist. -Pablo Picasso" - "The only way of discovering the limits of the possible is to venture a little way past them into the impossible. -Arthur C. Clarke" - "Don't wish it were easier. Wish you were better. -Jim Rohn" - "One chord is fine. Two chords is pushing it. Three chords and you're into jazz. -Lou Reed" - "We are all apprentices in a craft where no one ever becomes a master. -Ernest Hemingway" - "A designer knows he has achieved perfection not when there is nothing left to add, but when there is nothing left to take away. -Antoine de Saint-Exupery" - "Clojure isn't a language, it's a building material." - "Think big!" - "Think bold!" - "Think fun!" - "Code big!" - "Code bold!" - "Code fun!" - "Take this REPL, fellow hacker, and may it serve you well." - "Let the hacking commence!" - "Hacks and glory await!" - "Hack and be merry!" - "Your hacking starts... NOW!" - "May the Source be with you!" - "May the Source shine upon thy REPL!" - "Code long and prosper!" - "Happy hacking!" - "nREPL server is up, CIDER REPL is online!" - "CIDER REPL operational!" - "Your imagination is the only limit to what you can do with this REPL!" - "This REPL is yours to command!" - "Fame is but a hack away!" - "The REPL is not enough, but it is such a perfect place to start..." - "Keep on codin' in the free world!" - "What we do in the REPL echoes in eternity!" - "Evaluating is believing." - "To infinity... and beyond." - "Showtime!" - "Unfortunately, no one can be told what CIDER is. You have to figure this out yourself." - "Procure a bottle of cider to achieve optimum programming results." - "In parentheses we trust!" - "Write you some Clojure for Great Good!" - "Oh, what a day... what a lovely day!" - "What a day! What cannot be accomplished on such a splendid day!" - "Home is where your REPL is." - "The worst day programming is better than the best day working." - "The only thing worse than a rebel without a cause is a REPL without a clause." - "In the absence of parentheses, chaos prevails." - "One REPL to rule them all, One REPL to find them, One REPL to bring them all, and in parentheses bind them!" - "A blank REPL promotes creativity." - "A blank REPL is infinitely better than a blank cheque." - "May your functions be pure, your code concise and your programs a joy to behold!" - ,(format "%s, I've a feeling we're not in Kansas anymore." - (cider-user-first-name)) - ,(format "%s, this could be the start of a beautiful program." - (cider-user-first-name))) - "Scientifically-proven optimal words of hackerish encouragement.") - -(defun cider-random-words-of-inspiration () - "Select a random entry from `cider-words-of-inspiration'." - (nth (random (length cider-words-of-inspiration)) - cider-words-of-inspiration)) - -(defun cider-inspire-me () - "Display a random inspiration message." - (interactive) - (message (cider-random-words-of-inspiration))) - -(defvar cider-tips - '("Press <\\[cider-connect]> to connect to a running nREPL server." - "Press <\\[cider-quit]> to quit the current connection." - "Press <\\[cider-view-manual]> to view CIDER's manual." - "Press <\\[cider-view-refcard]> to view CIDER's refcard." - "Press <\\[describe-mode]> to see a list of the keybindings available (this will work in every Emacs buffer)." - "Press <\\[cider-repl-handle-shortcut]> to quickly invoke some REPL command." - "Press <\\[cider-switch-to-last-clojure-buffer]> to switch between the REPL and a Clojure source buffer." - "Press <\\[cider-doc]> to view the documentation for something (e.g. a var, a Java method)." - "Press <\\[cider-find-resource]> to find a resource on the classpath." - "Press <\\[cider-find-var]> to jump to the source of something (e.g. a var, a Java method)." - "Press <\\[cider-selector]> to quickly select a CIDER buffer." - "Press <\\[cider-test-run-ns-tests]> to run the tests for the current namespace." - "Press <\\[cider-test-run-loaded-tests]> to run all loaded tests." - "Press <\\[cider-test-run-project-tests]> to run all tests for the current project." - "Press <\\[cider-apropos]> to look for a symbol by some search string." - "Press <\\[cider-apropos-documentation]> to look for a symbol that has some string in its docstring." - "Press <\\[cider-eval-defun-at-point]> to eval the top-level form at point." - "Press <\\[cider-eval-defun-up-to-point]> to eval the top-level form up to the point." - "Press <\\[cider-eval-sexp-up-to-point]> to eval the current form up to the point." - "Press <\\[cider-eval-sexp-at-point]> to eval the current form around the point." - "Press <\\[cider-eval-sexp-at-point-in-context]> to eval the current form around the point in a user-provided context." - "Press <\\[cider-eval-buffer]> to eval the entire source buffer." - "Press <\\[cider-scratch]> to create a Clojure scratchpad. Pretty handy for prototyping." - "Press <\\[cider-read-and-eval]> to evaluate some Clojure expression directly in the minibuffer." - "Press <\\[cider-drink-a-sip]> to get more CIDER tips." - "Press <\\[cider-browse-ns-all]> to start CIDER's namespace browser." - "Press <\\[cider-classpath]> to start CIDER's classpath browser." - "Press <\\[cider-repl-history]> to start CIDER's REPL input history browser." - "Press <\\[cider-macroexpand-1]> to expand the preceding macro." - "Press <\\[cider-inspect]> to inspect the preceding expression's result." - "Press to inspect the defun at point's result." - "Press to read Clojure code from the minibuffer and inspect its result." - "Press <\\[cider-ns-refresh]> to reload modified and unloaded namespaces." - "You can define Clojure functions to be called before and after `cider-ns-refresh' (see `cider-ns-refresh-before-fn' and `cider-ns-refresh-after-fn'." - "Press <\\[cider-describe-connection]> to view information about the connection." - "Press <\\[cider-undef]> to undefine a symbol in the current namespace." - "Press <\\[cider-interrupt]> to interrupt an ongoing evaluation." - "Use to see every possible setting you can customize." - "Use to see every possible REPL setting you can customize." - "Enable `eldoc-mode' to display function & method signatures in the minibuffer." - "Enable `cider-enlighten-mode' to display the locals of a function when it's executed." - "Use <\\[cider-close-ancillary-buffers]> to close all ancillary buffers created by CIDER (e.g. *cider-doc*)." - "Exploring CIDER's menu-bar entries is a great way to discover features." - "Keep in mind that some commands don't have a keybinding by default. Explore CIDER!" - "Tweak `cider-repl-prompt-function' to customize your REPL prompt." - "Tweak `cider-eldoc-ns-function' to customize the way namespaces are displayed by eldoc." - "For no middleware, low-tech and reliable namespace reloading use <\\[cider-ns-reload]>." - "Press <\\[cider-load-buffer-and-switch-to-repl-buffer]> to load the current buffer and switch to the REPL buffer afterwards.") - "Some handy CIDER tips." - ) - -(defun cider-random-tip () - "Select a random tip from `cider-tips'." - (substitute-command-keys (nth (random (length cider-tips)) cider-tips))) - -(defun cider-drink-a-sip () - "Show a random tip." - (interactive) - (message (cider-random-tip))) - -(defun cider-column-number-at-pos (pos) - "Analog to `line-number-at-pos'. -Return buffer column number at position POS." - (save-excursion - (goto-char pos) - ;; we have to adjust the column number by 1 to account for the fact - ;; that Emacs starts counting columns from 0 and Clojure from 1 - (1+ (current-column)))) - -(defun cider-propertize (text kind) - "Propertize TEXT as KIND. -KIND can be the symbols `ns', `var', `emph', `fn', or a face name." - (propertize text 'face (pcase kind - (`fn 'font-lock-function-name-face) - (`method 'font-lock-function-name-face) - (`special-form 'font-lock-keyword-face) - (`macro 'font-lock-keyword-face) - (`var 'font-lock-variable-name-face) - (`ns 'font-lock-type-face) - (`emph 'font-lock-keyword-face) - (face face)))) - -(defun cider--menu-add-help-strings (menu-list) - "Add a :help entries to items in MENU-LIST." - (mapcar (lambda (x) - (cond - ((listp x) (cider--menu-add-help-strings x)) - ((and (vectorp x) - (not (plist-get (append x nil) :help)) - (functionp (elt x 1))) - (vconcat x `[:help ,(documentation (elt x 1))])) - (t x))) - menu-list)) - -(provide 'cider-util) - -;;; cider-util.el ends here diff --git a/elpa/cider-20230707.640/cider-xref.el b/elpa/cider-20230707.640/cider-xref.el deleted file mode 100644 index b25f9091..00000000 --- a/elpa/cider-20230707.640/cider-xref.el +++ /dev/null @@ -1,183 +0,0 @@ -;;; cider-xref.el --- Xref functionality for Clojure -*- lexical-binding: t -*- - -;; Copyright © 2019-2023 Bozhidar Batsov and CIDER contributors -;; -;; Author: Bozhidar Batsov - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Xref (find usages) functionality for Clojure. The implementation is based on -;; ideas from this article https://metaredux.com/posts/2019/05/04/discovering-runtime-function-references-in-clojure.html. -;; -;; Keep in mind that you won't get references in namespaces that haven't been loaded yet. - -;;; Code: - -(require 'cider-doc) -(require 'cider-find) -(require 'cider-util) -(require 'subr-x) - -(require 'cider-client) -(require 'cider-popup) -(require 'nrepl-dict) - -(require 'clojure-mode) -(require 'apropos) -(require 'button) - -(defconst cider-xref-buffer "*cider-xref*") - -(defcustom cider-xref-actions '(("display-doc" . cider-doc-lookup) - ("find-def" . cider--find-var) - ("lookup-on-clojuredocs" . cider-clojuredocs-lookup)) - "Controls the actions to be applied on the symbol found by an xref search. -The first action key in the list will be selected as default. If the list -contains only one action key, the associated action function will be -applied automatically. An action function can be any function that receives -the symbol found by the xref search as argument." - :type '(alist :key-type string :value-type function) - :group 'cider - :package-version '(cider . "0.22.0")) - -(defun cider-xref-doc (button) - "Display documentation for the symbol represented at BUTTON." - (cider-doc-lookup (button-get button 'apropos-symbol))) - -(defun cider-xref-result (result) - "Emit a RESULT into current buffer." - (let ((var-name (nrepl-dict-get result "name"))) - (cider-propertize-region (list 'apropos-symbol var-name - 'action #'cider-xref-doc - 'help-echo "Display doc") - (insert-text-button var-name 'type 'apropos-symbol)) - (insert "\n ") - (insert-text-button "Function" 'type 'apropos-function) - (insert ": ") - (let ((beg (point))) - (insert (nrepl-dict-get result "doc")) - (fill-region beg (point))) - (insert "\n") - (if-let* ((file (nrepl-dict-get result "file")) - (line (nrepl-dict-get result "line"))) - (progn - (insert (propertize var-name - 'font-lock-face 'font-lock-function-name-face) - " is defined in ") - (insert-text-button (cider--abbreviate-file-protocol file) - 'follow-link t - 'action (lambda (_x) - (cider-xref-source file line var-name))) - (insert ".")) - (insert "Definition location unavailable.")) - (insert "\n"))) - -(defun cider-xref-source (file line name) - "Find source for FILE, LINE and NAME." - (interactive) - (if file - (if-let* ((buffer (and (not (cider--tooling-file-p file)) - (cider-find-file file)))) - (cider-jump-to buffer (if line - (cons line nil) - name) - nil) - (user-error - (substitute-command-keys - "Can't find the source because it wasn't defined with `cider-eval-buffer'"))) - (error "No source location for %s" name))) - -(declare-function cider-mode "cider-mode") - -(defun cider-show-xref (summary results) - "Show SUMMARY and RESULTS in a pop-up buffer." - (with-current-buffer (cider-popup-buffer cider-xref-buffer 'select 'apropos-mode 'ancillary) - (let ((inhibit-read-only t)) - (if (boundp 'header-line-format) - (setq-local header-line-format summary) - (insert summary "\n\n")) - (dolist (result results) - (cider-xref-result result)) - (goto-char (point-min))))) - -;;;###autoload -(defun cider-xref-fn-refs (&optional ns symbol) - "Show all functions that reference the var matching NS and SYMBOL." - (interactive) - (cider-ensure-connected) - (cider-ensure-op-supported "fn-refs") - (if-let* ((ns (or ns (cider-current-ns))) - (symbol (or symbol (cider-symbol-at-point))) - (results (cider-sync-request:fn-refs ns symbol))) - (cider-show-xref (format "Showing %d functions that reference %s in currently loaded namespaces" (length results) symbol) results) - (message "No references found for %S in currently loaded namespaces" symbol))) - -;;;###autoload -(defun cider-xref-fn-deps (&optional ns symbol) - "Show all functions referenced by the var matching NS and SYMBOL." - (interactive) - (cider-ensure-connected) - (cider-ensure-op-supported "fn-deps") - (if-let* ((ns (or ns (cider-current-ns))) - (symbol (or symbol (cider-symbol-at-point))) - (results (cider-sync-request:fn-deps ns symbol))) - (cider-show-xref (format "Showing %d function dependencies for %s" (length results) symbol) results) - (message "No dependencies found for %S" symbol))) - -(defun cider-xref-act-on-symbol (symbol) - "Apply selected action on SYMBOL." - (let* ((first-action-key (car (car cider-xref-actions))) - (action-key (if (= 1 (length cider-xref-actions)) - first-action-key - (completing-read (format "Choose action to apply to `%s` (default %s): " - symbol first-action-key) - cider-xref-actions nil nil nil nil first-action-key))) - (action-fn (cdr (assoc action-key cider-xref-actions)))) - (if action-fn - (funcall action-fn symbol) - (user-error "Unknown action `%s`" action-key)))) - -;;;###autoload -(defun cider-xref-fn-refs-select (&optional ns symbol) - "Displays the references for NS and SYMBOL using completing read." - (interactive) - (cider-ensure-connected) - (cider-ensure-op-supported "fn-refs") - (if-let* ((ns (or ns (cider-current-ns))) - (symbol (or symbol (cider-symbol-at-point))) - (results (mapcar (lambda (d) (nrepl-dict-get d "name")) (cider-sync-request:fn-refs ns symbol))) - (summary (format "References for %s" symbol))) - (cider-xref-act-on-symbol (completing-read (concat summary ": ") results)) - (message "No references for %S found" symbol))) - -;;;###autoload -(defun cider-xref-fn-deps-select (&optional ns symbol) - "Displays the function dependencies for NS and SYMBOL using completing read." - (interactive) - (cider-ensure-connected) - (cider-ensure-op-supported "fn-deps") - (if-let* ((ns (or ns (cider-current-ns))) - (symbol (or symbol (cider-symbol-at-point))) - (results (mapcar (lambda (d) (nrepl-dict-get d "name")) (cider-sync-request:fn-deps ns symbol))) - (summary (format "Dependencies for %s" symbol))) - (cider-xref-act-on-symbol (completing-read (concat summary ": ") results)) - (message "No dependencies for %S found" symbol))) - -(provide 'cider-xref) - -;;; cider-xref.el ends here diff --git a/elpa/cider-20230707.640/cider.el b/elpa/cider-20230707.640/cider.el deleted file mode 100644 index 12d0bdba..00000000 --- a/elpa/cider-20230707.640/cider.el +++ /dev/null @@ -1,1958 +0,0 @@ -;;; cider.el --- Clojure Interactive Development Environment that Rocks -*- lexical-binding: t -*- - -;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Tim King -;; Phil Hagelberg -;; Bozhidar Batsov -;; Artur Malabarba -;; Hugo Duncan -;; Steve Purcell -;; Maintainer: Bozhidar Batsov -;; URL: http://www.github.com/clojure-emacs/cider -;; Version: 1.8.0-snapshot -;; Package-Requires: ((emacs "26") (clojure-mode "5.16.0") (parseedn "1.0.6") (queue "0.2") (spinner "1.7") (seq "2.22") (sesman "0.3.2") (transient "0.4.1")) -;; Keywords: languages, clojure, cider - -;; 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 . - -;; This file is not part of GNU Emacs. - -;;; Commentary: - -;; Provides a Clojure interactive development environment for Emacs, built on -;; top of nREPL. See https://docs.cider.mx for more details. - -;;; Installation: - -;; CIDER is available as a package in melpa.org and stable.melpa.org. First, make sure you've -;; enabled one of the repositories in your Emacs config: - -;; (add-to-list 'package-archives -;; '("melpa" . "https://melpa.org/packages/")) -;; -;; or -;; -;; (add-to-list 'package-archives -;; '("melpa-stable" . "https://stable.melpa.org/packages/") t) - -;; Afterwards, installing CIDER is as easy as: - -;; M-x package-install cider - -;;; Usage: - -;; You can start CIDER with one of the following commands: - -;; M-x cider-jack-in-clj -;; M-x cider-jack-in-cljs -;; -;; M-x cider-connect-sibling-clj -;; M-x cider-connect-sibling-cljs -;; -;; M-x cider-connect-clj -;; M-x cider-connect-cljs - -;;; Code: - -(defgroup cider nil - "Clojure Interactive Development Environment that Rocks." - :prefix "cider-" - :group 'applications - :link '(url-link :tag "GitHub" "https://github.com/clojure-emacs/cider") - :link '(url-link :tag "Homepage" "https://cider.mx") - :link '(url-link :tag "Documentation" "https://docs.cider.mx") - :link '(emacs-commentary-link :tag "Commentary" "cider")) - -(require 'cider-client) -(require 'cider-eldoc) -(require 'cider-repl) -(require 'cider-repl-history) -(require 'cider-connection) -(require 'cider-mode) -(require 'cider-common) -(require 'cider-debug) -(require 'cider-util) - -(require 'cl-lib) -(require 'tramp-sh) -(require 'subr-x) -(require 'seq) -(require 'sesman) -(require 'package) - -(defconst cider-version "1.8.0-snapshot" - "The current version of CIDER.") - -(defconst cider-codename "Geneva" - "Codename used to denote stable releases.") - -(defcustom cider-lein-command - "lein" - "The command used to execute Leiningen." - :type 'string) - -(defcustom cider-lein-global-options - nil - "Command global options used to execute Leiningen (e.g.: -o for offline)." - :type 'string - :safe #'stringp) - -(defcustom cider-lein-parameters - "repl :headless :host localhost" - "Params passed to Leiningen to start an nREPL server via `cider-jack-in'." - :type 'string - :safe #'stringp) - -(defcustom cider-boot-command - "boot" - "The command used to execute Boot." - :type 'string - :package-version '(cider . "0.9.0")) - -(defcustom cider-boot-global-options - nil - "Command global options used to execute Boot (e.g.: -c for checkouts)." - :type 'string - :safe #'stringp - :package-version '(cider . "0.14.0")) - -(defcustom cider-boot-parameters - "repl -s -b localhost wait" - "Params passed to boot to start an nREPL server via `cider-jack-in'." - :type 'string - :safe #'stringp - :package-version '(cider . "0.9.0")) - -(defcustom cider-clojure-cli-command - (if (and (eq system-type 'windows-nt) - (null (executable-find "clojure"))) - "powershell" - "clojure") - "The command used to execute clojure with tools.deps (requires Clojure 1.9+). -Don't use clj here, as it doesn't work when spawned from Emacs due to it -using rlwrap. If on Windows and no \"clojure\" executable is found we -default to \"powershell\"." - :type 'string - :safe #'stringp - :package-version '(cider . "0.17.0")) - -(defcustom cider-clojure-cli-global-options - nil - "Command line options used to execute clojure with tools.deps." - :type 'string - :safe #'stringp - :package-version '(cider . "0.17.0")) - -(defcustom cider-clojure-cli-parameters - nil - "Params passed to clojure cli to start an nREPL server via `cider-jack-in'." - :type 'string - :safe #'stringp - :package-version '(cider . "1.8.0")) - -(defcustom cider-clojure-cli-aliases - nil - "A list of aliases to include when using the clojure cli. -Alias names should be of the form \":foo:bar\". -Leading \"-A\" \"-M\" \"-T\" or \"-X\" are stripped from aliases -then concatenated into the \"-M[your-aliases]:cider/nrepl\" form." - :type 'string - :safe #'stringp - :package-version '(cider . "1.1")) - -(defcustom cider-shadow-cljs-command - "npx shadow-cljs" - "The command used to execute shadow-cljs. - -By default we favor the project-specific shadow-cljs over the system-wide." - :type 'string - :safe #'stringp - :package-version '(cider . "0.17.0")) - -(defcustom cider-shadow-cljs-global-options - "" - "Command line options used to execute shadow-cljs (e.g.: -v for verbose mode)." - :type 'string - :safe #'stringp - :package-version '(cider . "0.17.0")) - -(defcustom cider-shadow-cljs-parameters - "server" - "Params passed to shadow-cljs to start an nREPL server via `cider-jack-in'." - :type 'string - :safe #'stringp - :package-version '(cider . "0.17.0")) - -(defcustom cider-gradle-command - "./gradlew" - "The command used to execute Gradle." - :type 'string - :safe #'stringp - :package-version '(cider . "0.10.0")) - -(defcustom cider-gradle-global-options - "" - "Command line options used to execute Gradle (e.g.: -m for dry run)." - :type 'string - :safe #'stringp - :package-version '(cider . "0.14.0")) - -(defcustom cider-gradle-parameters - "clojureRepl" - "Params passed to gradle to start an nREPL server via `cider-jack-in'." - :type 'string - :safe #'stringp - :package-version '(cider . "0.10.0")) - -(defcustom cider-babashka-command - "bb" - "The command used to execute Babashka." - :type 'string - :safe #'stringp - :package-version '(cider . "1.2.0")) - -(defcustom cider-babashka-global-options - nil - "Command line options used to execute Babashka." - :type 'string - :safe #'stringp - :package-version '(cider . "1.2.0")) - -(defcustom cider-babashka-parameters - "nrepl-server localhost:0" - "Params passed to babashka to start an nREPL server via `cider-jack-in'." - :type 'string - :safe #'stringp - :package-version '(cider . "1.2.0")) - -(defcustom cider-nbb-command - "nbb" - "The command used to execute nbb." - :type 'string - :safe #'stringp - :package-version '(cider . "1.6.0")) - -(defcustom cider-nbb-global-options - nil - "Command line options used to execute nbb." - :type 'string - :safe #'stringp - :package-version '(cider . "1.6.0")) - -(defcustom cider-nbb-parameters - "nrepl-server" - "Params passed to nbb to start an nREPL server via `cider-jack-in'." - :type 'string - :safe #'stringp - :package-version '(cider . "1.6.0")) - -(make-obsolete-variable 'cider-lein-global-options 'cider-lein-parameters "1.8.0") -(make-obsolete-variable 'cider-boot-global-options 'cider-boot-parameters "1.8.0") -(make-obsolete-variable 'cider-clojure-cli-global-options 'cider-clojure-cli-parameters "1.8.0") -(make-obsolete-variable 'cider-shadow-cljs-global-options 'cider-shadow-cljs-parameters "1.8.0") -(make-obsolete-variable 'cider-gradle-global-options 'cider-gradle-parameters "1.8.0") -(make-obsolete-variable 'cider-babashka-global-options 'cider-babashka-parameters "1.8.0") -(make-obsolete-variable 'cider-nbb-global-options 'cider-nbb-parameters "1.8.0") - -(defcustom cider-jack-in-default - (if (executable-find "clojure") 'clojure-cli 'lein) - "The default tool to use when doing `cider-jack-in' outside a project. -This value will only be consulted when no identifying file types, i.e. -project.clj for leiningen or build.boot for boot, could be found. - -As the Clojure CLI is bundled with Clojure itself, it's the default. -In the absence of the Clojure CLI (e.g. on Windows), we fallback -to Leiningen." - :type '(choice (const lein) - (const boot) - (const clojure-cli) - (const shadow-cljs) - (const gradle) - (const babashka) - (const nbb)) - :safe #'symbolp - :package-version '(cider . "0.9.0")) - -(defcustom cider-preferred-build-tool - nil - "Allow choosing a build system when there are many. -When there are project markers from multiple build systems (e.g. lein and -boot) the user is prompted to select one of them. When non-nil, this -variable will suppress this behavior and will select whatever build system -is indicated by the variable if present. Note, this is only when CIDER -cannot decide which of many build systems to use and will never override a -command when there is no ambiguity." - :type '(choice (const lein) - (const boot) - (const clojure-cli) - (const shadow-cljs) - (const gradle) - (const babashka) - (const nbb) - (const :tag "Always ask" nil)) - :safe #'symbolp - :package-version '(cider . "0.13.0")) - -(defcustom cider-allow-jack-in-without-project 'warn - "Controls what happens when doing `cider-jack-in' outside a project. -When set to 'warn you'd prompted to confirm the command. -When set to t `cider-jack-in' will quietly continue. -When set to nil `cider-jack-in' will fail." - :type '(choice (const :tag "always" t) - (const warn) - (const :tag "never" nil)) - :safe #'symbolp - :package-version '(cider . "0.15.0")) - -(defcustom cider-known-endpoints nil - "A list of connection endpoints where each endpoint is a list. -For example: \\='((\"label\" \"host\" \"port\")). -The label is optional so that \\='(\"host\" \"port\") will suffice. -This variable is used by `cider-connect'." - :type '(repeat (list (string :tag "label") - (string :tag "host") - (string :tag "port")))) - -(defcustom cider-connected-hook nil - "List of functions to call when connected to Clojure nREPL server." - :type 'hook - :package-version '(cider . "0.9.0")) - -(defcustom cider-disconnected-hook nil - "List of functions to call when disconnected from the Clojure nREPL server." - :type 'hook - :package-version '(cider . "0.9.0")) - -(defcustom cider-inject-dependencies-at-jack-in t - "When nil, do not inject repl dependencies at `cider-jack-in' time. -The repl dependendcies are most likely to be nREPL middlewares." - :type 'boolean - :safe #'booleanp - :version '(cider . "0.11.0")) - -(defcustom cider-offer-to-open-cljs-app-in-browser t - "When nil, do not offer to open ClojureScript apps in a browser on connect." - :type 'boolean - :safe #'booleanp - :version '(cider . "0.15.0")) - -(defvar cider-ps-running-nrepls-command "ps u | grep leiningen" - "Process snapshot command used in `cider-locate-running-nrepl-ports'.") - -(defvar cider-ps-running-nrepl-path-regexp-list - '("\\(?:leiningen.original.pwd=\\)\\(.+?\\) -D" - "\\(?:-classpath +:?\\(.+?\\)/self-installs\\)") - "Regexp list to get project paths. -Extract project paths from output of `cider-ps-running-nrepls-command'. -Sub-match 1 must be the project path.") - -(defvar cider-host-history nil - "Completion history for connection hosts.") - -(defvar cider-jack-in-universal-options - '((clojure-cli (:prefix-arg 1 :cmd (:jack-in-type clj :project-type clojure-cli :edit-project-dir t))) - (lein (:prefix-arg 2 :cmd (:jack-in-type clj :project-type lein :edit-project-dir t))) - (babashka (:prefix-arg 3 :cmd (:jack-in-type clj :project-type babashka :edit-project-dir t))) - (nbb (:prefix-arg 4 :cmd (:jack-in-type cljs :project-type nbb :cljs-repl-type nbb :edit-project-dir t)))) - "The list of project tools that are supported by the universal jack in command. - -Each item in the list consists of the tool name and its plist options. - -The plist supports the following keys - -- :prefix-arg the numerical prefix arg to use to jack in to the tool. - -- :cmd a plist of instructions how to invoke the jack in command, with keys - - - :jack-in-type 'clj to start a clj repl and 'cljs for a cljs repl. - - - &rest the same set of params supported by the `cider-jack-in-clj' and - `cider-jack-in-cljs' commands.") - -;;;###autoload -(defun cider-version () - "Display CIDER's version." - (interactive) - (message "CIDER %s" (cider--version))) - -(defun cider-jack-in-command (project-type) - "Determine the command `cider-jack-in' needs to invoke for the PROJECT-TYPE." - (pcase project-type - ('lein cider-lein-command) - ('boot cider-boot-command) - ('clojure-cli cider-clojure-cli-command) - ('babashka cider-babashka-command) - ('shadow-cljs cider-shadow-cljs-command) - ('gradle cider-gradle-command) - ('nbb cider-nbb-command) - (_ (user-error "Unsupported project type `%S'" project-type)))) - -(defun cider-jack-in-resolve-command (project-type) - "Determine the resolved file path to `cider-jack-in-command'. -Throws an error if PROJECT-TYPE is unknown." - (pcase project-type - ('lein (cider--resolve-command cider-lein-command)) - ('boot (cider--resolve-command cider-boot-command)) - ('clojure-cli (cider--resolve-command cider-clojure-cli-command)) - ('babashka (cider--resolve-command cider-babashka-command)) - ;; here we have to account for the possibility that the command is either - ;; "npx shadow-cljs" or just "shadow-cljs" - ('shadow-cljs (let ((parts (split-string cider-shadow-cljs-command))) - (when-let* ((command (cider--resolve-command (car parts)))) - (mapconcat #'identity (cons command (cdr parts)) " ")))) - ;; TODO: Address the duplicated code below. - ;; here we have to account for the possibility that the command is either - ;; "nbb" (default) or "npx nbb". - ('nbb (let ((parts (split-string cider-nbb-command))) - (when-let* ((command (cider--resolve-command (car parts)))) - (mapconcat #'identity (cons command (cdr parts)) " ")))) - ;; here we have to account for use of the Gradle wrapper which is - ;; a shell script within their project, so if they have a clearly - ;; relative path like "./gradlew" use locate file instead of checking - ;; the exec-path - ('gradle (cider--resolve-project-command cider-gradle-command)) - (_ (user-error "Unsupported project type `%S'" project-type)))) - -(defun cider-jack-in-global-options (project-type) - "Determine the command line options for `cider-jack-in' for the PROJECT-TYPE." - (pcase project-type - ('lein cider-lein-global-options) - ('boot cider-boot-global-options) - ('clojure-cli cider-clojure-cli-global-options) - ('babashka cider-babashka-global-options) - ('shadow-cljs cider-shadow-cljs-global-options) - ('gradle cider-gradle-global-options) - ('nbb cider-nbb-global-options) - (_ (user-error "Unsupported project type `%S'" project-type)))) - -(defun cider-jack-in-params (project-type) - "Determine the commands params for `cider-jack-in' for the PROJECT-TYPE." - ;; The format of these command-line strings must consider different shells, - ;; different values of IFS, and the possibility that they'll be run remotely - ;; (e.g. with TRAMP). Using `", "` causes problems with TRAMP, for example. - ;; Please be careful when changing them. - (pcase project-type - ('lein cider-lein-parameters) - ('boot cider-boot-parameters) - ('clojure-cli cider-clojure-cli-parameters) - ('babashka cider-babashka-parameters) - ('shadow-cljs cider-shadow-cljs-parameters) - ('gradle cider-gradle-parameters) - ('nbb cider-nbb-parameters) - (_ (user-error "Unsupported project type `%S'" project-type)))) - - -;;; Jack-in dependencies injection -(defvar cider-jack-in-dependencies nil - "List of dependencies where elements are lists of artifact name and version.") -(put 'cider-jack-in-dependencies 'risky-local-variable t) - -(defcustom cider-injected-nrepl-version "1.0.0" - "The version of nREPL injected on jack-in. -We inject the newest known version of nREPL just in case -your version of Boot or Leiningen is bundling an older one." - :type 'string - :package-version '(cider . "1.2.0") - :safe #'stringp) - -(defvar cider-jack-in-cljs-dependencies nil - "List of dependencies where elements are lists of artifact name and version. -Added to `cider-jack-in-dependencies' when doing `cider-jack-in-cljs'.") -(put 'cider-jack-in-cljs-dependencies 'risky-local-variable t) -(cider-add-to-alist 'cider-jack-in-cljs-dependencies "cider/piggieback" "0.5.2") - -(defvar cider-jack-in-dependencies-exclusions nil - "List of exclusions for jack in dependencies. -Elements of the list are artifact name and list of exclusions to apply for -the artifact.") -(put 'cider-jack-in-dependencies-exclusions 'risky-local-variable t) - -(defconst cider-clojure-artifact-id "org.clojure/clojure" - "Artifact identifier for Clojure.") - -(defconst cider-minimum-clojure-version "1.8.0" - "Minimum supported version of Clojure.") - -(defconst cider-latest-clojure-version "1.10.1" - "Latest supported version of Clojure.") - -(defconst cider-required-middleware-version "0.32.0-alpha1" - "The CIDER nREPL version that's known to work properly with CIDER.") - -(defcustom cider-injected-middleware-version cider-required-middleware-version - "The version of cider-nrepl injected on jack-in. -Should be newer than the required version for optimal results." - :type 'string - :package-version '(cider . "1.2.0") - :safe #'stringp) - -(defcustom cider-enrich-classpath nil - "Whether to use git.io/JiJVX for adding sources and javadocs to the classpath. - -This is done in a clean manner, without interfering with classloaders. - -Only available for Leiningen projects at the moment." - :type 'boolean - :package-version '(cider . "1.2.0") - :safe #'booleanp) - -(defcustom cider-jack-in-auto-inject-clojure nil - "Version of clojure to auto-inject into REPL. -If nil, do not inject Clojure into the REPL. If `latest', inject -`cider-latest-clojure-version', which should approximate to the most recent -version of Clojure. If `minimal', inject `cider-minimum-clojure-version', -which will be the lowest version CIDER supports. If a string, use this as -the version number. If it is a list, the first element should be a string, -specifying the artifact ID, and the second element the version number." - :type '(choice (const :tag "None" nil) - (const :tag "Latest" latest) - (const :tag "Minimal" minimal) - (string :tag "Specific Version") - (list :tag "Artifact ID and Version" - (string :tag "Artifact ID") - (string :tag "Version")))) - -(defvar-local cider-jack-in-cmd nil - "The custom command used to start a nrepl server. -This is used by `cider-jack-in`. - -If this variable is set, its value will be -used as the command to start the nrepl server -instead of the default command inferred from -the project type. - -This allows for fine-grained control over the jack-in process. -The value should be a string representing the command to start -the nrepl server, such as \"nbb nrepl-server\".") - -(defvar cider-jack-in-lein-plugins nil - "List of Leiningen plugins to be injected at jack-in. -Each element is a list of artifact name and version, followed optionally by -keyword arguments. The only keyword argument currently accepted is -`:predicate', which should be given a function that takes the list (name, -version, and keyword arguments) and returns non-nil to indicate that the -plugin should actually be injected. (This is useful primarily for packages -that extend CIDER, not for users. For example, a refactoring package might -want to inject some middleware only when within a project context.)") -(put 'cider-jack-in-lein-plugins 'risky-local-variable t) - -(defvar cider-jack-in-lein-middlewares nil - "List of Leiningen :middleware values to be injected at jack-in. - -Necessary for plugins which require an explicit middleware name to be specified. - -Can also facilitate using middleware in a specific order.") -(put 'cider-jack-in-lein-middlewares 'risky-local-variable t) - -(defvar cider-jack-in-cljs-lein-plugins nil - "List of Leiningen plugins to be injected at jack-in. -Added to `cider-jack-in-lein-plugins' (which see) when doing -`cider-jack-in-cljs'.") -(put 'cider-jack-in-cljs-lein-plugins 'risky-local-variable t) - -(defun cider-jack-in-normalized-lein-plugins () - "Return a normalized list of Leiningen plugins to be injected. -See `cider-jack-in-lein-plugins' for the format, except that the list -returned by this function does not include keyword arguments." - (let ((plugins (if cider-enrich-classpath - (append cider-jack-in-lein-plugins - `(("cider/cider-nrepl" ,cider-injected-middleware-version) - ("mx.cider/enrich-classpath" "1.9.0"))) - (append cider-jack-in-lein-plugins - `(("cider/cider-nrepl" ,cider-injected-middleware-version)))))) - (thread-last - plugins - (seq-filter - (lambda (spec) - (if-let* ((pred (plist-get (seq-drop spec 2) :predicate))) - (funcall pred spec) - t))) - (mapcar - (lambda (spec) - (seq-take spec 2)))))) - -(defvar cider-jack-in-nrepl-middlewares nil - "List of Clojure variable names. -Each of these Clojure variables should hold a vector of nREPL middlewares. -Instead of a string, an element can be a list containing a string followed -by optional keyword arguments. The only keyword argument currently -accepted is `:predicate', which should be given a function that takes the -list (string and keyword arguments) and returns non-nil to indicate that -the middlewares should actually be injected.") -(put 'cider-jack-in-nrepl-middlewares 'risky-local-variable t) -(add-to-list 'cider-jack-in-nrepl-middlewares "cider.nrepl/cider-middleware") - -(defvar cider-jack-in-cljs-nrepl-middlewares nil - "List of Clojure variable names. -Added to `cider-jack-in-nrepl-middlewares' (which see) when doing -`cider-jack-in-cljs'.") -(put 'cider-jack-in-cljs-nrepl-middlewares 'risky-local-variable t) -(add-to-list 'cider-jack-in-cljs-nrepl-middlewares "cider.piggieback/wrap-cljs-repl") - -(defun cider-jack-in-normalized-nrepl-middlewares () - "Return a normalized list of middleware variable names. -See `cider-jack-in-nrepl-middlewares' for the format, except that the list -returned by this function only contains strings." - (thread-last - cider-jack-in-nrepl-middlewares - (seq-filter - (lambda (spec) - (or (not (listp spec)) - (if-let* ((pred (plist-get (cdr spec) :predicate))) - (funcall pred spec) - t)))) - (mapcar - (lambda (spec) - (if (listp spec) - (car spec) - spec))))) - -(defun cider--list-as-boot-artifact (list) - "Return a boot artifact string described by the elements of LIST. -LIST should have the form (ARTIFACT-NAME ARTIFACT-VERSION). The returned -string is quoted for passing as argument to an inferior shell." - (concat "-d " (shell-quote-argument (format "%s:%s" (car list) (cadr list))))) - -(defun cider--jack-in-required-dependencies () - "Returns the required CIDER deps. -They are normally added to `cider-jack-in-dependencies', -unless it's a Lein project." - `(("nrepl/nrepl" ,cider-injected-nrepl-version) - ("cider/cider-nrepl" ,cider-injected-middleware-version))) - -(defun cider-boot-dependencies (dependencies) - "Return a list of boot artifact strings created from DEPENDENCIES." - (concat (mapconcat #'cider--list-as-boot-artifact dependencies " ") - (unless (seq-empty-p dependencies) " "))) - -(defun cider-boot-middleware-task (params middlewares) - "Create a command to add MIDDLEWARES with corresponding PARAMS." - (concat "cider.tasks/add-middleware " - (mapconcat (lambda (middleware) - (format "-m %s" (shell-quote-argument middleware))) - middlewares - " ") - " " params)) - -(defun cider-boot-jack-in-dependencies (global-opts params dependencies middlewares) - "Create boot jack-in dependencies. -Does so by concatenating GLOBAL-OPTS, DEPENDENCIES, -and MIDDLEWARES. PARAMS and MIDDLEWARES are passed on to -`cider-boot-middleware-task` before concatenating and DEPENDENCIES - are passed on to `cider-boot-dependencies`." - (concat global-opts - (unless (seq-empty-p global-opts) " ") - "-i \"(require 'cider.tasks)\" " ;; Note the space at the end here - (cider-boot-dependencies (append (cider--jack-in-required-dependencies) dependencies)) - (cider-boot-middleware-task params middlewares))) - -(defun cider--gradle-dependency-notation (dependency) - "Returns Gradle's GAV dependency syntax. -For a \"group/artifact\" \"version\") DEPENDENCY list -return as group:artifact:version notation." - (let ((group-artifact (replace-regexp-in-string "/" ":" (car dependency))) - (version (cadr dependency))) - (format "%s:%s" group-artifact version))) - -(defun cider--gradle-jack-in-property (dependencies) - "Returns Clojurephant's dependency jack-in property. -For DEPENDENCIES, translates to Gradle's dependency notation -using `cider--gradle-dependency-notation`.''" - (if (seq-empty-p dependencies) - "" - (shell-quote-argument - (concat "-Pdev.clojurephant.jack-in.nrepl=" - (mapconcat #'cider--gradle-dependency-notation dependencies ","))))) - -(defun cider--gradle-middleware-params (middlewares) - "Returns Gradle-formatted middleware params. -Given a list of MIDDLEWARES symbols, this returns -the Gradle parameters expected by Clojurephant's -ClojureNRepl task." - (mapconcat (lambda (middleware) - (shell-quote-argument (concat "--middleware=" middleware))) - middlewares - " ")) - -(defun cider-gradle-jack-in-dependencies (global-opts params dependencies middlewares) - "Create gradle jack in dependencies. -Does so by concatenating GLOBAL-OPTS, DEPENDENCIES, -and MIDDLEWARES. GLOBAL-OPTS and PARAMS are taken as-is. -DEPENDENCIES are translated into Gradle's typical -group:artifact:version notation and MIDDLEWARES are -prepared as arguments to Clojurephant's ClojureNRepl task." - (concat global-opts - (unless (seq-empty-p global-opts) " ") - (cider--gradle-jack-in-property (append (cider--jack-in-required-dependencies) dependencies)) - " " - params - (unless (seq-empty-p params) " ") - (cider--gradle-middleware-params middlewares))) - -(defun cider--lein-artifact-exclusions (exclusions) - "Return an exclusions vector described by the elements of EXCLUSIONS." - (if exclusions - (format " :exclusions [%s]" (mapconcat #'identity exclusions " ")) - "")) - -(defun cider--list-as-lein-artifact (list &optional exclusions) - "Return an artifact string described by the elements of LIST. -LIST should have the form (ARTIFACT-NAME ARTIFACT-VERSION). Optionally a list -of EXCLUSIONS can be provided as well. The returned -string is quoted for passing as argument to an inferior shell." - (shell-quote-argument (format "[%s %S%s]" (car list) (cadr list) (cider--lein-artifact-exclusions exclusions)))) - -(defun cider-lein-jack-in-dependencies (global-opts params dependencies dependencies-exclusions lein-plugins &optional lein-middlewares) - "Create lein jack-in dependencies. -Does so by concatenating GLOBAL-OPTS, DEPENDENCIES, with DEPENDENCIES-EXCLUSIONS -removed, LEIN-PLUGINS, LEIN-MIDDLEWARES and finally PARAMS." - (concat - global-opts - (unless (seq-empty-p global-opts) " ") - (mapconcat #'identity - (append (seq-map (lambda (dep) - (let ((exclusions (cadr (assoc (car dep) dependencies-exclusions)))) - (concat "update-in :dependencies conj " - (cider--list-as-lein-artifact dep exclusions)))) - dependencies) - (seq-map (lambda (plugin) - (concat "update-in :plugins conj " - (cider--list-as-lein-artifact plugin))) - lein-plugins) - (seq-map (lambda (middleware) - (concat "update-in :middleware conj " - middleware)) - lein-middlewares)) - " -- ") - " -- " - params)) - -(defun cider--dedupe-deps (deps) - "Removes the duplicates in DEPS." - (cl-delete-duplicates deps :test 'equal)) - -(defun cider--jack-in-cmd-powershell-p (command) - "Returns whether COMMAND is PowerShell." - (or (string-equal command "powershell") - (string-equal command "pwsh"))) - -(defun cider--shell-quote-argument (argument &optional command) - "Quotes ARGUMENT like `shell-quote-argument', suitable for use with COMMAND. - -Uses `shell-quote-argument' to quote the ARGUMENT, unless COMMAND is given -and refers to PowerShell, in which case it uses (some limited) PowerShell -rules to quote it." - (if (cider--jack-in-cmd-powershell-p command) - ;; please add more PowerShell quoting rules as necessary. - (format "'%s'" (replace-regexp-in-string "\"" "\"\"" argument)) - (shell-quote-argument argument))) - -(defun cider--powershell-encode-command (cmd-params) - "Base64 encode the powershell command and jack-in CMD-PARAMS for clojure-cli." - (let* ((quoted-params cmd-params) - (command (format "clojure %s" quoted-params)) - (utf-16le-command (encode-coding-string command 'utf-16le))) - (format "-encodedCommand %s" (base64-encode-string utf-16le-command t)))) - -(defun cider-clojure-cli-jack-in-dependencies (global-options params dependencies &optional command) - "Create Clojure tools.deps jack-in dependencies. -Does so by concatenating DEPENDENCIES, PARAMS and GLOBAL-OPTIONS into a -suitable `clojure` invocation and quoting, also accounting for COMMAND if -provided. The main is placed in an inline alias :cider/nrepl so that if -your aliases contain any mains, the cider/nrepl one will be the one used." - (let* ((all-deps (thread-last - dependencies - (append (cider--jack-in-required-dependencies)) - ;; Duplicates are never OK since they would result in - ;; `java.lang.IllegalArgumentException: Duplicate key [...]`: - (cider--dedupe-deps) - (seq-map (lambda (dep) - (if (listp (cadr dep)) - (format "%s {%s}" - (car dep) - (seq-reduce - (lambda (acc v) - (concat acc (format " :%s \"%s\" " (car v) (cdr v)))) - (cadr dep) - "")) - (format "%s {:mvn/version \"%s\"}" (car dep) (cadr dep))))))) - (middleware (mapconcat - (apply-partially #'format "%s") - (cider-jack-in-normalized-nrepl-middlewares) - ",")) - (main-opts (format "\"-m\" \"nrepl.cmdline\" \"--middleware\" \"[%s]\"" middleware)) - (deps (format "{:deps {%s} :aliases {:cider/nrepl {:main-opts [%s]}}}" - (string-join all-deps " ") main-opts)) - (deps-quoted (cider--shell-quote-argument deps command))) - (format "%s-Sdeps %s -M%s:cider/nrepl%s" - ;; TODO: global-options are deprecated and should be removed in CIDER 2.0 - (if global-options (format "%s " global-options) "") - deps-quoted - (if cider-clojure-cli-aliases - ;; remove exec-opts flags -A -M -T or -X from cider-clojure-cli-aliases - ;; concatenated with :cider/nrepl to ensure :cider/nrepl comes last - (format "%s" (replace-regexp-in-string "^-\\(A\\|M\\|T\\|X\\)" "" cider-clojure-cli-aliases)) - "") - (if params (format " %s" params) "")))) - -(defun cider-shadow-cljs-jack-in-dependencies (global-opts params dependencies) - "Create shadow-cljs jack-in deps. -Does so by concatenating GLOBAL-OPTS, DEPENDENCIES finally PARAMS." - (let ((dependencies (append (cider--jack-in-required-dependencies) dependencies))) - (concat - global-opts - (unless (seq-empty-p global-opts) " ") - (mapconcat #'identity - (seq-map (lambda (dep) (format "-d %s:%s" (car dep) (cadr dep))) dependencies) - " ") - " " - params))) - -(defun cider-add-clojure-dependencies-maybe (dependencies) - "Return DEPENDENCIES with an added Clojure dependency if requested. -See also `cider-jack-in-auto-inject-clojure'." - (if cider-jack-in-auto-inject-clojure - (if (consp cider-jack-in-auto-inject-clojure) - (cons cider-jack-in-auto-inject-clojure dependencies) - (cons (list cider-clojure-artifact-id - (cond - ((stringp cider-jack-in-auto-inject-clojure) - cider-jack-in-auto-inject-clojure) - ((eq cider-jack-in-auto-inject-clojure 'minimal) - cider-minimum-clojure-version) - ((eq cider-jack-in-auto-inject-clojure 'latest) - cider-latest-clojure-version))) - dependencies)) - dependencies)) - -(defun cider-inject-jack-in-dependencies (global-opts params project-type &optional command) - "Return GLOBAL-OPTS and PARAMS with injected REPL dependencies. -These are set in `cider-jack-in-dependencies', `cider-jack-in-lein-plugins' -and `cider-jack-in-nrepl-middlewares' are injected from the CLI according -to the used PROJECT-TYPE, and COMMAND if provided. Eliminates the need for -hacking profiles.clj or the boot script for supporting CIDER with its nREPL -middleware and dependencies." - (pcase project-type - ('lein (cider-lein-jack-in-dependencies - global-opts - params - (cider-add-clojure-dependencies-maybe - (append `(("nrepl/nrepl" ,cider-injected-nrepl-version)) cider-jack-in-dependencies)) - cider-jack-in-dependencies-exclusions - (cider-jack-in-normalized-lein-plugins) - (if cider-enrich-classpath - (append cider-jack-in-lein-middlewares - '("cider.enrich-classpath/middleware")) - cider-jack-in-lein-middlewares))) - ('boot (cider-boot-jack-in-dependencies - global-opts - params - (cider-add-clojure-dependencies-maybe - cider-jack-in-dependencies) - (cider-jack-in-normalized-nrepl-middlewares))) - ('clojure-cli (cider-clojure-cli-jack-in-dependencies - global-opts - params - (cider-add-clojure-dependencies-maybe - cider-jack-in-dependencies) - command)) - ('babashka (concat - global-opts - (unless (seq-empty-p global-opts) " ") - params)) - ('shadow-cljs (cider-shadow-cljs-jack-in-dependencies - global-opts - params - (cider-add-clojure-dependencies-maybe - cider-jack-in-dependencies))) - ('gradle (cider-gradle-jack-in-dependencies - global-opts - params - (cider-add-clojure-dependencies-maybe - cider-jack-in-dependencies) - (cider-jack-in-normalized-nrepl-middlewares))) - ('nbb (concat - global-opts - (unless (seq-empty-p global-opts) " ") - params)) - (_ (error "Unsupported project type `%S'" project-type)))) - - -;;; ClojureScript REPL creation - -(defcustom cider-check-cljs-repl-requirements t - "When non-nil will run the requirement checks for the different cljs repls. -Generally you should not disable this unless you run into some faulty check." - :type 'boolean - :safe #'booleanp - :package-version '(cider . "0.17.0")) - -(defun cider-clojurescript-present-p () - "Return non nil when ClojureScript is present." - (or - ;; This is nil for example for nbb. - (cider-library-present-p "cljs.core") - ;; demunge is not defined currently for normal cljs repls. - ;; So we end up making the two checks - (nrepl-dict-get (cider-sync-tooling-eval "cljs.core/demunge") "value"))) - -(defun cider-verify-clojurescript-is-present () - "Check whether ClojureScript is present." - (unless (cider-clojurescript-present-p) - (user-error "ClojureScript is not available. See https://docs.cider.mx/cider/basics/clojurescript for details"))) - -(defun cider-verify-piggieback-is-present () - "Check whether the piggieback middleware is present." - (unless (cider-library-present-p "cider.piggieback") - (user-error "Piggieback 0.4.x (aka cider/piggieback) is not available. See https://docs.cider.mx/cider/basics/clojurescript for details"))) - -(defun cider-check-node-requirements () - "Check whether we can start a Node ClojureScript REPL." - (cider-verify-piggieback-is-present) - (unless (executable-find "node") - (user-error "Node.js is not present on the exec-path. Make sure you've installed it and your exec-path is properly set"))) - -(defun cider-check-figwheel-requirements () - "Check whether we can start a Figwheel ClojureScript REPL." - (cider-verify-piggieback-is-present) - (unless (cider-library-present-p "figwheel-sidecar.repl") - (user-error "Figwheel-sidecar is not available. Please check https://docs.cider.mx/cider/basics/clojurescript for details"))) - -(defun cider-check-figwheel-main-requirements () - "Check whether we can start a Figwheel ClojureScript REPL." - (cider-verify-piggieback-is-present) - (unless (cider-library-present-p "figwheel.main") - (user-error "Figwheel-main is not available. Please check https://docs.cider.mx/cider/basics/clojurescript for details"))) - -(defun cider-check-weasel-requirements () - "Check whether we can start a Weasel ClojureScript REPL." - (cider-verify-piggieback-is-present) - (unless (cider-library-present-p "weasel.repl.server") - (user-error "Weasel in not available. Please check https://docs.cider.mx/cider/basics/clojurescript/#browser-connected-clojurescript-repl for details"))) - -(defun cider-check-boot-requirements () - "Check whether we can start a Boot ClojureScript REPL." - (cider-verify-piggieback-is-present) - (unless (cider-library-present-p "adzerk.boot-cljs-repl") - (user-error "The Boot ClojureScript REPL is not available. Please check https://github.com/adzerk-oss/boot-cljs-repl/blob/master/README.md for details"))) - -(defun cider-check-krell-requirements () - "Check whether we can start a Krell ClojureScript REPL." - (cider-verify-piggieback-is-present) - (unless (cider-library-present-p "krell.repl") - (user-error "The Krell ClojureScript REPL is not available. Please check https://github.com/vouch-opensource/krell for details"))) - -(defun cider-check-shadow-cljs-requirements () - "Check whether we can start a shadow-cljs REPL." - (unless (cider-library-present-p "shadow.cljs.devtools.api") - (user-error "The shadow-cljs ClojureScript REPL is not available. Please check https://docs.cider.mx/cider/basics/clojurescript for details"))) - -(defun cider-normalize-cljs-init-options (options) - "Normalize the OPTIONS string used for initializing a ClojureScript REPL." - (if (or (string-prefix-p "{" options) - (string-prefix-p "(" options) - (string-prefix-p "[" options) - (string-prefix-p ":" options) - (string-prefix-p "\"" options)) - options - (concat ":" options))) - -(defcustom cider-shadow-watched-builds nil - "Defines the list of builds `shadow-cljs' should watch." - :type '(repeat string) - :safe #'listp - :package-version '(cider . "1.0")) - -(defcustom cider-shadow-default-options nil - "Defines default `shadow-cljs' options." - :type 'string - :safe (lambda (s) (or (null s) (stringp s))) - :package-version '(cider . "0.18.0")) - -(defun cider--shadow-parse-builds (hash) - "Parses the build names of a shadow-cljs.edn HASH map. -The default options of `browser-repl' and `node-repl' are also included." - (let* ((builds (when (hash-table-p hash) - (gethash :builds hash))) - (build-keys (when (hash-table-p builds) - (hash-table-keys builds)))) - (append build-keys '(browser-repl node-repl)))) - -(defun cider--shadow-get-builds () - "Extract build names from the shadow-cljs.edn config file in the project root." - (let ((shadow-edn (concat (clojure-project-dir) "shadow-cljs.edn"))) - (when (file-exists-p shadow-edn) - (with-temp-buffer - (insert-file-contents shadow-edn) - (let ((hash (car (parseedn-read '((shadow/env . identity)))))) - (cider--shadow-parse-builds hash)))))) - -(defun cider-shadow-select-cljs-init-form () - "Generate the init form for a shadow-cljs select-only REPL. -We have to prompt the user to select a build, that's why this is a command, -not just a string." - (let ((form "(do (require '[shadow.cljs.devtools.api :as shadow]) (shadow/nrepl-select %s))") - (options (or cider-shadow-default-options - (completing-read "Select shadow-cljs build: " - (cider--shadow-get-builds))))) - (format form (cider-normalize-cljs-init-options options)))) - -(defun cider-shadow-cljs-init-form () - "Generate the init form for a shadow-cljs REPL. -We have to prompt the user to select a build, that's why -this is a command, not just a string." - (let* ((shadow-require "(require '[shadow.cljs.devtools.api :as shadow])") - - (default-build (cider-normalize-cljs-init-options - (or cider-shadow-default-options - (car cider-shadow-watched-builds) - (completing-read "Select shadow-cljs build: " - (cider--shadow-get-builds))))) - - (watched-builds (or (mapcar #'cider-normalize-cljs-init-options cider-shadow-watched-builds) - (list default-build))) - - (watched-builds-form (mapconcat (lambda (build) (format "(shadow/watch %s)" build)) - watched-builds - " ")) - ;; form used for user-defined builds - (user-build-form "(do %s %s (shadow/nrepl-select %s))") - ;; form used for built-in builds like :browser-repl and :node-repl - (default-build-form "(do %s (shadow/%s))")) - (if (member default-build '(":browser-repl" ":node-repl")) - (format default-build-form shadow-require (string-remove-prefix ":" default-build)) - (format user-build-form shadow-require watched-builds-form default-build)))) - -(defcustom cider-figwheel-main-default-options nil - "Defines the `figwheel.main/start' options. - -Note that figwheel-main/start can also accept a map of options, refer to -Figwheel for details." - :type 'string - :safe (lambda (s) (or (null s) (stringp s))) - :package-version '(cider . "0.18.0")) - -(defun cider--figwheel-main-get-builds () - "Extract build names from the .cljs.edn config files. -Fetches them in the project root." - (when-let ((project-dir (clojure-project-dir))) - (let ((builds (directory-files project-dir nil ".*\\.cljs\\.edn"))) - (mapcar (lambda (f) (string-match "^\\(.*\\)\\.cljs\\.edn" f) - (match-string 1 f)) - builds)))) - -(defun cider-figwheel-main-init-form () - "Produce the figwheel-main ClojureScript init form." - (let ((form "(do (require 'figwheel.main) (figwheel.main/start %s))") - (builds (cider--figwheel-main-get-builds))) - (cond - (cider-figwheel-main-default-options - (format form (cider-normalize-cljs-init-options (string-trim cider-figwheel-main-default-options)))) - - (builds - (format form (cider-normalize-cljs-init-options (completing-read "Select figwheel-main build: " builds)))) - - (t (user-error "No figwheel-main build files (.cljs.edn) were found"))))) - -(defcustom cider-custom-cljs-repl-init-form nil - "The form used to start a custom ClojureScript REPL. -When set it becomes the return value of the `cider-custom-cljs-repl-init-form' -function, which normally prompts for the init form. - -This defcustom is mostly intended for use with .dir-locals.el for -cases where it doesn't make sense to register a new ClojureScript REPL type." - :type 'string - :safe (lambda (s) (or (null s) (stringp s))) - :package-version '(cider . "0.23.0")) - -(defun cider-custom-cljs-repl-init-form () - "The form used to start a custom ClojureScript REPL. -Defaults to the value of `cider-custom-cljs-repl-init-form'. -If it's nil the function will prompt for a form. -The supplied string will be wrapped in a do form if needed." - (or - cider-custom-cljs-repl-init-form - (let ((form (read-from-minibuffer "Please, provide a form to start a ClojureScript REPL: "))) - ;; TODO: We should probably make this more robust (e.g. by using a regexp or - ;; parsing the form). - (if (string-prefix-p "(do" form) - form - (format "(do %s)" form))))) - -(defvar cider-cljs-repl-types - '((figwheel "(do (require 'figwheel-sidecar.repl-api) (figwheel-sidecar.repl-api/start-figwheel!) (figwheel-sidecar.repl-api/cljs-repl))" - cider-check-figwheel-requirements) - (figwheel-main cider-figwheel-main-init-form cider-check-figwheel-main-requirements) - (figwheel-connected "(figwheel-sidecar.repl-api/cljs-repl)" - cider-check-figwheel-requirements) - (browser "(do (require 'cljs.repl.browser) (cider.piggieback/cljs-repl (cljs.repl.browser/repl-env)))") - (node "(do (require 'cljs.repl.node) (cider.piggieback/cljs-repl (cljs.repl.node/repl-env)))" - cider-check-node-requirements) - (weasel "(do (require 'weasel.repl.websocket) (cider.piggieback/cljs-repl (weasel.repl.websocket/repl-env :ip \"127.0.0.1\" :port 9001)))" - cider-check-weasel-requirements) - (boot "(do (require 'adzerk.boot-cljs-repl) (adzerk.boot-cljs-repl/start-repl))" - cider-check-boot-requirements) - (shadow cider-shadow-cljs-init-form cider-check-shadow-cljs-requirements) - (shadow-select cider-shadow-select-cljs-init-form cider-check-shadow-cljs-requirements) - (krell "(require '[clojure.edn :as edn] - '[clojure.java.io :as io] - '[cider.piggieback] - '[krell.api :as krell] - '[krell.repl]) -(def config (edn/read-string (slurp (io/file \"build.edn\")))) -(apply cider.piggieback/cljs-repl (krell.repl/repl-env) (mapcat identity config))" - cider-check-krell-requirements) - ;; native cljs repl, no form required. - (nbb) - (custom cider-custom-cljs-repl-init-form nil)) - "A list of supported ClojureScript REPLs. - -For each one we have its name, and then, if the repl is not a native -ClojureScript REPL, the form we need to evaluate in a Clojure REPL to -switch to the ClojureScript REPL and functions to verify their -requirements. - -The form, if any, should be either a string or a function producing a -string.") - -(defun cider-register-cljs-repl-type (type &optional init-form requirements-fn) - "Register a new ClojureScript REPL type. - -Types are defined by the following: - -- TYPE - symbol identifier that will be used to refer to the REPL type -- INIT-FORM - (optional) string or function (symbol) producing string -- REQUIREMENTS-FN - function to check whether the REPL can be started. -This param is optional. - -All this function does is modifying `cider-cljs-repl-types'. -It's intended to be used in your Emacs config." - (unless (symbolp type) - (user-error "The REPL type must be a symbol")) - (unless (or (null init-form) (stringp init-form) (symbolp init-form)) - (user-error "The init form must be a string or a symbol referring to a function or nil")) - (unless (or (null requirements-fn) (symbolp requirements-fn)) - (user-error "The requirements-fn must be a symbol referring to a function")) - (add-to-list 'cider-cljs-repl-types (list type init-form requirements-fn))) - -(defcustom cider-default-cljs-repl nil - "The default ClojureScript REPL to start. -This affects commands like `cider-jack-in-cljs'. Generally it's -intended to be set via .dir-locals.el for individual projects, as its -relatively unlikely you'd like to use the same type of REPL in each project -you're working on." - :type '(choice (const :tag "Figwheel" figwheel) - (const :tag "Figwheel Main" figwheel-main) - (const :tag "Browser" browser) - (const :tag "Node" node) - (const :tag "Weasel" weasel) - (const :tag "Boot" boot) - (const :tag "Shadow" shadow) - (const :tag "Shadow w/o Server" shadow-select) - (const :tag "Krell" krell) - (const :tag "Nbb" nbb) - (const :tag "Custom" custom)) - :safe #'symbolp - :package-version '(cider . "0.17.0")) - -(make-obsolete-variable 'cider-cljs-lein-repl 'cider-default-cljs-repl "0.17") -(make-obsolete-variable 'cider-cljs-boot-repl 'cider-default-cljs-repl "0.17") -(make-obsolete-variable 'cider-cljs-gradle-repl 'cider-default-cljs-repl "0.17") - -(defvar cider--select-cljs-repl-history nil) -(defun cider-select-cljs-repl (&optional default) - "Select the ClojureScript REPL to use with `cider-jack-in-cljs'. -DEFAULT is the default ClojureScript REPL to offer in completion." - (let ((repl-types (mapcar #'car cider-cljs-repl-types))) - (intern (completing-read "Select ClojureScript REPL type: " repl-types - nil nil nil 'cider--select-cljs-repl-history - (or default (car cider--select-cljs-repl-history)))))) - -(defun cider-cljs-repl-form (repl-type) - "Get the cljs REPL form for REPL-TYPE, if any." - (if-let* ((repl-type-info (seq-find - (lambda (entry) - (eq (car entry) repl-type)) - cider-cljs-repl-types))) - (when-let ((repl-form (cadr repl-type-info))) - ;; repl-form can be either a string or a function producing a string - (if (symbolp repl-form) - (funcall repl-form) - repl-form)) - (user-error "No ClojureScript REPL type %s found. Please make sure that `cider-cljs-repl-types' has an entry for it" repl-type))) - -(defun cider-verify-cljs-repl-requirements (&optional repl-type) - "Verify that the requirements for REPL-TYPE are met. -Return REPL-TYPE if requirements are met." - (let ((repl-type (or repl-type - cider-default-cljs-repl - (cider-select-cljs-repl)))) - (when cider-check-cljs-repl-requirements - (when-let* ((fun (nth 2 (seq-find - (lambda (entry) - (eq (car entry) repl-type)) - cider-cljs-repl-types)))) - (funcall fun))) - repl-type)) - -(defun cider--check-cljs (&optional cljs-type no-error) - "Verify that all cljs requirements are met for CLJS-TYPE connection. -Return REPL-TYPE of requirement are met, and throw an ‘user-error’ otherwise. -When NO-ERROR is non-nil, don't throw an error, issue a message and return -nil." - (if no-error - (condition-case ex - (progn - (cider-verify-clojurescript-is-present) - (cider-verify-cljs-repl-requirements cljs-type)) - (error - (message "Invalid ClojureScript dependency: %S" ex) - nil)) - (cider-verify-clojurescript-is-present) - (cider-verify-cljs-repl-requirements cljs-type))) - -(defun cider--offer-to-open-app-in-browser (server-buffer) - "Look for a server address in SERVER-BUFFER and offer to open it." - (when (buffer-live-p server-buffer) - (with-current-buffer server-buffer - (save-excursion - (goto-char (point-min)) - (when-let* ((url (and (search-forward-regexp "http://localhost:[0-9]+" nil 'noerror) - (match-string 0)))) - (when (y-or-n-p (format "Visit ‘%s’ in a browser? " url)) - (browse-url url))))))) - - -;;; User Level Connectors - -;;;###autoload (autoload 'cider-start-map "cider" "CIDER jack-in and connect keymap." t 'keymap) -(defvar cider-start-map - (let ((map (define-prefix-command 'cider-start-map))) - (define-key map (kbd "x") #'cider) - (define-key map (kbd "C-x") #'cider) - (define-key map (kbd "j j") #'cider-jack-in-clj) - (define-key map (kbd "j s") #'cider-jack-in-cljs) - (define-key map (kbd "j m") #'cider-jack-in-clj&cljs) - (define-key map (kbd "j u") #'cider-jack-in-universal) - (define-key map (kbd "C-j j") #'cider-jack-in-clj) - (define-key map (kbd "C-j s") #'cider-jack-in-cljs) - (define-key map (kbd "C-j m") #'cider-jack-in-clj&cljs) - (define-key map (kbd "C-j C-j") #'cider-jack-in-clj) - (define-key map (kbd "C-j C-s") #'cider-jack-in-cljs) - (define-key map (kbd "C-j C-m") #'cider-jack-in-clj&cljs) - (define-key map (kbd "c j") #'cider-connect-clj) - (define-key map (kbd "c s") #'cider-connect-cljs) - (define-key map (kbd "c m") #'cider-connect-clj&cljs) - (define-key map (kbd "C-c j") #'cider-connect-clj) - (define-key map (kbd "C-c s") #'cider-connect-cljs) - (define-key map (kbd "C-c m") #'cider-connect-clj&cljs) - (define-key map (kbd "C-c C-j") #'cider-connect-clj) - (define-key map (kbd "C-c C-s") #'cider-connect-cljs) - (define-key map (kbd "C-c C-m") #'cider-connect-clj&cljs) - (define-key map (kbd "s j") #'cider-connect-sibling-clj) - (define-key map (kbd "s s") #'cider-connect-sibling-cljs) - (define-key map (kbd "C-s j") #'cider-connect-sibling-clj) - (define-key map (kbd "C-s s") #'cider-connect-sibling-cljs) - (define-key map (kbd "C-s C-j") #'cider-connect-sibling-clj) - (define-key map (kbd "C-s C-s") #'cider-connect-sibling-cljs) - map) - "CIDER jack-in and connect keymap.") - -;;;###autoload -(defun cider-jack-in-clj (params) - "Start an nREPL server for the current project and connect to it. -PARAMS is a plist optionally containing :project-dir and :jack-in-cmd. -With the prefix argument, allow editing of the jack in command; with a -double prefix prompt for all these parameters." - (interactive "P") - (let ((params (thread-first - params - (cider--update-project-dir) - (cider--check-existing-session) - (cider--update-jack-in-cmd)))) - (nrepl-start-server-process - (plist-get params :project-dir) - (plist-get params :jack-in-cmd) - (lambda (server-buffer) - (cider-connect-sibling-clj params server-buffer))))) - -;;;###autoload -(defun cider-jack-in-cljs (params) - "Start an nREPL server for the current project and connect to it. -PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and -:cljs-repl-type (e.g. Node, Figwheel, etc). With the prefix argument, -allow editing of the jack in command; with a double prefix prompt for all -these parameters." - (interactive "P") - (let ((cider-jack-in-dependencies (append cider-jack-in-dependencies cider-jack-in-cljs-dependencies)) - (cider-jack-in-lein-plugins (append cider-jack-in-lein-plugins cider-jack-in-cljs-lein-plugins)) - (cider-jack-in-nrepl-middlewares (append cider-jack-in-nrepl-middlewares cider-jack-in-cljs-nrepl-middlewares)) - (orig-buffer (current-buffer))) - ;; cider--update-jack-in-cmd relies indirectly on the above dynamic vars - (let ((params (thread-first - params - (cider--update-project-dir) - (cider--check-existing-session) - (cider--update-jack-in-cmd)))) - (nrepl-start-server-process - (plist-get params :project-dir) - (plist-get params :jack-in-cmd) - (lambda (server-buffer) - (with-current-buffer orig-buffer - (cider-connect-sibling-cljs params server-buffer))))))) - -;;;###autoload -(defun cider-jack-in-clj&cljs (&optional params soft-cljs-start) - "Start an nREPL server and connect with clj and cljs REPLs. -PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and -:cljs-repl-type (e.g. Node, Figwheel, etc). With the prefix argument, -allow for editing of the jack in command; with a double prefix prompt for -all these parameters. When SOFT-CLJS-START is non-nil, start cljs REPL -only when the ClojureScript dependencies are met." - (interactive "P") - (let ((cider-jack-in-dependencies (append cider-jack-in-dependencies cider-jack-in-cljs-dependencies)) - (cider-jack-in-lein-plugins (append cider-jack-in-lein-plugins cider-jack-in-cljs-lein-plugins)) - (cider-jack-in-nrepl-middlewares (append cider-jack-in-nrepl-middlewares cider-jack-in-cljs-nrepl-middlewares)) - (orig-buffer (current-buffer))) - ;; cider--update-jack-in-cmd relies indirectly on the above dynamic vars - (let ((params (thread-first - params - (cider--update-project-dir) - (cider--check-existing-session) - (cider--update-jack-in-cmd) - (cider--update-cljs-type) - ;; already asked, don't ask on sibling connect - (plist-put :do-prompt nil)))) - (nrepl-start-server-process - (plist-get params :project-dir) - (plist-get params :jack-in-cmd) - (lambda (server-buffer) - (with-current-buffer orig-buffer - (let ((clj-repl (cider-connect-sibling-clj params server-buffer))) - (if soft-cljs-start - (when (cider--check-cljs (plist-get params :cljs-repl-type) 'no-error) - (cider-connect-sibling-cljs params clj-repl)) - (cider-connect-sibling-cljs params clj-repl))))))))) - -;;;###autoload -(defun cider-connect-sibling-clj (params &optional other-repl) - "Create a Clojure REPL with the same server as OTHER-REPL. -PARAMS is for consistency with other connection commands and is currently -ignored. OTHER-REPL defaults to `cider-current-repl' and in programs can -also be a server buffer, in which case a new session with a REPL for that -server is created." - (interactive "P") - (cider-nrepl-connect - (let* ((other-repl (or other-repl (cider-current-repl 'any 'ensure))) - (other-params (cider--gather-connect-params nil other-repl)) - (ses-name (unless (nrepl-server-p other-repl) - (sesman-session-name-for-object 'CIDER other-repl)))) - (thread-first - params - (cider--update-do-prompt) - (append other-params) - (plist-put :repl-init-function nil) - (plist-put :repl-type 'clj) - (plist-put :session-name ses-name))))) - -;;;###autoload -(defun cider-connect-sibling-cljs (params &optional other-repl) - "Create a ClojureScript REPL with the same server as OTHER-REPL. -PARAMS is a plist optionally containing :cljs-repl-type (e.g. Node, -Figwheel, etc). All other parameters are inferred from the OTHER-REPL. -OTHER-REPL defaults to `cider-current-repl' but in programs can also be a -server buffer, in which case a new session for that server is created." - (interactive "P") - (let* ((other-repl (or other-repl (cider-current-repl 'any 'ensure))) - (other-params (cider--gather-connect-params nil other-repl)) - (ses-name (unless (nrepl-server-p other-repl) - (sesman-session-name-for-object 'CIDER other-repl)))) - (cider-nrepl-connect - (thread-first - params - (cider--update-do-prompt) - (append other-params) - (cider--update-cljs-type) - (cider--update-cljs-init-function) - (plist-put :session-name ses-name) - (plist-put :repl-type 'cljs))))) - -;;;###autoload -(defun cider-connect-clj (&optional params) - "Initialize a Clojure connection to an nREPL server. -PARAMS is a plist optionally containing :host, :port and :project-dir. On -prefix argument, prompt for all the parameters." - (interactive "P") - (cider-nrepl-connect - (thread-first - params - (cider--update-project-dir) - (cider--update-host-port) - (cider--check-existing-session) - (plist-put :repl-init-function nil) - (plist-put :session-name nil) - (plist-put :repl-type 'clj)))) - -;;;###autoload -(defun cider-connect-cljs (&optional params) - "Initialize a ClojureScript connection to an nREPL server. -PARAMS is a plist optionally containing :host, :port, :project-dir and -:cljs-repl-type (e.g. Node, Figwheel, etc). On prefix, prompt for all the -parameters regardless of their supplied or default values." - (interactive "P") - (cider-nrepl-connect - (thread-first - params - (cider--update-project-dir) - (cider--update-host-port) - (cider--check-existing-session) - (cider--update-cljs-type) - (cider--update-cljs-init-function) - (plist-put :session-name nil) - (plist-put :repl-type 'cljs)))) - -;;;###autoload -(defun cider-connect-clj&cljs (params &optional soft-cljs-start) - "Initialize a Clojure and ClojureScript connection to an nREPL server. -PARAMS is a plist optionally containing :host, :port, :project-dir and -:cljs-repl-type (e.g. Node, Figwheel, etc). When SOFT-CLJS-START is -non-nil, don't start if ClojureScript requirements are not met." - (interactive "P") - (let* ((params (thread-first - params - (cider--update-project-dir) - (cider--update-host-port) - (cider--check-existing-session) - (cider--update-cljs-type))) - (clj-repl (cider-connect-clj params))) - (if soft-cljs-start - (when (cider--check-cljs (plist-get params :cljs-repl-type) 'no-error) - (cider-connect-sibling-cljs params clj-repl)) - (cider-connect-sibling-cljs params clj-repl)))) - -(defvar cider-connection-init-commands - '(cider-jack-in-clj - cider-jack-in-cljs - cider-jack-in-clj&cljs - cider-connect-clj - cider-connect-cljs - cider-connect-clj&cljs - cider-connect-sibling-clj - cider-connect-sibling-cljs) - "A list of all user-level connection init commands in CIDER.") - -;;;###autoload -(defun cider () - "Start a connection of any type interactively." - (interactive) - (when-let* ((command (intern (completing-read "Select command: " cider-connection-init-commands)))) - (call-interactively command))) - - -;;; PARAMS updating - -(defun cider--update-do-prompt (params) - "Update :do-prompt in PARAMS." - (cond ((equal params '(4)) (list :edit-jack-in-command t)) - ((equal params '(16)) (list :do-prompt t)) - (t params))) - -(defun cider--update-project-dir (params) - "Update :project-dir in PARAMS. - -Params is a plist with the following keys (non-exhaustive) - - :edit-project-dir prompt (optional) ask user to confirm the project root - directory." - (let* ((params (cider--update-do-prompt params)) - (proj-dir (if (or (plist-get params :do-prompt) - (plist-get params :edit-project-dir)) - (read-directory-name "Project: " - (clojure-project-dir (cider-current-dir))) - (plist-get params :project-dir))) - (orig-buffer (current-buffer))) - (if (or (null proj-dir) - (file-in-directory-p default-directory proj-dir)) - (plist-put params :project-dir - (or proj-dir - (clojure-project-dir (cider-current-dir)))) - ;; If proj-dir is not a parent of default-directory, transfer all local - ;; variables and hack dir-local variables into a temporary buffer and keep - ;; that buffer within `params` for the later use by other --update- - ;; functions. The context buffer should not be used outside of the param - ;; initialization pipeline. Therefore, we don't bother with making it - ;; unique or killing it anywhere. - (let ((context-buf-name " *cider-context-buffer*")) - (when (get-buffer context-buf-name) - (kill-buffer context-buf-name)) - (with-current-buffer (get-buffer-create context-buf-name) - (dolist (pair (buffer-local-variables orig-buffer)) - (pcase pair - (`(,name . ,value) ;ignore unbound variables - (ignore-errors (set (make-local-variable name) value)))) - (setq-local buffer-file-name nil)) - (let ((default-directory proj-dir)) - (hack-dir-local-variables-non-file-buffer) - (thread-first - params - (plist-put :project-dir proj-dir) - (plist-put :--context-buffer (current-buffer))))))))) - -(defun cider--update-cljs-type (params) - "Update :cljs-repl-type in PARAMS." - (with-current-buffer (or (plist-get params :--context-buffer) - (current-buffer)) - (let ((params (cider--update-do-prompt params)) - (inferred-type (or (plist-get params :cljs-repl-type) - cider-default-cljs-repl))) - (plist-put params :cljs-repl-type - (if (plist-get params :do-prompt) - (cider-select-cljs-repl inferred-type) - (or inferred-type - (cider-select-cljs-repl))))))) - -(defcustom cider-edit-jack-in-command nil - "When truthy allow the user to edit the command." - :type 'boolean - :safe #'booleanp - :version '(cider . "0.22.0")) - -(defvar cider--jack-in-nrepl-params-history nil - "History list for user-specified jack-in nrepl command params.") - -(defvar cider--jack-in-cmd-history nil - "History list for user-specified jack-in commands.") - -(defun cider--update-jack-in-cmd (params) - "Update :jack-in-cmd key in PARAMS. - -PARAMS is a plist with the following keys (non-exhaustive list) - -:project-type optional, the project type to create the command for; see -`cider-jack-in-command' for the list of valid types)." - (cond - ((plist-get params :jack-in-cmd) params) - (cider-jack-in-cmd (plist-put params :jack-in-cmd cider-jack-in-cmd)) - (t (let* ((params (cider--update-do-prompt params)) - (project-dir (plist-get params :project-dir)) - (params-project-type (plist-get params :project-type)) - (project-type (or params-project-type - (cider-project-type project-dir))) - (command (cider-jack-in-command project-type)) - (command-resolved (cider-jack-in-resolve-command project-type)) - ;; TODO: global-options are deprecated and should be removed in CIDER 2.0 - (command-global-opts (cider-jack-in-global-options project-type)) - (command-params (cider-jack-in-params project-type))) - (if command-resolved - (with-current-buffer (or (plist-get params :--context-buffer) - (current-buffer)) - (let* ((command-params (if (plist-get params :do-prompt) - (read-string "nREPL server command: " - command-params - 'cider--jack-in-nrepl-params-history) - command-params)) - (cmd-params (if cider-inject-dependencies-at-jack-in - (cider-inject-jack-in-dependencies command-global-opts command-params - project-type command) - command-params))) - (if (or project-dir cider-allow-jack-in-without-project) - (when (or project-dir - (eq cider-allow-jack-in-without-project t) - (and (null project-dir) - (eq cider-allow-jack-in-without-project 'warn) - (or params-project-type - (y-or-n-p "Are you sure you want to run `cider-jack-in' without a Clojure project? ")))) - (let ((cmd (format "%s %s" command-resolved - (if (cider--jack-in-cmd-powershell-p command) - (cider--powershell-encode-command cmd-params) - cmd-params)))) - (plist-put params :jack-in-cmd (if (or cider-edit-jack-in-command - (plist-get params :edit-jack-in-command)) - (read-string "jack-in command: " cmd 'cider--jack-in-cmd-history) - cmd)))) - (user-error "`cider-jack-in' is not allowed without a Clojure project")))) - (user-error "The %s executable isn't on your `exec-path'" command)))))) - -(defun cider--update-host-port (params) - "Update :host and :port; or :socket-file in PARAMS." - (with-current-buffer (or (plist-get params :--context-buffer) - (current-buffer)) - (let* ((params (cider--update-do-prompt params)) - (host (plist-get params :host)) - (port (plist-get params :port)) - (endpoint (if (plist-get params :do-prompt) - (cider-select-endpoint) - (if (and host port) - (cons host port) - (cider-select-endpoint))))) - (if (equal "local-unix-domain-socket" (car endpoint)) - (plist-put params :socket-file (cdr endpoint)) - (thread-first - params - (plist-put :host (car endpoint)) - (plist-put :port (cdr endpoint))))))) - -(defun cider--update-cljs-init-function (params) - "Update repl type and any init PARAMS for cljs connections. - -The updated params are: - -:cider-repl-cljs-upgrade-pending nil if it is a cljs REPL, or t -when the init form is required to be sent to the REPL to switch -over to cljs. - -:repl-init-form The form that can switch the REPL over to cljs. - -:repl-init-function The fn that switches the REPL over to cljs." - (with-current-buffer (or (plist-get params :--context-buffer) - (current-buffer)) - (let* ((cljs-type (plist-get params :cljs-repl-type)) - (repl-init-form (cider-cljs-repl-form cljs-type))) - (if (null repl-init-form) - (plist-put params :cider-repl-cljs-upgrade-pending nil) - - (thread-first - params - (plist-put :cider-repl-cljs-upgrade-pending t) - (plist-put :repl-init-function - (lambda () - (cider--check-cljs cljs-type) - ;; FIXME: ideally this should be done in the state handler - (setq-local cider-cljs-repl-type cljs-type) - (cider-nrepl-send-request - (list "op" "eval" - "ns" (cider-current-ns) - "code" repl-init-form) - (cider-repl-handler (current-buffer))) - (when (and (buffer-live-p nrepl-server-buffer) - cider-offer-to-open-cljs-app-in-browser) - (cider--offer-to-open-app-in-browser nrepl-server-buffer)))) - (plist-put :repl-init-form repl-init-form)))))) - -(defun cider--check-existing-session (params) - "Ask for confirmation if a session with similar PARAMS already exists. -If no session exists or user chose to proceed, return PARAMS. If the user -canceled the action, signal quit." - (let* ((proj-dir (plist-get params :project-dir)) - (host (plist-get params :host)) - (port (plist-get params :port)) - (session (seq-find (lambda (ses) - (let ((ses-params (cider--gather-session-params ses))) - (and (equal proj-dir (plist-get ses-params :project-dir)) - (or (null port) - (equal port (plist-get ses-params :port))) - (or (null host) - (equal host (plist-get ses-params :host)))))) - (sesman-current-sessions 'CIDER '(project))))) - (when session - (unless (y-or-n-p - (concat - "A CIDER session with the same connection parameters already exists (" (car session) "). " - "Are you sure you want to create a new session instead of using `cider-connect-sibling-clj(s)'? ")) - (let ((debug-on-quit nil)) - (signal 'quit nil))))) - params) - - -;;; Aliases - -;;;###autoload -(defalias 'cider-jack-in #'cider-jack-in-clj) -;;;###autoload -(defalias 'cider-connect #'cider-connect-clj) - - -;;; Helpers - -(defun cider-current-host () - "Retrieve the current host." - (or (when (stringp buffer-file-name) - (file-remote-p buffer-file-name 'host)) - "localhost")) - -(defun cider-select-endpoint () - "Interactively select the host and port to connect to." - (dolist (endpoint cider-known-endpoints) - (unless (stringp (or (nth 2 endpoint) - (nth 1 endpoint))) - (user-error "The port for %s in `cider-known-endpoints' should be a string" - (nth 0 endpoint)))) - (let* ((ssh-hosts (cider--ssh-hosts)) - (hosts (seq-uniq (append (when cider-host-history - ;; history elements are strings of the form "host:port" - (list (split-string (car cider-host-history) ":"))) - (list (list (cider-current-host))) - cider-known-endpoints - ssh-hosts - ;; always add localhost - '(("localhost") - ("local-unix-domain-socket"))))) - (sel-host (cider--completing-read-host hosts)) - (host (car sel-host)) - (port (or (cadr sel-host) - (if (equal host "local-unix-domain-socket") - (cider--completing-read-socket-file) - (cider--completing-read-port host (cider--infer-ports host ssh-hosts)))))) - (cons host port))) - -(defun cider--ssh-hosts () - "Retrieve all ssh host from local configuration files." - (seq-map (lambda (s) (list (replace-regexp-in-string ":$" "" s))) - ;; `tramp-completion-mode' is obsoleted in 26 - (cl-progv (if (version< emacs-version "26") - '(tramp-completion-mode) - '(non-essential)) '(t) - (tramp-completion-handle-file-name-all-completions "" "/ssh:")))) - -(defun cider--completing-read-host (hosts) - "Interactively select host from HOSTS. -Each element in HOSTS is one of: (host), (host port) or (label host port). -Return a list of the form (HOST PORT), where PORT can be nil." - (let* ((hosts (cider-join-into-alist hosts)) - (sel-host (completing-read "Host: " hosts nil nil nil - 'cider-host-history (caar hosts))) - (host (or (cdr (assoc sel-host hosts)) (list sel-host)))) - ;; remove the label - (if (= 3 (length host)) (cdr host) host))) - -(defun cider--tramp-file-name (vec) - "A simple compatibility wrapper around `make-tramp-file-name'. -Tramp version starting 26.1 is using a `cl-defstruct' rather than vanilla VEC." - (if (version< emacs-version "26.1") - vec - (with-no-warnings - (make-tramp-file-name :method (elt vec 0) - :host (elt vec 2))))) - -(defcustom cider-infer-remote-nrepl-ports nil - "When true, cider will use ssh to try to infer nREPL ports on remote hosts." - :type 'boolean - :safe #'booleanp - :package-version '(cider . "0.19.0")) - -(defun cider--infer-ports (host ssh-hosts) - "Infer nREPL ports on HOST. -Return a list of elements of the form (directory port). SSH-HOSTS is a list -of remote SSH hosts." - (let ((localp (or (nrepl-local-host-p host) - (not (assoc-string host ssh-hosts))))) - (if localp - ;; change dir: current file might be remote - (let* ((change-dir-p (file-remote-p default-directory)) - (default-directory (if change-dir-p "~/" default-directory))) - (cider-locate-running-nrepl-ports (unless change-dir-p default-directory))) - (when cider-infer-remote-nrepl-ports - (let ((vec (vector "sshx" nil host "" nil)) - ;; change dir: user might want to connect to a different remote - (dir (when (file-remote-p default-directory) - (with-parsed-tramp-file-name default-directory cur - (when (string= cur-host host) default-directory))))) - (tramp-maybe-open-connection (cider--tramp-file-name vec)) - (with-current-buffer (tramp-get-connection-buffer (cider--tramp-file-name vec)) - (cider-locate-running-nrepl-ports dir))))))) - -(defun cider--completing-read-port (host ports) - "Interactively select port for HOST from PORTS." - (let* ((ports (cider-join-into-alist ports)) - (sel-port (completing-read (format "Port for %s: " host) ports - nil nil nil nil (caar ports))) - (port (or (cdr (assoc sel-port ports)) sel-port)) - (port (if (listp port) (cadr port) port))) - (if (stringp port) (string-to-number port) port))) - -(defun cider--completing-read-socket-file () - "Interactively select unix domain socket file name." - (read-file-name "Socket File: " nil nil t nil - (lambda (filename) - "Predicate: auto-complete only socket-files and directories" - (let ((filetype (string-to-char - (file-attribute-modes - (file-attributes - filename))))) - (or (eq ?s filetype) - (eq ?d filetype)))))) - -(defun cider-locate-running-nrepl-ports (&optional dir) - "Locate ports of running nREPL servers. -When DIR is non-nil also look for nREPL port files in DIR. Return a list -of list of the form (project-dir port)." - (let* ((paths (cider--running-nrepl-paths)) - (proj-ports (apply #'append - (mapcar (lambda (d) - (mapcar (lambda (p) (list (file-name-nondirectory (directory-file-name d)) p)) - (and d (nrepl-extract-ports (cider--file-path d))))) - (cons (clojure-project-dir dir) paths))))) - (seq-uniq (delq nil proj-ports)))) - -(defun cider--running-nrepl-paths () - "Retrieve project paths of running nREPL servers. -Use `cider-ps-running-nrepls-command' and -`cider-ps-running-nrepl-path-regexp-list'." - (let (paths) - (with-temp-buffer - (insert (shell-command-to-string cider-ps-running-nrepls-command)) - (dolist (regexp cider-ps-running-nrepl-path-regexp-list) - (goto-char 1) - (while (re-search-forward regexp nil t) - (setq paths (cons (match-string 1) paths))))) - (seq-uniq paths))) - -(defun cider--identify-buildtools-present (&optional project-dir) - "Identify build systems present by their build files in PROJECT-DIR. -PROJECT-DIR defaults to current project." - (let* ((default-directory (or project-dir (clojure-project-dir (cider-current-dir)))) - (build-files '((lein . "project.clj") - (boot . "build.boot") - (clojure-cli . "deps.edn") - (babashka . "bb.edn") - (shadow-cljs . "shadow-cljs.edn") - (gradle . "build.gradle") - (gradle . "build.gradle.kts") - (nbb . "nbb.edn")))) - (delq nil - (mapcar (lambda (candidate) - (when (file-exists-p (cdr candidate)) - (car candidate))) - build-files)))) - -(defun cider-project-type (&optional project-dir) - "Determine the type of the project in PROJECT-DIR. -When multiple project file markers are present, check for a preferred build -tool in `cider-preferred-build-tool', otherwise prompt the user to choose. -PROJECT-DIR defaults to the current project." - (let* ((choices (cider--identify-buildtools-present project-dir)) - (multiple-project-choices (> (length choices) 1)) - ;; this needs to be a string to be used in `completing-read' - (default (symbol-name (car choices))) - ;; `cider-preferred-build-tool' used to be a string prior to CIDER - ;; 0.18, therefore the need for `cider-maybe-intern' - (preferred-build-tool (cider-maybe-intern cider-preferred-build-tool))) - (cond ((and multiple-project-choices - (member preferred-build-tool choices)) - preferred-build-tool) - (multiple-project-choices - (intern - (completing-read - (format "Which command should be used (default %s): " default) - choices nil t nil nil default))) - (choices - (car choices)) - ;; TODO: Move this fallback outside the project-type check - ;; if we're outside a project we fallback to whatever tool - ;; is specified in `cider-jack-in-default' (normally clojure-cli) - ;; `cider-jack-in-default' used to be a string prior to CIDER - ;; 0.18, therefore the need for `cider-maybe-intern' - (t (cider-maybe-intern cider-jack-in-default))))) - -;;;###autoload -(defun cider-jack-in-universal (arg) - "Start and connect to an nREPL server for the current project or ARG project id. - -If a project is found in current dir, call `cider-jack-in' passing ARG as -first parameter, of which see. Otherwise, ask user which project type to -start an nREPL server and connect to without a project. - -But if invoked with a numeric prefix ARG, then start an nREPL server for -the project type denoted by ARG number and connect to it, even if there is -no project for it in the current dir. - -The supported project tools and their assigned numeric prefix ids are -sourced from `cider-jack-in-universal-options', of which see. - -You can pass a numeric prefix argument n with `M-n` or `C-u n`. - -For example, to jack in to leiningen which is assigned to prefix arg 2 type - -M-2 \\[cider-jack-in-universal]." - (interactive "P") - (let ((cpt (clojure-project-dir (cider-current-dir)))) - (if (or (integerp arg) (null cpt)) - (let* ((project-types-available (mapcar #'car cider-jack-in-universal-options)) - (project-type (if (null arg) - (intern (completing-read - "No project found in current dir, select project type to jack in: " - project-types-available - nil t)) - - (or (seq-some (lambda (elt) - (cl-destructuring-bind - (project-type (&key prefix-arg &allow-other-keys)) elt - (when (= arg prefix-arg) - project-type))) - cider-jack-in-universal-options) - (error ":cider-jack-in-universal :unsupported-prefix-argument %S :no-such-project" - arg)))) - (project-options (cadr (seq-find (lambda (elt) (equal project-type (car elt))) - cider-jack-in-universal-options))) - (jack-in-opts (plist-get project-options :cmd)) - (jack-in-type (plist-get jack-in-opts :jack-in-type))) - (pcase jack-in-type - ('clj (cider-jack-in-clj jack-in-opts)) - ('cljs (cider-jack-in-cljs jack-in-opts)) - (_ (error ":cider-jack-in-universal :jack-in-type-unsupported %S" jack-in-type)))) - - (cider-jack-in-clj arg)))) - - -;; TODO: Implement a check for command presence over tramp -(defun cider--resolve-command (command) - "Find COMMAND in exec path (see variable `exec-path'). -Return nil if not found. In case `default-directory' is non-local we -assume the command is available." - (when-let* ((command (or (and (file-remote-p default-directory) command) - (executable-find command) - (executable-find (concat command ".bat"))))) - (shell-quote-argument command))) - -(defun cider--resolve-project-command (command) - "Find COMMAND in project dir or exec path (see variable `exec-path'). -If COMMAND starts with ./ or ../ resolve relative to `clojure-project-dir', -otherwise resolve via `cider--resolve-command'." - (if (string-match-p "\\`\\.\\{1,2\\}/" command) - (locate-file command (list (clojure-project-dir)) '("" ".bat") 'executable) - (cider--resolve-command command))) - -(defcustom cider-connection-message-fn #'cider-random-words-of-inspiration - "The function to use to generate the message displayed on connect. -When set to nil no additional message will be displayed. A good -alternative to the default is `cider-random-tip'." - :type 'function - :group 'cider - :package-version '(cider . "0.11.0")) - -(defun cider--maybe-inspire-on-connect () - "Display an inspiration connection message." - (when cider-connection-message-fn - (message "Connected! %s" (funcall cider-connection-message-fn)))) - -(add-hook 'cider-connected-hook #'cider--maybe-inspire-on-connect) - -;;;###autoload -(with-eval-after-load 'clojure-mode - (define-key clojure-mode-map (kbd "C-c M-x") #'cider) - (define-key clojure-mode-map (kbd "C-c M-j") #'cider-jack-in-clj) - (define-key clojure-mode-map (kbd "C-c M-J") #'cider-jack-in-cljs) - (define-key clojure-mode-map (kbd "C-c M-c") #'cider-connect-clj) - (define-key clojure-mode-map (kbd "C-c M-C") #'cider-connect-cljs) - (define-key clojure-mode-map (kbd "C-c C-x") 'cider-start-map) - (define-key clojure-mode-map (kbd "C-c C-s") 'sesman-map) - (require 'sesman) - (sesman-install-menu clojure-mode-map) - (add-hook 'clojure-mode-hook (lambda () (setq-local sesman-system 'CIDER)))) - -(provide 'cider) - -;;; cider.el ends here diff --git a/elpa/cider-20230707.640/nrepl-client.el b/elpa/cider-20230707.640/nrepl-client.el deleted file mode 100644 index beb9b32d..00000000 --- a/elpa/cider-20230707.640/nrepl-client.el +++ /dev/null @@ -1,1492 +0,0 @@ -;;; nrepl-client.el --- Client for Clojure nREPL -*- lexical-binding: t -*- - -;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Tim King -;; Phil Hagelberg -;; Bozhidar Batsov -;; Artur Malabarba -;; Hugo Duncan -;; Steve Purcell -;; Reid McKenzie -;; -;; 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 . -;; -;; This file is not part of GNU Emacs. -;; -;;; Commentary: -;; -;; Provides an Emacs Lisp client to connect to Clojure nREPL servers. -;; -;; A connection is an abstract idea of the communication between Emacs (client) -;; and nREPL server. On the Emacs side connections are represented by two -;; running processes. The two processes are the server process and client -;; process (the connection to the server). Each of these is represented by its -;; own process buffer, filter and sentinel. -;; -;; The nREPL communication process can be broadly represented as follows: -;; -;; 1) The server process is started as an Emacs subprocess (usually by -;; `cider-jack-in', which in turn fires up an nREPL server). Note that -;; if a connection was established using `cider-connect' there won't be -;; a server process. -;; -;; 2) The server's process filter (`nrepl-server-filter') detects the -;; connection port from the first plain text response from the server and -;; starts a communication process (socket connection) as another Emacs -;; subprocess. This is the nREPL client process (`nrepl-client-filter'). -;; All requests and responses handling happens through this client -;; connection. -;; -;; 3) Requests are sent by `nrepl-send-request' and -;; `nrepl-send-sync-request'. A request is simply a list containing a -;; requested operation name and the parameters required by the -;; operation. Each request has an associated callback that is called once -;; the response for the request has arrived. Besides the above functions -;; there are specialized request senders for each type of common -;; operations. Examples are `nrepl-request:eval', `nrepl-request:clone', -;; `nrepl-sync-request:describe'. -;; -;; 4) Responses from the server are decoded in `nrepl-client-filter' and are -;; physically represented by alists whose structure depends on the type of -;; the response. After having been decoded, the data from the response is -;; passed over to the callback that was registered by the original -;; request. -;; -;; Please see the comments in dedicated sections of this file for more detailed -;; description. - -;;; Code: -(require 'seq) -(require 'subr-x) -(require 'cl-lib) -(require 'nrepl-dict) -(require 'queue) -(require 'sesman) -(require 'tramp) - - -;;; Custom - -(defgroup nrepl nil - "Interaction with the Clojure nREPL Server." - :prefix "nrepl-" - :group 'applications) - -;; (defcustom nrepl-buffer-name-separator " " -;; "Used in constructing the REPL buffer name. -;; The `nrepl-buffer-name-separator' separates cider-repl from the project name." -;; :type '(string) -;; :group 'nrepl) -(make-obsolete-variable 'nrepl-buffer-name-separator 'cider-session-name-template "0.18") - -;; (defcustom nrepl-buffer-name-show-port nil -;; "Show the connection port in the nrepl REPL buffer name, if set to t." -;; :type 'boolean -;; :group 'nrepl) -(make-obsolete-variable 'nrepl-buffer-name-show-port 'cider-session-name-template "0.18") - -(defcustom nrepl-connected-hook nil - "List of functions to call when connecting to the nREPL server." - :type 'hook) - -(defcustom nrepl-disconnected-hook nil - "List of functions to call when disconnected from the nREPL server." - :type 'hook) - -(defcustom nrepl-force-ssh-for-remote-hosts nil - "If non-nil, do not attempt a direct connection for remote hosts." - :type 'boolean) - -(defcustom nrepl-use-ssh-fallback-for-remote-hosts nil - "If non-nil, Use ssh as a fallback to connect to remote hosts. -It will attempt to connect via ssh to remote hosts when unable to connect -directly." - :type 'boolean) - -(defcustom nrepl-sync-request-timeout 10 - "The number of seconds to wait for a sync response. -Setting this to nil disables the timeout functionality." - :type 'integer) - -(defcustom nrepl-hide-special-buffers nil - "Control the display of some special buffers in buffer switching commands. -When true some special buffers like the server buffer will be hidden." - :type 'boolean) - - -;;; Buffer Local Declarations - -;; These variables are used to track the state of nREPL connections -(defvar-local nrepl-connection-buffer nil) -(defvar-local nrepl-server-buffer nil) -(defvar-local nrepl-messages-buffer nil) -(defvar-local nrepl-endpoint nil) -(defvar-local nrepl-project-dir nil) -(defvar-local nrepl-is-server nil) -(defvar-local nrepl-server-command nil) -(defvar-local nrepl-tunnel-buffer nil) - -(defvar-local nrepl-session nil - "Current nREPL session id.") - -(defvar-local nrepl-tooling-session nil - "Current nREPL tooling session id. -To be used for tooling calls (i.e. completion, eldoc, etc)") - -(defvar-local nrepl-request-counter 0 - "Continuation serial number counter.") - -(defvar-local nrepl-pending-requests nil) - -(defvar-local nrepl-completed-requests nil) - -(defvar-local nrepl-last-sync-response nil - "Result of the last sync request.") - -(defvar-local nrepl-last-sync-request-timestamp nil - "The time when the last sync request was initiated.") - -(defvar-local nrepl-ops nil - "Available nREPL server ops (from describe).") - -(defvar-local nrepl-versions nil - "Version information received from the describe op.") - -(defvar-local nrepl-aux nil - "Auxiliary information received from the describe op.") - - -;;; nREPL Buffer Names - -(defconst nrepl-message-buffer-name-template "*nrepl-messages %s(%r:%S)*") -(defconst nrepl-error-buffer-name "*nrepl-error*") -(defconst nrepl-repl-buffer-name-template "*cider-repl %s(%r:%S)*") -(defconst nrepl-server-buffer-name-template "*nrepl-server %s*") -(defconst nrepl-tunnel-buffer-name-template "*nrepl-tunnel %s*") - -(declare-function cider-format-connection-params "cider-connection") -(defun nrepl-make-buffer-name (template params &optional dup-ok) - "Generate a buffer name using TEMPLATE and PARAMS. -TEMPLATE and PARAMS are as in `cider-format-connection-params'. If -optional DUP-OK is non-nil, the returned buffer is not \"uniquified\" by a -call to `generate-new-buffer-name'." - (let ((name (cider-format-connection-params template params))) - (if dup-ok - name - (generate-new-buffer-name name)))) - -(defun nrepl--make-hidden-name (buffer-name) - "Apply a prefix to BUFFER-NAME that will hide the buffer." - (concat (if nrepl-hide-special-buffers " " "") buffer-name)) - -(defun nrepl-repl-buffer-name (params &optional dup-ok) - "Return the name of the repl buffer. -PARAMS and DUP-OK are as in `nrepl-make-buffer-name'." - (nrepl-make-buffer-name nrepl-repl-buffer-name-template params dup-ok)) - -(defun nrepl-server-buffer-name (params) - "Return the name of the server buffer. -PARAMS is as in `nrepl-make-buffer-name'." - (nrepl-make-buffer-name (nrepl--make-hidden-name nrepl-server-buffer-name-template) - params)) - -(defun nrepl-tunnel-buffer-name (params) - "Return the name of the tunnel buffer. -PARAMS is as in `nrepl-make-buffer-name'." - (nrepl-make-buffer-name (nrepl--make-hidden-name nrepl-tunnel-buffer-name-template) - params)) - -(defun nrepl-messages-buffer-name (params) - "Return the name for the message buffer given connection PARAMS." - (nrepl-make-buffer-name nrepl-message-buffer-name-template params)) - - -;;; Utilities -(defun nrepl-op-supported-p (op connection) - "Return t iff the given operation OP is supported by the nREPL CONNECTION." - (when (buffer-live-p connection) - (with-current-buffer connection - (and nrepl-ops (nrepl-dict-get nrepl-ops op))))) - -(defun nrepl-aux-info (key connection) - "Return KEY's aux info, as returned via the :describe op for CONNECTION." - (with-current-buffer connection - (and nrepl-aux (nrepl-dict-get nrepl-aux key)))) - -(defun nrepl-local-host-p (host) - "Return t if HOST is local." - (string-match-p tramp-local-host-regexp host)) - -(defun nrepl-extract-port (dir) - "Read port from applicable repl-port file in directory DIR." - (or (nrepl--port-from-file (expand-file-name "repl-port" dir)) - (nrepl--port-from-file (expand-file-name ".nrepl-port" dir)) - (nrepl--port-from-file (expand-file-name "target/repl-port" dir)) - (nrepl--port-from-file (expand-file-name ".shadow-cljs/nrepl.port" dir)))) - -(defun nrepl-extract-ports (dir) - "Read ports from applicable repl-port files in directory DIR." - (delq nil - (list (nrepl--port-from-file (expand-file-name "repl-port" dir)) - (nrepl--port-from-file (expand-file-name ".nrepl-port" dir)) - (nrepl--port-from-file (expand-file-name "target/repl-port" dir)) - (nrepl--port-from-file (expand-file-name ".shadow-cljs/nrepl.port" dir))))) - -(make-obsolete 'nrepl-extract-port 'nrepl-extract-ports "1.5.0") - -(defun nrepl--port-from-file (file) - "Attempts to read port from a file named by FILE." - (when (file-exists-p file) - (with-temp-buffer - (insert-file-contents file) - (buffer-string)))) - - -;;; Bencode - -(cl-defstruct (nrepl-response-queue - (:include queue) - (:constructor nil) - (:constructor nrepl-response-queue (&optional stub))) - stub) - -(put 'nrepl-response-queue 'function-documentation - "Create queue object used by nREPL to store decoded server responses. -The STUB slot stores a stack of nested, incompletely parsed objects.") - -(defun nrepl--bdecode-list (&optional stack) - "Decode a bencode list or dict starting at point. -STACK is as in `nrepl--bdecode-1'." - ;; skip leading l or d - (forward-char 1) - (let* ((istack (nrepl--bdecode-1 stack)) - (pos0 (point)) - (info (car istack))) - (while (null info) - (setq istack (nrepl--bdecode-1 (cdr istack)) - pos0 (point) - info (car istack))) - (cond ((eq info :e) - (cons nil (cdr istack))) - ((eq info :stub) - (goto-char pos0) - istack) - (t istack)))) - -(defun nrepl--bdecode-1 (&optional stack) - "Decode one elementary bencode object starting at point. -Bencoded object is either list, dict, integer or string. See -http://en.wikipedia.org/wiki/Bencode#Encoding_algorithm for the encoding -rules. - -STACK is a list of so far decoded components of the current message. Car -of STACK is the innermost incompletely decoded object. The algorithm pops -this list when inner object was completely decoded or grows it by one when -new list or dict was encountered. - -The returned value is of the form (INFO . STACK) where INFO is -:stub, nil, :end or :eob and STACK is either an incomplete parsing state as -above (INFO is :stub, nil or :eob) or a list of one component representing -the completely decoded message (INFO is :end). INFO is nil when an -elementary non-root object was successfully decoded. INFO is :end when this -object is a root list or dict." - (cond - ;; list - ((eq (char-after) ?l) - (nrepl--bdecode-list (cons () stack))) - ;; dict - ((eq (char-after) ?d) - (nrepl--bdecode-list (cons '(dict) stack))) - ;; end of a list or a dict - ((eq (char-after) ?e) - (forward-char 1) - (cons (if (cdr stack) :e :end) - (nrepl--push (nrepl--nreverse (car stack)) - (cdr stack)))) - ;; string - ((looking-at "\\([0-9]+\\):") - (let ((pos0 (point)) - (beg (goto-char (match-end 0))) - (end (byte-to-position (+ (position-bytes (point)) - (string-to-number (match-string 1)))))) - (if (null end) - (progn (goto-char pos0) - (cons :stub stack)) - (goto-char end) - ;; normalise any platform-specific newlines - (let* ((original (buffer-substring-no-properties beg end)) - (result (replace-regexp-in-string "\r\n\\|\n\r\\|\r" "\n" original))) - (cons nil (nrepl--push result stack)))))) - ;; integer - ((looking-at "i\\(-?[0-9]+\\)e") - (goto-char (match-end 0)) - (cons nil (nrepl--push (string-to-number (match-string 1)) - stack))) - ;; should happen in tests only as eobp is checked in nrepl-bdecode. - ((eobp) - (cons :eob stack)) - ;; truncation in the middle of an integer or in 123: string prefix - ((looking-at-p "[0-9i]") - (cons :stub stack)) - ;; else, throw a quiet error - (t - (message "Invalid bencode message detected. See the %s buffer for details." - nrepl-error-buffer-name) - (nrepl-log-error - (format "Decoder error at position %d (`%s'):" - (point) (buffer-substring (point) (min (+ (point) 10) (point-max))))) - (nrepl-log-error (buffer-string)) - (ding) - ;; Ensure loop break and clean queues' states in nrepl-bdecode: - (goto-char (point-max)) - (cons :end nil)))) - -(defun nrepl--bdecode-message (&optional stack) - "Decode one full message starting at point. -STACK is as in `nrepl--bdecode-1'. Return a cons (INFO . STACK)." - (let* ((istack (nrepl--bdecode-1 stack)) - (info (car istack)) - (stack (cdr istack))) - (while (or (null info) - (eq info :e)) - (setq istack (nrepl--bdecode-1 stack) - info (car istack) - stack (cdr istack))) - istack)) - -(defun nrepl--ensure-fundamental-mode () - "Enable `fundamental-mode' if it is not enabled already." - (when (not (eq 'fundamental-mode major-mode)) - (fundamental-mode))) - -(defun nrepl-bdecode (string-q &optional response-q) - "Decode STRING-Q and place the results into RESPONSE-Q. -STRING-Q is either a queue of strings or a string. RESPONSE-Q is a queue of -server requests (nREPL dicts). STRING-Q and RESPONSE-Q are modified by side -effects. - -Return a cons (STRING-Q . RESPONSE-Q) where STRING-Q is the original queue -containing the remainder of the input strings which could not be -decoded. RESPONSE-Q is the original queue with successfully decoded messages -enqueued and with slot STUB containing a nested stack of an incompletely -decoded message or nil if the strings were completely decoded." - (with-current-buffer (get-buffer-create " *nrepl-decoding*") - ;; Don't needlessly call `fundamental-mode', to prevent needlessly firing - ;; hooks. This fixes an issue with evil-mode where the cursor loses its - ;; correct color. - (nrepl--ensure-fundamental-mode) - (erase-buffer) - (if (queue-p string-q) - (while (queue-head string-q) - (insert (queue-dequeue string-q))) - (insert string-q) - (setq string-q (queue-create))) - (goto-char 1) - (unless response-q - (setq response-q (nrepl-response-queue))) - (let ((istack (nrepl--bdecode-message - (nrepl-response-queue-stub response-q)))) - (while (and (eq (car istack) :end) - (not (eobp))) - (queue-enqueue response-q (cadr istack)) - (setq istack (nrepl--bdecode-message))) - (unless (eobp) - (queue-enqueue string-q (buffer-substring (point) (point-max)))) - (if (not (eq (car istack) :end)) - (setf (nrepl-response-queue-stub response-q) (cdr istack)) - (queue-enqueue response-q (cadr istack)) - (setf (nrepl-response-queue-stub response-q) nil)) - (erase-buffer) - (cons string-q response-q)))) - -(defun nrepl-bencode (object) - "Encode OBJECT with bencode. -Integers, lists and nrepl-dicts are treated according to bencode -specification. Everything else is encoded as string." - (cond - ((integerp object) (format "i%de" object)) - ((nrepl-dict-p object) (format "d%se" (mapconcat #'nrepl-bencode (cdr object) ""))) - ((listp object) (format "l%se" (mapconcat #'nrepl-bencode object ""))) - (t (format "%s:%s" (string-bytes object) object)))) - - -;;; Client: Process Filter - -(defvar nrepl-response-handler-functions nil - "List of functions to call on each nREPL message. -Each of these functions should be a function with one argument, which will -be called by `nrepl-client-filter' on every response received. The current -buffer will be connection (REPL) buffer of the process. These functions -should take a single argument, a dict representing the message. See -`nrepl--dispatch-response' for an example. - -These functions are called before the message's own callbacks, so that they -can affect the behavior of the callbacks. Errors signaled by these -functions are demoted to messages, so that they don't prevent the -callbacks from running.") - -(defun nrepl-client-filter (proc string) - "Decode message(s) from PROC contained in STRING and dispatch them." - (let ((string-q (process-get proc :string-q))) - (queue-enqueue string-q string) - ;; Start decoding only if the last letter is 'e' - (when (eq ?e (aref string (1- (length string)))) - (let ((response-q (process-get proc :response-q))) - (nrepl-bdecode string-q response-q) - (while (queue-head response-q) - (with-current-buffer (process-buffer proc) - (let ((response (queue-dequeue response-q))) - (with-demoted-errors "Error in one of the `nrepl-response-handler-functions': %s" - (run-hook-with-args 'nrepl-response-handler-functions response)) - (nrepl--dispatch-response response)))))))) - -(defun nrepl--dispatch-response (response) - "Dispatch the RESPONSE to associated callback. -First we check the callbacks of pending requests. If no callback was found, -we check the completed requests, since responses could be received even for -older requests with \"done\" status." - (nrepl-dbind-response response (id) - (nrepl-log-message response 'response) - (let ((callback (or (gethash id nrepl-pending-requests) - (gethash id nrepl-completed-requests)))) - (if callback - (funcall callback response) - (error "[nREPL] No response handler with id %s found" id))))) - -(defun nrepl-client-sentinel (process message) - "Handle sentinel events from PROCESS. -Notify MESSAGE and if the process is closed run `nrepl-disconnected-hook' -and kill the process buffer." - (if (string-match "deleted\\b" message) - (message "[nREPL] Connection closed") - (message "[nREPL] Connection closed unexpectedly (%s)" - (substring message 0 -1))) - (when (equal (process-status process) 'closed) - (when-let* ((client-buffer (process-buffer process))) - (sesman-remove-object 'CIDER nil client-buffer - (not (process-get process :keep-server)) - 'no-error) - (nrepl--clear-client-sessions client-buffer) - (with-current-buffer client-buffer - (goto-char (point-max)) - (insert-before-markers - (propertize - (format "\n*** Closed on %s ***\n" (current-time-string)) - 'face 'cider-repl-stderr-face)) - (run-hooks 'nrepl-disconnected-hook) - (let ((server-buffer nrepl-server-buffer)) - (when (and (buffer-live-p server-buffer) - (not (process-get process :keep-server))) - (setq nrepl-server-buffer nil) - (nrepl--maybe-kill-server-buffer server-buffer))))))) - - -;;; Network - -(defun nrepl--unix-connect (socket-file &optional no-error) - "If SOCKET-FILE is given, try to `make-network-process'. -If NO-ERROR is non-nil, show messages instead of throwing an error." - (if (not socket-file) - (unless no-error - (error "[nREPL] Socket file not provided")) - (message "[nREPL] Establishing unix socket connection to %s ..." socket-file) - (condition-case nil - (prog1 (list :proc (make-network-process :name "nrepl-connection" :buffer nil - :family 'local :service socket-file) - :host "local-unix-domain-socket" - :port socket-file - :socket-file socket-file) - (message "[nREPL] Unix socket connection to %s established" socket-file)) - (error (let ((msg (format "[nREPL] Unix socket connection to %s failed" socket-file))) - (if no-error - (message msg) - (error msg)) - nil))))) - -(defun nrepl-connect (host port) - "Connect to the nREPL server identified by HOST and PORT. -For local hosts use a direct connection. For remote hosts, if -`nrepl-force-ssh-for-remote-hosts' is nil, attempt a direct connection -first. If `nrepl-force-ssh-for-remote-hosts' is non-nil or the direct -connection failed (and `nrepl-use-ssh-fallback-for-remote-hosts' is -non-nil), try to start a SSH tunneled connection. Return a plist of the -form (:proc PROC :host \"HOST\" :port PORT) that might contain additional -key-values depending on the connection type." - (let ((localp (if host - (nrepl-local-host-p host) - (not (file-remote-p default-directory))))) - (if localp - (nrepl--direct-connect (or host "localhost") port) - ;; we're dealing with a remote host - (if (and host (not nrepl-force-ssh-for-remote-hosts)) - (or (nrepl--direct-connect host port 'no-error) - ;; direct connection failed - ;; fallback to ssh tunneling if enabled - (and nrepl-use-ssh-fallback-for-remote-hosts - (message "[nREPL] Falling back to SSH tunneled connection ...") - (nrepl--ssh-tunnel-connect host port)) - ;; fallback is either not enabled or it failed as well - (if (and (null nrepl-use-ssh-fallback-for-remote-hosts) - (not localp)) - (error "[nREPL] Direct connection to %s:%s failed; try setting `nrepl-use-ssh-fallback-for-remote-hosts' to t" - host port) - (error "[nREPL] Cannot connect to %s:%s" host port))) - ;; `nrepl-force-ssh-for-remote-hosts' is non-nil - (nrepl--ssh-tunnel-connect host port))))) - -(defun nrepl--direct-connect (host port &optional no-error) - "If HOST and PORT are given, try to `open-network-stream'. -If NO-ERROR is non-nil, show messages instead of throwing an error." - (if (not (and host port)) - (unless no-error - (unless host - (error "[nREPL] Host not provided")) - (unless port - (error "[nREPL] Port not provided"))) - (message "[nREPL] Establishing direct connection to %s:%s ..." host port) - (condition-case nil - (prog1 (list :proc (open-network-stream "nrepl-connection" nil host port) - :host host :port port) - (message "[nREPL] Direct connection to %s:%s established" host port)) - (error (let ((msg (format "[nREPL] Direct connection to %s:%s failed" host port))) - (if no-error - (message msg) - (error msg)) - nil))))) - -(defun nrepl--ssh-tunnel-connect (host port) - "Connect to a remote machine identified by HOST and PORT through SSH tunnel." - (message "[nREPL] Establishing SSH tunneled connection to %s:%s ..." host port) - (let* ((current-buf (buffer-file-name)) - (tramp-file-regexp "/ssh:\\(.+@\\)?\\(.+?\\)\\(:\\|#\\).+") - (remote-dir (cond - ;; If current buffer is a TRAMP buffer and its host is - ;; the same as HOST, reuse its connection parameters for - ;; SSH tunnel. - ((and (string-match tramp-file-regexp current-buf) - (string= host (match-string 2 current-buf))) current-buf) - ;; Otherwise, if HOST was provided, use it for connection. - (host (format "/ssh:%s:" host)) - ;; Use default directory as fallback. - (t default-directory))) - (ssh (or (executable-find "ssh") - (error "[nREPL] Cannot locate 'ssh' executable"))) - (cmd (nrepl--ssh-tunnel-command ssh remote-dir port)) - (tunnel-buf (nrepl-tunnel-buffer-name - `((:host ,host) (:port ,port)))) - (tunnel (start-process-shell-command "nrepl-tunnel" tunnel-buf cmd))) - (process-put tunnel :waiting-for-port t) - (set-process-filter tunnel (nrepl--ssh-tunnel-filter port)) - (while (and (process-live-p tunnel) - (process-get tunnel :waiting-for-port)) - (accept-process-output nil 0.005)) - (if (not (process-live-p tunnel)) - (error "[nREPL] SSH port forwarding failed. Check the '%s' buffer" tunnel-buf) - (message "[nREPL] SSH port forwarding established to localhost:%s" port) - (let ((endpoint (nrepl--direct-connect "localhost" port))) - (thread-first - endpoint - (plist-put :tunnel tunnel) - (plist-put :remote-host host)))))) - -(defun nrepl--ssh-tunnel-command (ssh dir port) - "Command string to open SSH tunnel to the host associated with DIR's PORT." - (with-parsed-tramp-file-name dir v - ;; this abuses the -v option for ssh to get output when the port - ;; forwarding is set up, which is used to synchronise on, so that - ;; the port forwarding is up when we try to connect. - (format-spec - "%s -v -N -L %p:localhost:%p %u'%h' %n" - `((?s . ,ssh) - (?p . ,port) - (?h . ,v-host) - (?u . ,(if v-user (format "-l '%s' " v-user) "")) - (?n . ,(if v-port (format "-p '%s' " v-port) "")))))) - -(autoload 'comint-watch-for-password-prompt "comint" "(autoload).") - -(defun nrepl--ssh-tunnel-filter (port) - "Return a process filter that waits for PORT to appear in process output." - (let ((port-string (format "LOCALHOST:%s" port))) - (lambda (proc string) - (when (string-match-p port-string string) - (process-put proc :waiting-for-port nil)) - (when (and (process-live-p proc) - (buffer-live-p (process-buffer proc))) - (with-current-buffer (process-buffer proc) - (let ((moving (= (point) (process-mark proc)))) - (save-excursion - (goto-char (process-mark proc)) - (insert string) - (set-marker (process-mark proc) (point)) - (comint-watch-for-password-prompt string)) - (if moving (goto-char (process-mark proc))))))))) - - -;;; Client: Process Handling - -(defun nrepl--kill-process (proc) - "Attempt to kill PROC tree. -On MS-Windows, using the standard API is highly likely to leave the child -processes still running in the background as orphans. As a workaround, an -attempt is made to delegate the task to the `taskkill` program, which comes -with windows since at least Windows XP, and fallback to the Emacs API if it -can't be found. - -It is expected that the `(process-status PROC)` return value after PROC is -killed is `exit` when `taskkill` is used and `signal` otherwise." - (cond - ((and (eq system-type 'windows-nt) - (process-live-p proc) - (executable-find "taskkill")) - ;; try to use `taskkill` if available - (with-temp-buffer - (call-process-shell-command (format "taskkill /PID %s /T /F" (process-id proc)) - nil (buffer-name) ) - ;; useful for debugging. - ;;(message ":PROCESS-KILL-OUPUT %s" (buffer-string)) - )) - - ((memq system-type '(cygwin windows-nt)) - ;; fallback, this is considered to work better than `kill-process` on - ;; MS-Windows. - (interrupt-process proc)) - - (t (kill-process proc)))) - -(defun nrepl-kill-server-buffer (server-buf) - "Kill SERVER-BUF and its process." - (when (buffer-live-p server-buf) - (let ((proc (get-buffer-process server-buf))) - (when (process-live-p proc) - (set-process-query-on-exit-flag proc nil) - (nrepl--kill-process proc)) - (kill-buffer server-buf)))) - -(defun nrepl--maybe-kill-server-buffer (server-buf) - "Kill SERVER-BUF and its process. -Do not kill the server if there is a REPL connected to that server." - (when (buffer-live-p server-buf) - (with-current-buffer server-buf - ;; Don't kill if there is at least one REPL connected to it. - (when (not (seq-find (lambda (b) - (eq (buffer-local-value 'nrepl-server-buffer b) - server-buf)) - (buffer-list))) - (nrepl-kill-server-buffer server-buf))))) - -(defun nrepl-start-client-process (&optional host port server-proc buffer-builder socket-file) - "Create new client process identified by either HOST and PORT or SOCKET-FILE. -If SOCKET-FILE is non-nil, it takes precedence. In remote buffers, HOST -and PORT are taken from the current tramp connection. SERVER-PROC must be -a running nREPL server process within Emacs. BUFFER-BUILDER is a function -of one argument (endpoint returned by `nrepl-connect') which returns a -client buffer. Return the newly created client process." - (let* ((endpoint (if socket-file - (nrepl--unix-connect (expand-file-name socket-file)) - (nrepl-connect host port))) - (client-proc (plist-get endpoint :proc)) - (builder (or buffer-builder (error "`buffer-builder' must be provided"))) - (client-buf (funcall builder endpoint))) - - (set-process-buffer client-proc client-buf) - - (set-process-filter client-proc #'nrepl-client-filter) - (set-process-sentinel client-proc #'nrepl-client-sentinel) - (set-process-coding-system client-proc 'utf-8-unix 'utf-8-unix) - - (process-put client-proc :string-q (queue-create)) - (process-put client-proc :response-q (nrepl-response-queue)) - - (with-current-buffer client-buf - (when-let* ((server-buf (and server-proc (process-buffer server-proc)))) - (setq nrepl-project-dir (buffer-local-value 'nrepl-project-dir server-buf) - nrepl-server-buffer server-buf)) - (setq nrepl-endpoint endpoint - nrepl-tunnel-buffer (when-let* ((tunnel (plist-get endpoint :tunnel))) - (process-buffer tunnel)) - nrepl-pending-requests (make-hash-table :test 'equal) - nrepl-completed-requests (make-hash-table :test 'equal))) - - (with-current-buffer client-buf - (nrepl--init-client-sessions client-proc) - (nrepl--init-capabilities client-buf) - (run-hooks 'nrepl-connected-hook)) - - client-proc)) - -(defun nrepl--init-client-sessions (client) - "Initialize CLIENT connection nREPL sessions. -We create two client nREPL sessions per connection - a main session and a -tooling session. The main session is general purpose and is used for pretty -much every request that needs a session. The tooling session is used only -for functionality that's implemented in terms of the \"eval\" op, so that -eval requests for functionality like pretty-printing won't clobber the -values of *1, *2, etc." - (let* ((client-conn (process-buffer client)) - (response-main (nrepl-sync-request:clone client-conn)) - (response-tooling (nrepl-sync-request:clone client-conn t))) ; t for tooling - (nrepl-dbind-response response-main (new-session err) - (if new-session - (with-current-buffer client-conn - (setq nrepl-session new-session)) - (error "Could not create new session (%s)" err))) - (nrepl-dbind-response response-tooling (new-session err) - (if new-session - (with-current-buffer client-conn - (setq nrepl-tooling-session new-session)) - (error "Could not create new tooling session (%s)" err))))) - -(defun nrepl--init-capabilities (conn-buffer) - "Store locally in CONN-BUFFER the capabilities of nREPL server." - (let ((description (nrepl-sync-request:describe conn-buffer))) - (nrepl-dbind-response description (ops versions aux) - (with-current-buffer conn-buffer - (setq nrepl-ops ops) - (setq nrepl-versions versions) - (setq nrepl-aux aux))))) - -(defun nrepl--clear-client-sessions (conn-buffer) - "Clear information about nREPL sessions in CONN-BUFFER. -CONN-BUFFER refers to a (presumably) dead connection, -which we can eventually reuse." - (with-current-buffer conn-buffer - (setq nrepl-session nil) - (setq nrepl-tooling-session nil))) - - -;;; Client: Response Handling -;; After being decoded, responses (aka, messages from the server) are dispatched -;; to handlers. Handlers are constructed with `nrepl-make-response-handler'. - -(defvar nrepl-err-handler nil - "Evaluation error handler.") - -(defun nrepl--mark-id-completed (id) - "Move ID from `nrepl-pending-requests' to `nrepl-completed-requests'. -It is safe to call this function multiple times on the same ID." - ;; FIXME: This should go away eventually when we get rid of - ;; pending-request hash table - (when-let* ((handler (gethash id nrepl-pending-requests))) - (puthash id handler nrepl-completed-requests) - (remhash id nrepl-pending-requests))) - -(declare-function cider-repl--emit-interactive-output "cider-repl") -(defun nrepl-notify (msg type) - "Handle \"notification\" server request. -MSG is a string to be displayed. TYPE is the type of the message. All -notifications are currently displayed with `message' function and emitted -to the REPL." - (let* ((face (pcase type - ((or "message" `nil) 'font-lock-builtin-face) - ("warning" 'warning) - ("error" 'error))) - (msg (if face - (propertize msg 'face face) - (format "%s: %s" (upcase type) msg)))) - (cider-repl--emit-interactive-output msg (or face 'font-lock-builtin-face)) - (message msg))) - -(defvar cider-buffer-ns) -(defvar cider-print-quota) -(defvar cider-special-mode-truncate-lines) -(declare-function cider-need-input "cider-client") -(declare-function cider-set-buffer-ns "cider-mode") - -(defun nrepl-make-response-handler (buffer value-handler stdout-handler - stderr-handler done-handler - &optional eval-error-handler - content-type-handler - truncated-handler) - "Make a response handler for connection BUFFER. -A handler is a function that takes one argument - response received from -the server process. The response is an alist that contains at least 'id' -and 'session' keys. Other standard response keys are 'value', 'out', 'err', -and 'status'. - -The presence of a particular key determines the type of the response. For -example, if 'value' key is present, the response is of type 'value', if -'out' key is present the response is 'stdout' etc. - -Depending on the type, the handler dispatches the appropriate value to one -of the supplied handlers: VALUE-HANDLER, STDOUT-HANDLER, STDERR-HANDLER, -DONE-HANDLER, EVAL-ERROR-HANDLER, CONTENT-TYPE-HANDLER, and -TRUNCATED-HANDLER. - -Handlers are functions of the buffer and the value they handle, except for -the optional CONTENT-TYPE-HANDLER which should be a function of the buffer, -content, the content-type to be handled as a list `(type attrs)'. - -If the optional EVAL-ERROR-HANDLER is nil, the default `nrepl-err-handler' -is used. If any of the other supplied handlers are nil nothing happens for -the corresponding type of response." - (lambda (response) - (nrepl-dbind-response response (content-type content-transfer-encoding body - value ns out err status id) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (when (and ns (not (derived-mode-p 'clojure-mode))) - (cider-set-buffer-ns ns)))) - (cond ((and content-type content-type-handler) - (funcall content-type-handler buffer - (if (string= content-transfer-encoding "base64") - (base64-decode-string body) - body) - content-type)) - (value - (when value-handler - (funcall value-handler buffer value))) - (out - (when stdout-handler - (funcall stdout-handler buffer out))) - (err - (when stderr-handler - (funcall stderr-handler buffer err))) - (status - (when (and truncated-handler (member "nrepl.middleware.print/truncated" status)) - (let ((warning (format "\n... output truncated to %sB ..." - (file-size-human-readable cider-print-quota)))) - (funcall truncated-handler buffer warning))) - (when (member "notification" status) - (nrepl-dbind-response response (msg type) - (nrepl-notify msg type))) - (when (member "interrupted" status) - (message "Evaluation interrupted.")) - (when (member "eval-error" status) - (funcall (or eval-error-handler nrepl-err-handler))) - (when (member "namespace-not-found" status) - (message "Namespace `%s' not found." ns)) - (when (member "need-input" status) - (cider-need-input buffer)) - (when (member "done" status) - (nrepl--mark-id-completed id) - (when done-handler - (funcall done-handler buffer)))))))) - - -;;; Client: Request Core API - -;; Requests are messages from an nREPL client (like CIDER) to an nREPL server. -;; Requests can be asynchronous (sent with `nrepl-send-request') or -;; synchronous (send with `nrepl-send-sync-request'). The request is a pair list -;; of operation name and operation parameters. The core operations are described -;; at https://github.com/nrepl/nrepl/blob/master/doc/ops.md. CIDER adds -;; many more operations through nREPL middleware. See -;; https://github.com/clojure-emacs/cider-nrepl#supplied-nrepl-middleware for -;; the up-to-date list. - -(defun nrepl-next-request-id (connection) - "Return the next request id for CONNECTION." - (with-current-buffer connection - (number-to-string (cl-incf nrepl-request-counter)))) - -(defun nrepl-send-request (request callback connection &optional tooling) - "Send REQUEST and register response handler CALLBACK using CONNECTION. -REQUEST is a pair list of the form (\"op\" \"operation\" \"par1-name\" -\"par1\" ... ). See the code of `nrepl-request:clone', -`nrepl-request:stdin', etc. This expects that the REQUEST does not have a -session already in it. This code will add it as appropriate to prevent -connection/session drift. -Return the ID of the sent message. -Optional argument TOOLING Set to t if desiring the tooling session rather than -the standard session." - (with-current-buffer connection - (when-let* ((session (if tooling nrepl-tooling-session nrepl-session))) - (setq request (append request `("session" ,session)))) - (let* ((id (nrepl-next-request-id connection)) - (request (cons 'dict (lax-plist-put request "id" id))) - (message (nrepl-bencode request))) - (nrepl-log-message request 'request) - (puthash id callback nrepl-pending-requests) - (process-send-string nil message) - id))) - -(defvar nrepl-ongoing-sync-request nil - "Dynamically bound to t while a sync request is ongoing.") - -(declare-function cider-repl-emit-interactive-stderr "cider-repl") -(declare-function cider--render-stacktrace-causes "cider-eval") - -(defun nrepl-send-sync-request (request connection &optional abort-on-input tooling) - "Send REQUEST to the nREPL server synchronously using CONNECTION. -Hold till final \"done\" message has arrived and join all response messages -of the same \"op\" that came along. -If ABORT-ON-INPUT is non-nil, the function will return nil at the first -sign of user input, so as not to hang the interface. -If TOOLING, use the tooling session rather than the standard session." - (let* ((time0 (current-time)) - (response (cons 'dict nil)) - (nrepl-ongoing-sync-request t) - status) - (nrepl-send-request request - (lambda (resp) (nrepl--merge response resp)) - connection - tooling) - (while (and (not (member "done" status)) - (not (and abort-on-input - (input-pending-p)))) - (setq status (nrepl-dict-get response "status")) - ;; If we get a need-input message then the repl probably isn't going - ;; anywhere, and we'll just timeout. So we forward it to the user. - (if (member "need-input" status) - (progn (cider-need-input (current-buffer)) - ;; If the used took a few seconds to respond, we might - ;; unnecessarily timeout, so let's reset the timer. - (setq time0 (current-time))) - ;; break out in case we don't receive a response for a while - (when (and nrepl-sync-request-timeout - (time-less-p - nrepl-sync-request-timeout - (time-subtract nil time0))) - (error "Sync nREPL request timed out %s after %s secs" request nrepl-sync-request-timeout))) - ;; Clean up the response, otherwise we might repeatedly ask for input. - (nrepl-dict-put response "status" (remove "need-input" status)) - (accept-process-output nil 0.01)) - ;; If we couldn't finish, return nil. - (when (member "done" status) - (nrepl-dbind-response response (ex err eval-error pp-stacktrace id) - (when (and ex err) - (cond (eval-error (funcall nrepl-err-handler)) - (pp-stacktrace (cider--render-stacktrace-causes - pp-stacktrace (remove "done" status))))) ;; send the error type - (when id - (with-current-buffer connection - (nrepl--mark-id-completed id))) - response)))) - -(defun nrepl-request:stdin (input callback connection) - "Send a :stdin request with INPUT using CONNECTION. -Register CALLBACK as the response handler." - (nrepl-send-request `("op" "stdin" - "stdin" ,input) - callback - connection)) - -(defun nrepl-request:interrupt (pending-request-id callback connection) - "Send an :interrupt request for PENDING-REQUEST-ID. -The request is dispatched using CONNECTION. -Register CALLBACK as the response handler." - (nrepl-send-request `("op" "interrupt" - "interrupt-id" ,pending-request-id) - callback - connection)) - -(define-minor-mode cider-enlighten-mode nil - :lighter (cider-mode " light") - :global t) - -(defun nrepl--eval-request (input &optional ns line column) - "Prepare :eval request message for INPUT. -NS provides context for the request. -If LINE and COLUMN are non-nil and current buffer is a file buffer, \"line\", -\"column\" and \"file\" are added to the message." - (nconc (and ns `("ns" ,ns)) - `("op" "eval" - "code" ,(substring-no-properties input)) - (when cider-enlighten-mode - '("enlighten" "true")) - (let ((file (or (buffer-file-name) (buffer-name)))) - (when (and line column file) - `("file" ,file - "line" ,line - "column" ,column))))) - -(defun nrepl-request:eval (input callback connection &optional ns line column additional-params tooling) - "Send the request INPUT and register the CALLBACK as the response handler. -The request is dispatched via CONNECTION. If NS is non-nil, -include it in the request. LINE and COLUMN, if non-nil, define the position -of INPUT in its buffer. A CONNECTION uniquely determines two connections -available: the standard interaction one and the tooling session. If the -tooling is desired, set TOOLING to true. -ADDITIONAL-PARAMS is a plist to be appended to the request message." - (nrepl-send-request (append (nrepl--eval-request input ns line column) additional-params) - callback - connection - tooling)) - -(defun nrepl-sync-request:clone (connection &optional tooling) - "Sent a :clone request to create a new client session. -The request is dispatched via CONNECTION. -Optional argument TOOLING Tooling is set to t if wanting the tooling session -from CONNECTION." - (nrepl-send-sync-request '("op" "clone") - connection - nil tooling)) - -(defun nrepl-sync-request:close (connection) - "Sent a :close request to close CONNECTION's SESSION." - (nrepl-send-sync-request '("op" "close") connection) - (nrepl-send-sync-request '("op" "close") connection nil t)) ;; close tooling session - -(defun nrepl-sync-request:describe (connection) - "Perform :describe request for CONNECTION and SESSION." - (nrepl-send-sync-request '("op" "describe") - connection)) - -(defun nrepl-sync-request:ls-sessions (connection) - "Perform :ls-sessions request for CONNECTION." - (nrepl-send-sync-request '("op" "ls-sessions") connection)) - -(defun nrepl-sync-request:ls-middleware (connection) - "Perform :ls-middleware request for CONNECTION." - (nrepl-send-sync-request '("op" "ls-middleware") connection)) - -(defun nrepl-sync-request:eval (input connection &optional ns tooling) - "Send the INPUT to the nREPL server synchronously. -The request is dispatched via CONNECTION. -If NS is non-nil, include it in the request -If TOOLING is non-nil the evaluation is done using the tooling nREPL -session." - (nrepl-send-sync-request - (nrepl--eval-request input ns) - connection - nil - tooling)) - -(defun nrepl-sessions (connection) - "Get a list of active sessions on the nREPL server using CONNECTION." - (nrepl-dict-get (nrepl-sync-request:ls-sessions connection) "sessions")) - -(defun nrepl-middleware (connection) - "Get a list of middleware on the nREPL server using CONNECTION." - (nrepl-dict-get (nrepl-sync-request:ls-middleware connection) "middleware")) - - -;;; Server - -;; The server side process is started by `nrepl-start-server-process' and has a -;; very simple filter that pipes its output directly into its process buffer -;; (*nrepl-server*). The main purpose of this process is to start the actual -;; nrepl communication client (`nrepl-client-filter') when the message "nREPL -;; server started on port ..." is detected. - -;; internal variables used for state transfer between nrepl-start-server-process -;; and nrepl-server-filter. -(defvar-local nrepl-on-port-callback nil) - -(defun nrepl-server-p (buffer-or-process) - "Return t if BUFFER-OR-PROCESS is an nREPL server." - (let ((buffer (if (processp buffer-or-process) - (process-buffer buffer-or-process) - buffer-or-process))) - (buffer-local-value 'nrepl-is-server buffer))) - -(defun nrepl-start-server-process (directory cmd on-port-callback) - "Start nREPL server process in DIRECTORY using shell command CMD. -Return a newly created process. Set `nrepl-server-filter' as the process -filter, which starts REPL process with its own buffer once the server has -started. ON-PORT-CALLBACK is a function of one argument (server buffer) -which is called by the process filter once the port of the connection has -been determined." - (let* ((default-directory (or directory default-directory)) - (serv-buf (get-buffer-create - (nrepl-server-buffer-name - `(:project-dir ,default-directory))))) - (with-current-buffer serv-buf - (setq nrepl-is-server t - nrepl-project-dir default-directory - nrepl-server-command cmd - nrepl-on-port-callback on-port-callback)) - (let ((serv-proc (start-file-process-shell-command - "nrepl-server" serv-buf cmd))) - (set-process-filter serv-proc #'nrepl-server-filter) - (set-process-sentinel serv-proc #'nrepl-server-sentinel) - (set-process-coding-system serv-proc 'utf-8-unix 'utf-8-unix) - (message "[nREPL] Starting server via %s" - (propertize cmd 'face 'font-lock-keyword-face)) - serv-proc))) - -(defconst nrepl-listening-unix-address-regexp - (rx - (and "nREPL server listening on" (+ " ") - "nrepl+unix:" (group-n 1 (+ not-newline))))) - -(defconst nrepl-listening-inet-address-regexp - (rx (or - ;; standard - (and "nREPL server started on port " (group-n 1 (+ (any "0-9")))) - ;; babashka - (and "Started nREPL server at " - (group-n 2 (+? any)) ":" (group-n 1 (+ (any "0-9")))))) - "A regexp to search an nREPL's stdout for the address it is listening on. - -If it matches, the address components can be extracted using the following -match groups: -1 for the port, and -2 for the host (babashka only).") - -(defun cider--process-plist-put (proc prop val) - "Change value in PROC's plist of PROP to VAL. -Value is changed using `plist-put`, of which see." - (thread-first - proc - (process-plist) - (plist-put prop val) - (thread-last (set-process-plist proc)))) - -(defun nrepl-server-filter (process output) - "Process nREPL server output from PROCESS contained in OUTPUT. - -The PROCESS plist is updated as (non-exhaustive list): - -:cider--nrepl-server-ready set to t when the server is successfully brought -up." - ;; In Windows this can be false: - (let ((server-buffer (process-buffer process))) - (when (buffer-live-p server-buffer) - (with-current-buffer server-buffer - ;; auto-scroll on new output - (let ((moving (= (point) (process-mark process)))) - (save-excursion - (goto-char (process-mark process)) - (insert output) - (ansi-color-apply-on-region (process-mark process) (point)) - (set-marker (process-mark process) (point))) - (when moving - (goto-char (process-mark process)) - (when-let* ((win (get-buffer-window))) - (set-window-point win (point))))) - ;; detect the port the server is listening on from its output - (when (null nrepl-endpoint) - (let ((end (cond - ((string-match nrepl-listening-unix-address-regexp output) - (let ((path (match-string 1 output))) - (message "[nREPL] server started on nrepl+unix:%s" path) - (list :host "local-unix-domain-socket" - :port path - :socket-file path))) - ((string-match nrepl-listening-inet-address-regexp output) - (let ((host (or (match-string 2 output) - (file-remote-p default-directory 'host) - "localhost")) - (port (string-to-number (match-string 1 output)))) - (message "[nREPL] server started on %s" port) - (list :host host :port port)))))) - (when end - (setq nrepl-endpoint end) - (cider--process-plist-put process :cider--nrepl-server-ready t) - (when nrepl-on-port-callback - (funcall nrepl-on-port-callback (process-buffer process)))))))))) - -(defmacro emacs-bug-46284/when-27.1-windows-nt (&rest body) - "Only evaluate BODY when Emacs bug #46284 has been detected." - (when (and (eq system-type 'windows-nt) - (string= emacs-version "27.1")) - (cons 'progn body))) - - -(declare-function cider--close-connection "cider-connection") -(defun nrepl-server-sentinel (process event) - "Handle nREPL server PROCESS EVENT. -If the nREPL PROCESS failed to initiate and encountered a fatal EVENT -signal, raise an 'error'. Additionally, if the EVENT signal is SIGHUP, -close any existing client connections." - ;; only interested on fatal signals. - (when (not (process-live-p process)) - (emacs-bug-46284/when-27.1-windows-nt - ;; There is a bug in emacs 27.1 (since fixed) that sets all EVENT - ;; descriptions for signals to "unknown signal". We correct this by - ;; resetting it back to its canonical value. - (when (eq (process-status process) 'signal) - (cl-case (process-exit-status process) - ;; SIGHUP==1 emacs nt/inc/ms-w32.h - (1 (setq event "Hangup")) - ;; SIGINT==2 x86_64-w64-mingw32/include/signal.h - (2 (setq event "Interrupt")) - ;; SIGKILL==9 emacs nt/inc/ms-w32.h - (9 (setq event "Killed"))))) - (let* ((server-buffer (process-buffer process)) - (clients (seq-filter (lambda (b) - (eq (buffer-local-value 'nrepl-server-buffer b) - server-buffer)) - (buffer-list)))) - - ;; see https://github.com/clojure-emacs/cider/pull/3333 - (when (string-match-p "^hangup" event) - (mapc #'cider--close-connection clients)) - - (if (process-get process :cider--nrepl-server-ready) - (progn - (when server-buffer (kill-buffer server-buffer)) - (message "nREPL server exited.")) - (let ((problem (when (and server-buffer (buffer-live-p server-buffer)) - (with-current-buffer server-buffer - (buffer-substring (point-min) (point-max)))))) - (error "Could not start nREPL server: %s (%S)" problem (string-trim event))))))) - - -;;; Messages - -(defcustom nrepl-log-messages nil - "If non-nil, log protocol messages to an nREPL messages buffer. -This is extremely useful for debug purposes, as it allows you to inspect -the communication between Emacs and an nREPL server. Enabling the logging -might have a negative impact on performance, so it's not recommended to -keep it enabled unless you need to debug something." - :type 'boolean - :safe #'booleanp) - -(defconst nrepl-message-buffer-max-size 1000000 - "Maximum size for the nREPL message buffer. -Defaults to 1000000 characters, which should be an insignificant -memory burden, while providing reasonable history.") - -(defconst nrepl-message-buffer-reduce-denominator 4 - "Divisor by which to reduce message buffer size. -When the maximum size for the nREPL message buffer is exceeded, the size of -the buffer is reduced by one over this value. Defaults to 4, so that 1/4 -of the buffer is removed, which should ensure the buffer's maximum is -reasonably utilized, while limiting the number of buffer shrinking -operations.") - -(defvar nrepl-messages-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "n") #'next-line) - (define-key map (kbd "p") #'previous-line) - (define-key map (kbd "TAB") #'forward-button) - (define-key map (kbd "RET") #'nrepl-log-expand-button) - (define-key map (kbd "e") #'nrepl-log-expand-button) - (define-key map (kbd "E") #'nrepl-log-expand-all-buttons) - (define-key map (kbd "") #'backward-button) - map)) - -(define-derived-mode nrepl-messages-mode special-mode "nREPL Messages" - "Major mode for displaying nREPL messages. - -\\{nrepl-messages-mode-map}" - (when cider-special-mode-truncate-lines - (setq-local truncate-lines t)) - (setq-local sesman-system 'CIDER) - (setq-local electric-indent-chars nil) - (setq-local comment-start ";") - (setq-local comment-end "") - (setq-local paragraph-start "(-->\\|(<--") - (setq-local paragraph-separate "(<--")) - -(defun nrepl-decorate-msg (msg type) - "Decorate nREPL MSG according to its TYPE." - (pcase type - (`request (cons '--> (cdr msg))) - (`response (cons '<-- (cdr msg))))) - -(defun nrepl-log-message (msg type) - "Log the nREPL MSG. -TYPE is either request or response. The message is logged to a buffer -described by `nrepl-message-buffer-name-template'." - (when nrepl-log-messages - ;; append a time-stamp to the message before logging it - ;; the time-stamps are quite useful for debugging - (setq msg (cons (car msg) - (lax-plist-put (cdr msg) "time-stamp" - (format-time-string "%Y-%m-%0d %H:%M:%S.%N")))) - (with-current-buffer (nrepl-messages-buffer (current-buffer)) - (setq buffer-read-only nil) - (when (> (buffer-size) nrepl-message-buffer-max-size) - (goto-char (/ (buffer-size) nrepl-message-buffer-reduce-denominator)) - (re-search-forward "^(" nil t) - (delete-region (point-min) (- (point) 1))) - (goto-char (point-max)) - (nrepl-log-pp-object (nrepl-decorate-msg msg type) - (nrepl-log--message-color (lax-plist-get (cdr msg) "id")) - t) - (when-let* ((win (get-buffer-window))) - (set-window-point win (point-max))) - (setq buffer-read-only t)))) - -(defun nrepl-toggle-message-logging () - "Toggle the value of `nrepl-log-messages' between nil and t. - -This in effect enables or disables the logging of nREPL messages." - (interactive) - (setq nrepl-log-messages (not nrepl-log-messages)) - (if nrepl-log-messages - (message "nREPL message logging enabled") - (message "nREPL message logging disabled"))) - -(defcustom nrepl-message-colors - '("red" "brown" "coral" "orange" "green" "deep sky blue" "blue" "dark violet") - "Colors used in the messages buffer." - :type '(repeat color)) - -(defun nrepl-log-expand-button (&optional button) - "Expand the objects hidden in BUTTON's :nrepl-object property. -BUTTON defaults the button at point." - (interactive) - (if-let* ((button (or button (button-at (point))))) - (let* ((start (overlay-start button)) - (end (overlay-end button)) - (obj (overlay-get button :nrepl-object)) - (inhibit-read-only t)) - (save-excursion - (goto-char start) - (delete-overlay button) - (delete-region start end) - (nrepl-log-pp-object obj) - (delete-char -1))) - (error "No button at point"))) - -(defun nrepl-log-expand-all-buttons () - "Expand all buttons in nREPL log buffer." - (interactive) - (if (not (eq major-mode 'nrepl-messages-mode)) - (user-error "Not in a `nrepl-messages-mode'") - (save-excursion - (let* ((pos (point-min)) - (button (next-button pos))) - (while button - (setq pos (overlay-start button)) - (nrepl-log-expand-button button) - (setq button (next-button pos))))))) - -(defun nrepl-log--expand-button-mouse (event) - "Expand the text hidden under overlay button. -EVENT gives the button position on window." - (interactive "e") - (pcase (elt event 1) - (`(,window ,_ ,_ ,_ ,_ ,point . ,_) - (with-selected-window window - (nrepl-log-expand-button (button-at point)))))) - -(defun nrepl-log-insert-button (label object) - "Insert button with LABEL and :nrepl-object property as OBJECT." - (insert-button label - :nrepl-object object - 'action #'nrepl-log-expand-button - 'face 'link - 'help-echo "RET: Expand object." - ;; Workaround for bug#1568 (don't use local-map here; it - ;; overwrites major mode map.) - 'keymap `(keymap (mouse-1 . nrepl-log--expand-button-mouse))) - (insert "\n")) - -(defun nrepl-log--message-color (id) - "Return the color to use when pretty-printing the nREPL message with ID. -If ID is nil, return nil." - (when id - (thread-first - (string-to-number id) - (mod (length nrepl-message-colors)) - (nth nrepl-message-colors)))) - -(defun nrepl-log--pp-listlike (object &optional foreground button) - "Pretty print nREPL list like OBJECT. -FOREGROUND and BUTTON are as in `nrepl-log-pp-object'." - (cl-flet ((color (str) - (propertize str 'face - (append '(:weight ultra-bold) - (when foreground `(:foreground ,foreground)))))) - (let ((head (format "(%s" (car object)))) - (insert (color head)) - (if (null (cdr object)) - (insert ")\n") - (let* ((indent (+ 2 (- (current-column) (length head)))) - (sorted-pairs (sort (seq-partition (cl-copy-list (cdr object)) 2) - (lambda (a b) - (string< (car a) (car b))))) - (name-lengths (seq-map (lambda (pair) (length (car pair))) sorted-pairs)) - (longest-name (seq-max name-lengths)) - ;; Special entries are displayed first - (specialq (lambda (pair) (member (car pair) '("id" "op" "session" "time-stamp")))) - (special-pairs (seq-filter specialq sorted-pairs)) - (not-special-pairs (seq-remove specialq sorted-pairs)) - (all-pairs (seq-concatenate 'list special-pairs not-special-pairs)) - (sorted-object (apply #'seq-concatenate 'list all-pairs))) - (insert "\n") - (cl-loop for l on sorted-object by #'cddr - do (let ((indent-str (make-string indent ?\s)) - (name-str (propertize (car l) 'face - ;; Only highlight top-level keys. - (unless (eq (car object) 'dict) - 'font-lock-keyword-face))) - (spaces-str (make-string (- longest-name (length (car l))) ?\s))) - (insert (format "%s%s%s " indent-str name-str spaces-str)) - (nrepl-log-pp-object (cadr l) nil button))) - (when (eq (car object) 'dict) - (delete-char -1)) - (insert (color ")\n"))))))) - -(defun nrepl-log-pp-object (object &optional foreground button) - "Pretty print nREPL OBJECT, delimited using FOREGROUND. -If BUTTON is non-nil, try making a button from OBJECT instead of inserting -it into the buffer." - (let ((min-dict-fold-size 1) - (min-list-fold-size 10) - (min-string-fold-size 60)) - (if-let* ((head (car-safe object))) - ;; list-like objects - (cond - ;; top level dicts (always expanded) - ((memq head '(<-- -->)) - (nrepl-log--pp-listlike object foreground button)) - ;; inner dicts - ((eq head 'dict) - (if (and button (> (length object) min-dict-fold-size)) - (nrepl-log-insert-button "(dict ...)" object) - (nrepl-log--pp-listlike object foreground button))) - ;; lists - (t - (if (and button (> (length object) min-list-fold-size)) - (nrepl-log-insert-button (format "(%s ...)" (prin1-to-string head)) object) - (pp object (current-buffer))))) - ;; non-list objects - (if (stringp object) - (if (and button (> (length object) min-string-fold-size)) - (nrepl-log-insert-button (format "\"%s...\"" (substring object 0 min-string-fold-size)) object) - (insert (prin1-to-string object) "\n")) - (pp object (current-buffer)) - (insert "\n"))))) - -(declare-function cider--gather-connect-params "cider-connection") -(defun nrepl-messages-buffer (conn) - "Return or create the buffer for CONN. -The default buffer name is *nrepl-messages connection*." - (with-current-buffer conn - (or (and (buffer-live-p nrepl-messages-buffer) - nrepl-messages-buffer) - (setq nrepl-messages-buffer - (let ((buffer (get-buffer-create - (nrepl-messages-buffer-name - (cider--gather-connect-params))))) - (with-current-buffer buffer - (buffer-disable-undo) - (nrepl-messages-mode) - buffer)))))) - -(defun nrepl-error-buffer () - "Return or create the buffer. -The default buffer name is *nrepl-error*." - (or (get-buffer nrepl-error-buffer-name) - (let ((buffer (get-buffer-create nrepl-error-buffer-name))) - (with-current-buffer buffer - (buffer-disable-undo) - (nrepl--ensure-fundamental-mode) - buffer)))) - -(defun nrepl-log-error (msg) - "Log the given MSG to the buffer given by `nrepl-error-buffer'." - (with-current-buffer (nrepl-error-buffer) - (setq buffer-read-only nil) - (goto-char (point-max)) - (insert msg) - (when-let* ((win (get-buffer-window))) - (set-window-point win (point-max))) - (setq buffer-read-only t))) - -(make-obsolete 'nrepl-default-client-buffer-builder nil "0.18") - -(provide 'nrepl-client) - -;;; nrepl-client.el ends here diff --git a/elpa/cider-20230707.640/nrepl-dict.el b/elpa/cider-20230707.640/nrepl-dict.el deleted file mode 100644 index b6b2e980..00000000 --- a/elpa/cider-20230707.640/nrepl-dict.el +++ /dev/null @@ -1,205 +0,0 @@ -;;; nrepl-dict.el --- Dictionary functions for Clojure nREPL -*- lexical-binding: t -*- - -;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov -;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors -;; -;; Author: Tim King -;; Phil Hagelberg -;; Bozhidar Batsov -;; Artur Malabarba -;; Hugo Duncan -;; Steve Purcell -;; -;; 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 . -;; -;; This file is not part of GNU Emacs. -;; -;;; Commentary: -;; -;; Provides functions to interact with and create `nrepl-dict's. These are -;; simply plists with an extra element at the head. - -;;; Code: -(require 'cl-lib) - - -(defun nrepl-dict (&rest key-vals) - "Create nREPL dict from KEY-VALS." - (cons 'dict key-vals)) - -(defun nrepl-dict-from-hash (hash) - "Create nREPL dict from HASH." - (let ((dict (nrepl-dict))) - (maphash (lambda (k v) (nrepl-dict-put dict k v)) hash) - dict)) - -(defun nrepl-dict-p (object) - "Return t if OBJECT is an nREPL dict." - (and (listp object) - (eq (car object) 'dict))) - -(defun nrepl-dict-empty-p (dict) - "Return t if nREPL dict DICT is empty." - (null (cdr dict))) - -(defun nrepl-dict-contains (dict key) - "Return nil if nREPL dict DICT doesn't contain KEY. -If DICT does contain KEY, then a non-nil value is returned. Due to the -current implementation, this return value is the tail of DICT's key-list -whose car is KEY. Comparison is done with `equal'." - (member key (nrepl-dict-keys dict))) - -(defun nrepl-dict-get (dict key &optional default) - "Get from DICT value associated with KEY, optional DEFAULT if KEY not in DICT. -If dict is nil, return nil. If DEFAULT not provided, and KEY not in DICT, -return nil. If DICT is not an nREPL dict object, an error is thrown." - (when dict - (if (nrepl-dict-p dict) - (if (nrepl-dict-contains dict key) - (lax-plist-get (cdr dict) key) - default) - (error "Not an nREPL dict object: %s" dict)))) - -(defun nrepl-dict-put (dict key value) - "Associate in DICT, KEY to VALUE. -Return new dict. Dict is modified by side effects." - (if (null dict) - `(dict ,key ,value) - (if (not (nrepl-dict-p dict)) - (error "Not an nREPL dict object: %s" dict) - (setcdr dict (lax-plist-put (cdr dict) key value)) - dict))) - -(defun nrepl-dict-keys (dict) - "Return all the keys in the nREPL DICT." - (if (nrepl-dict-p dict) - (cl-loop for l on (cdr dict) by #'cddr - collect (car l)) - (error "Not an nREPL dict"))) - -(defun nrepl-dict-vals (dict) - "Return all the values in the nREPL DICT." - (if (nrepl-dict-p dict) - (cl-loop for l on (cdr dict) by #'cddr - collect (cadr l)) - (error "Not an nREPL dict"))) - -(defun nrepl-dict-map (fn dict) - "Map FN on nREPL DICT. -FN must accept two arguments key and value." - (if (nrepl-dict-p dict) - (cl-loop for l on (cdr dict) by #'cddr - collect (funcall fn (car l) (cadr l))) - (error "Not an nREPL dict"))) - -(defun nrepl-dict-merge (dict1 dict2) - "Destructively merge DICT2 into DICT1. -Keys in DICT2 override those in DICT1." - (let ((base (or dict1 '(dict)))) - (nrepl-dict-map (lambda (k v) - (nrepl-dict-put base k v)) - (or dict2 '(dict))) - base)) - -(defun nrepl-dict-get-in (dict keys) - "Return the value in a nested DICT. -KEYS is a list of keys. Return nil if any of the keys is not present or if -any of the values is nil." - (let ((out dict)) - (while (and keys out) - (setq out (nrepl-dict-get out (pop keys)))) - out)) - -(defun nrepl-dict-flat-map (function dict) - "Map FUNCTION over DICT and flatten the result. -FUNCTION follows the same restrictions as in `nrepl-dict-map', and it must -also always return a sequence (since the result will be flattened)." - (when dict - (apply #'append (nrepl-dict-map function dict)))) - -(defun nrepl-dict-filter (function dict) - "For all key-values of DICT, return new dict where FUNCTION returns non-nil. - -FUNCTION should be a function taking two arguments, key and value." - (let ((new-map (nrepl-dict)) - (keys (nrepl-dict-keys dict))) - (dolist (key keys) - (let ((val (nrepl-dict-get dict key))) - (when (funcall function key val) - (nrepl-dict-put new-map key val)))) - new-map)) - - -;;; More specific functions -(defun nrepl--cons (car list-or-dict) - "Generic cons of CAR to LIST-OR-DICT." - (if (eq (car list-or-dict) 'dict) - (cons 'dict (cons car (cdr list-or-dict))) - (cons car list-or-dict))) - -(defun nrepl--nreverse (list-or-dict) - "Generic `nreverse' which works on LIST-OR-DICT." - (if (eq (car list-or-dict) 'dict) - (cons 'dict (nreverse (cdr list-or-dict))) - (nreverse list-or-dict))) - -(defun nrepl--push (obj stack) - "Cons OBJ to the top element of the STACK." - ;; stack is assumed to be a list - (if (eq (caar stack) 'dict) - (cons (cons 'dict (cons obj (cdar stack))) - (cdr stack)) - (cons (if (null stack) - obj - (cons obj (car stack))) - (cdr stack)))) - -(defun nrepl--merge (dict1 dict2 &optional no-join) - "Join nREPL dicts DICT1 and DICT2 in a meaningful way. -String values for non \"id\" and \"session\" keys are concatenated. Lists -are appended. nREPL dicts merged recursively. All other objects are -accumulated into a list. DICT1 is modified destructively and -then returned. -If NO-JOIN is given, return the first non nil dict." - (if no-join - (or dict1 dict2) - (cond ((null dict1) dict2) - ((null dict2) dict1) - ((stringp dict1) (concat dict1 dict2)) - ((nrepl-dict-p dict1) - (nrepl-dict-map - (lambda (k2 v2) - (nrepl-dict-put dict1 k2 - (nrepl--merge (nrepl-dict-get dict1 k2) v2 - (member k2 '("id" "session"))))) - dict2) - dict1) - ((and (listp dict2) (listp dict1)) (append dict1 dict2)) - ((listp dict1) (append dict1 (list dict2))) - (t `(,dict1 ,dict2))))) - - -;;; Dbind -(defmacro nrepl-dbind-response (response keys &rest body) - "Destructure an nREPL RESPONSE dict. -Bind the value of the provided KEYS and execute BODY." - (declare (debug (form (&rest symbolp) body))) - `(let ,(cl-loop for key in keys - collect `(,key (nrepl-dict-get ,response ,(format "%s" key)))) - ,@body)) -(put 'nrepl-dbind-response 'lisp-indent-function 2) - -(provide 'nrepl-dict) - -;;; nrepl-dict.el ends here diff --git a/elpa/cider-20241203.1607/cider-apropos.el b/elpa/cider-20241203.1607/cider-apropos.el new file mode 100644 index 00000000..b94e27ed --- /dev/null +++ b/elpa/cider-20241203.1607/cider-apropos.el @@ -0,0 +1,210 @@ +;;; cider-apropos.el --- Apropos functionality for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2014-2024 Jeff Valk, Bozhidar Batsov and CIDER contributors +;; +;; Author: Jeff Valk + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Apropos functionality for Clojure. + +;;; Code: + +(require 'cider-doc) ; for cider-doc-lookup +(require 'cider-find) ; for cider--find-var +(require 'cider-util) +(require 'subr-x) +(require 'cider-connection) ; for cider-ensure-connected + +(require 'cider-client) +(require 'cider-popup) +(require 'nrepl-dict) + +(require 'apropos) +(require 'button) + +(defconst cider-apropos-buffer "*cider-apropos*") + +(defcustom cider-apropos-actions '(("display-doc" . cider-doc-lookup) + ("find-def" . cider--find-var) + ("lookup-on-clojuredocs" . cider-clojuredocs-lookup)) + "Controls the actions to be applied on the symbol found by an apropos search. +The first action key in the list will be selected as default. If the list +contains only one action key, the associated action function will be +applied automatically. An action function can be any function that receives +the symbol found by the apropos search as argument." + :type '(alist :key-type string :value-type function) + :group 'cider + :package-version '(cider . "0.13.0")) + +(define-button-type 'apropos-special-form + 'apropos-label "Special form" + 'apropos-short-label "s" + 'face 'font-lock-keyword-face + 'help-echo "mouse-2, RET: Display more help on this special form" + 'follow-link t + 'action (lambda (button) + (describe-function (button-get button 'apropos-symbol)))) + +(defun cider-apropos-doc (button) + "Display documentation for the symbol represented at BUTTON." + (cider-doc-lookup (button-get button 'apropos-symbol))) + +(defun cider-apropos-summary (query ns docs-p include-private-p case-sensitive-p) + "Return a short description for the performed apropos search. + +QUERY can be a regular expression list of space-separated words +\(e.g take while) which will be converted to a regular expression +\(like take.+while) automatically behind the scenes. The search may be +limited to the namespace NS, and may optionally search doc strings +\(based on DOCS-P), include private vars (based on INCLUDE-PRIVATE-P), +and be case-sensitive (based on CASE-SENSITIVE-P)." + (concat (if case-sensitive-p "Case-sensitive " "") + (if docs-p "Documentation " "") + (format "Apropos for %S" query) + (if ns (format " in namespace %S" ns) "") + (if include-private-p + " (public and private symbols)" + " (public symbols only)"))) + +(defun cider-apropos-highlight (doc query) + "Return the DOC string propertized to highlight QUERY matches." + (let ((pos 0)) + (while (string-match query doc pos) + (setq pos (match-end 0)) + (put-text-property (match-beginning 0) + (match-end 0) + 'font-lock-face apropos-match-face doc))) + doc) + +(defvar cider-use-tooltips) +(defun cider-apropos-result (result query docs-p) + "Emit a RESULT matching QUERY into current buffer, formatted for DOCS-P." + (nrepl-dbind-response result (name type doc) + (let* ((label (capitalize (if (string= type "variable") "var" type))) + (help (concat "Display doc for this " (downcase label))) + (props (list 'apropos-symbol name + 'action #'cider-apropos-doc)) + (props (if cider-use-tooltips + (append props (list 'help-echo help)) + props))) + (cider-propertize-region props + (insert-text-button name 'type 'apropos-symbol) + (insert "\n ") + (insert-text-button label 'type (intern (concat "apropos-" type))) + (insert ": ") + (let ((beg (point))) + (if docs-p + (insert (cider-apropos-highlight doc query) "\n") + (insert doc) + (fill-region beg (point)))) + (insert "\n"))))) + +(defun cider-show-apropos (summary results query docs-p) + "Show SUMMARY and RESULTS for QUERY in a pop-up buffer, formatted for DOCS-P." + (with-current-buffer (cider-popup-buffer cider-apropos-buffer 'select 'apropos-mode 'ancillary) + (let ((inhibit-read-only t)) + (if (boundp 'header-line-format) + (setq-local header-line-format summary) + (insert summary "\n\n")) + (dolist (result results) + (cider-apropos-result result query docs-p)) + (goto-char (point-min))))) + +;;;###autoload +(defun cider-apropos (query &optional ns docs-p privates-p case-sensitive-p) + "Show all symbols whose names match QUERY, a regular expression. +QUERY can also be a list of space-separated words (e.g. take while) which +will be converted to a regular expression (like take.+while) automatically +behind the scenes. The search may be limited to the namespace NS, and may +optionally search doc strings (based on DOCS-P), include private vars +\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P)." + (interactive + (cons (read-string "Search for Clojure symbol (a regular expression): ") + (when current-prefix-arg + (list (let ((ns (completing-read "Namespace (default is all): " (cider-sync-request:ns-list)))) + (if (string= ns "") nil ns)) + (y-or-n-p "Search doc strings? ") + (y-or-n-p "Include private symbols? ") + (y-or-n-p "Case-sensitive? "))))) + (cider-ensure-connected) + (cider-ensure-op-supported "apropos") + (if-let* ((summary (cider-apropos-summary + query ns docs-p privates-p case-sensitive-p)) + (results (cider-sync-request:apropos query ns docs-p privates-p case-sensitive-p))) + (cider-show-apropos summary results query docs-p) + (message "No apropos matches for %S" query))) + +;;;###autoload +(defun cider-apropos-documentation () + "Shortcut for (cider-apropos nil t)." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "apropos") + (cider-apropos (read-string "Search for Clojure documentation (a regular expression): ") nil t)) + +(defun cider-apropos-act-on-symbol (symbol) + "Apply selected action on SYMBOL." + (let* ((first-action-key (car (car cider-apropos-actions))) + (action-key (if (= 1 (length cider-apropos-actions)) + first-action-key + (completing-read (format "Choose action to apply to `%s` (default %s): " + symbol first-action-key) + cider-apropos-actions nil nil nil nil first-action-key))) + (action-fn (cdr (assoc action-key cider-apropos-actions)))) + (if action-fn + (funcall action-fn symbol) + (user-error "Unknown action `%s`" action-key)))) + +;;;###autoload +(defun cider-apropos-select (query &optional ns docs-p privates-p case-sensitive-p) + "Similar to `cider-apropos', but presents the results in a completing read. +Show all symbols whose names match QUERY, a regular expression. +QUERY can also be a list of space-separated words (e.g. take while) which +will be converted to a regular expression (like take.+while) automatically +behind the scenes. The search may be limited to the namespace NS, and may +optionally search doc strings (based on DOCS-P), include private vars +\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P)." + (interactive + (cons (read-string "Search for Clojure symbol (a regular expression): ") + (when current-prefix-arg + (list (let ((ns (completing-read "Namespace (default is all): " (cider-sync-request:ns-list)))) + (if (string= ns "") nil ns)) + (y-or-n-p "Search doc strings? ") + (y-or-n-p "Include private symbols? ") + (y-or-n-p "Case-sensitive? "))))) + (cider-ensure-connected) + (cider-ensure-op-supported "apropos") + (if-let* ((summary (cider-apropos-summary + query ns docs-p privates-p case-sensitive-p)) + (results (mapcar (lambda (r) (nrepl-dict-get r "name")) + (cider-sync-request:apropos query ns docs-p privates-p case-sensitive-p)))) + (cider-apropos-act-on-symbol (completing-read (concat summary ": ") results)) + (message "No apropos matches for %S" query))) + +;;;###autoload +(defun cider-apropos-documentation-select () + "Shortcut for (cider-apropos-select nil t)." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "apropos") + (cider-apropos-select (read-string "Search for Clojure documentation (a regular expression): ") nil t)) + +(provide 'cider-apropos) + +;;; cider-apropos.el ends here diff --git a/elpa/cider-20241203.1607/cider-autoloads.el b/elpa/cider-20241203.1607/cider-autoloads.el new file mode 100644 index 00000000..7762315a --- /dev/null +++ b/elpa/cider-20241203.1607/cider-autoloads.el @@ -0,0 +1,712 @@ +;;; cider-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from cider.el + +(autoload 'cider-version "cider" "\ +Display CIDER's version." t) + (autoload 'cider-start-map "cider" "CIDER jack-in and connect keymap." t 'keymap) +(autoload 'cider-jack-in-clj "cider" "\ +Start an nREPL server for the current project and connect to it. +PARAMS is a plist optionally containing :project-dir and :jack-in-cmd. +With the prefix argument, allow editing of the jack in command; with a +double prefix prompt for all these parameters. + +(fn PARAMS)" t) +(autoload 'cider-jack-in-cljs "cider" "\ +Start an nREPL server for the current project and connect to it. +PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and +:cljs-repl-type (e.g. 'shadow, 'node, 'figwheel, etc). + +With the prefix argument, +allow editing of the jack in command; with a double prefix prompt for all +these parameters. + +(fn PARAMS)" t) +(autoload 'cider-jack-in-clj&cljs "cider" "\ +Start an nREPL server and connect with clj and cljs REPLs. +PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and +:cljs-repl-type (e.g. 'shadow, 'node, 'fighweel, etc). + +With the prefix argument, allow for editing of the jack in command; +with a double prefix prompt for all these parameters. + +When SOFT-CLJS-START is non-nil, start cljs REPL +only when the ClojureScript dependencies are met. + +(fn &optional PARAMS SOFT-CLJS-START)" t) +(autoload 'cider-connect-sibling-clj "cider" "\ +Create a Clojure REPL with the same server as OTHER-REPL. +PARAMS is for consistency with other connection commands and is currently +ignored. OTHER-REPL defaults to `cider-current-repl' and in programs can +also be a server buffer, in which case a new session with a REPL for that +server is created. + +(fn PARAMS &optional OTHER-REPL)" t) +(autoload 'cider-connect-sibling-cljs "cider" "\ +Create a ClojureScript REPL with the same server as OTHER-REPL. +PARAMS is a plist optionally containing :cljs-repl-type (e.g. 'node, +'figwheel, 'shadow, etc). + +All other parameters are inferred from the OTHER-REPL. +OTHER-REPL defaults to `cider-current-repl' but in programs can also be a +server buffer, in which case a new session for that server is created. + +(fn PARAMS &optional OTHER-REPL)" t) +(autoload 'cider-connect-clj "cider" "\ +Initialize a Clojure connection to an nREPL server. +PARAMS is a plist optionally containing :host, :port and :project-dir. On +prefix argument, prompt for all the parameters. + +(fn &optional PARAMS)" t) +(autoload 'cider-connect-cljs "cider" "\ +Initialize a ClojureScript connection to an nREPL server. +PARAMS is a plist optionally containing :host, :port, :project-dir and +:cljs-repl-type (e.g. 'shadow, 'node, 'figwheel, etc). + +On prefix, prompt for all the +parameters regardless of their supplied or default values. + +(fn &optional PARAMS)" t) +(autoload 'cider-connect-clj&cljs "cider" "\ +Initialize a Clojure and ClojureScript connection to an nREPL server. +PARAMS is a plist optionally containing :host, :port, :project-dir and +:cljs-repl-type (e.g. 'shadow, 'node, 'figwheel, etc). When SOFT-CLJS-START is +non-nil, don't start if ClojureScript requirements are not met. + +(fn PARAMS &optional SOFT-CLJS-START)" t) +(autoload 'cider "cider" "\ +Start a connection of any type interactively." t) +(defalias 'cider-jack-in #'cider-jack-in-clj) +(defalias 'cider-connect #'cider-connect-clj) +(autoload 'cider-jack-in-universal "cider" "\ +Start and connect to an nREPL server for the current project or ARG project id. + +If a project is found in current dir, call `cider-jack-in' passing ARG as +first parameter, of which see. Otherwise, ask user which project type to +start an nREPL server and connect to without a project. + +But if invoked with a numeric prefix ARG, then start an nREPL server for +the project type denoted by ARG number and connect to it, even if there is +no project for it in the current dir. + +The supported project tools and their assigned numeric prefix ids are +sourced from `cider-jack-in-universal-options', of which see. + +You can pass a numeric prefix argument n with `M-n` or `C-u n`. + +For example, to jack in to leiningen which is assigned to prefix arg 2 type + +M-2 \\[cider-jack-in-universal]. + +(fn ARG)" t) +(autoload 'cider--setup-clojure-major-mode "cider" "\ +Setup Cider key bindings on a Clojure mode's MODE-MAP and hooks in MODE-HOOK. + +(fn MODE-MAP MODE-HOOK)") +(with-eval-after-load 'clojure-mode (cider--setup-clojure-major-mode clojure-mode-map 'clojure-mode-hook)) +(with-eval-after-load 'clojure-ts-mode (cider--setup-clojure-major-mode (with-suppressed-warnings ((free-vars clojure-ts-mode-map)) clojure-ts-mode-map) 'clojure-ts-mode-hook)) +(register-definition-prefixes "cider" '("cider-")) + + +;;; Generated autoloads from cider-apropos.el + +(autoload 'cider-apropos "cider-apropos" "\ +Show all symbols whose names match QUERY, a regular expression. +QUERY can also be a list of space-separated words (e.g. take while) which +will be converted to a regular expression (like take.+while) automatically +behind the scenes. The search may be limited to the namespace NS, and may +optionally search doc strings (based on DOCS-P), include private vars +(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P). + +(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t) +(autoload 'cider-apropos-documentation "cider-apropos" "\ +Shortcut for (cider-apropos nil t)." t) +(autoload 'cider-apropos-select "cider-apropos" "\ +Similar to `cider-apropos', but presents the results in a completing read. +Show all symbols whose names match QUERY, a regular expression. +QUERY can also be a list of space-separated words (e.g. take while) which +will be converted to a regular expression (like take.+while) automatically +behind the scenes. The search may be limited to the namespace NS, and may +optionally search doc strings (based on DOCS-P), include private vars +(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P). + +(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t) +(autoload 'cider-apropos-documentation-select "cider-apropos" "\ +Shortcut for (cider-apropos-select nil t)." t) +(register-definition-prefixes "cider-apropos" '("apropos-special-form" "cider-")) + + +;;; Generated autoloads from cider-browse-ns.el + +(autoload 'cider-browse-ns "cider-browse-ns" "\ +List all NAMESPACE's vars in BUFFER. + +(fn NAMESPACE)" t) +(autoload 'cider-browse-ns-all "cider-browse-ns" "\ +List all loaded namespaces in BUFFER." t) +(register-definition-prefixes "cider-browse-ns" '("cider-browse-ns-")) + + +;;; Generated autoloads from cider-browse-spec.el + +(autoload 'cider-browse-spec "cider-browse-spec" "\ +Browse SPEC definition. + +(fn SPEC)" t) +(autoload 'cider-browse-spec-all "cider-browse-spec" "\ +Open list of specs in a popup buffer. + +With a prefix argument ARG, prompts for a regexp to filter specs. +No filter applied if the regexp is the empty string. + +(fn &optional ARG)" t) +(register-definition-prefixes "cider-browse-spec" '("cider-")) + + +;;; Generated autoloads from cider-cheatsheet.el + +(autoload 'cider-cheatsheet-select "cider-cheatsheet" "\ +Navigate cheatsheet sections and show documentation for selected var. + +With a prefix argument FLAT, represent each candidate as a full path to var. + +(fn &optional FLAT)" t) +(autoload 'cider-cheatsheet "cider-cheatsheet" "\ +Display cheatsheet in a popup buffer." t) +(register-definition-prefixes "cider-cheatsheet" '("cider-cheatsheet-")) + + +;;; Generated autoloads from cider-classpath.el + +(autoload 'cider-classpath "cider-classpath" "\ +List all classpath entries." t) +(autoload 'cider-open-classpath-entry "cider-classpath" "\ +Open a classpath entry." t) +(register-definition-prefixes "cider-classpath" '("cider-classpath-")) + + +;;; Generated autoloads from cider-client.el + +(register-definition-prefixes "cider-client" '("cider-")) + + +;;; Generated autoloads from cider-clojuredocs.el + +(autoload 'cider-clojuredocs-web "cider-clojuredocs" "\ +Open ClojureDocs documentation in the default web browser. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates. + +(fn &optional ARG)" t) +(autoload 'cider-clojuredocs-refresh-cache "cider-clojuredocs" "\ +Refresh the ClojureDocs cache." t) +(autoload 'cider-clojuredocs "cider-clojuredocs" "\ +Open ClojureDocs documentation in a popup buffer. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates. + +(fn &optional ARG)" t) +(register-definition-prefixes "cider-clojuredocs" '("cider-")) + + +;;; Generated autoloads from cider-common.el + +(register-definition-prefixes "cider-common" '("cider-")) + + +;;; Generated autoloads from cider-completion.el + +(register-definition-prefixes "cider-completion" '("cider-")) + + +;;; Generated autoloads from cider-completion-context.el + +(register-definition-prefixes "cider-completion-context" '("cider-completion-")) + + +;;; Generated autoloads from cider-connection.el + +(register-definition-prefixes "cider-connection" '("cider-")) + + +;;; Generated autoloads from cider-debug.el + +(autoload 'cider-debug-defun-at-point "cider-debug" "\ +Instrument the \"top-level\" expression at point. +If it is a defn, dispatch the instrumented definition. Otherwise, +immediately evaluate the instrumented expression. + +While debugged code is being evaluated, the user is taken through the +source code and displayed the value of various expressions. At each step, +a number of keys will be prompted to the user." t) +(register-definition-prefixes "cider-debug" '("cider-")) + + +;;; Generated autoloads from cider-doc.el + +(register-definition-prefixes "cider-doc" '("cider-")) + + +;;; Generated autoloads from cider-docstring.el + +(register-definition-prefixes "cider-docstring" '("cider-")) + + +;;; Generated autoloads from cider-eldoc.el + +(register-definition-prefixes "cider-eldoc" '("cider-")) + + +;;; Generated autoloads from cider-eval.el + +(register-definition-prefixes "cider-eval" '("cider-")) + + +;;; Generated autoloads from cider-find.el + +(autoload 'cider-find-var "cider-find" "\ +Find definition for VAR at LINE. +Prompt according to prefix ARG and `cider-prompt-for-symbol'. +A single or double prefix argument inverts the meaning of +`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes +the results to be displayed in a different window. The default value is +thing at point. + +(fn &optional ARG VAR LINE)" t) +(autoload 'cider-find-dwim-at-mouse "cider-find" "\ +Find and display variable or resource at mouse EVENT. + +(fn EVENT)" t) +(autoload 'cider-find-dwim "cider-find" "\ +Find and display the SYMBOL-FILE at point. +SYMBOL-FILE could be a var or a resource. If thing at point is empty then +show Dired on project. If var is not found, try to jump to resource of the +same name. When called interactively, a prompt is given according to the +variable `cider-prompt-for-symbol'. A single or double prefix argument +inverts the meaning. A prefix of `-' or a double prefix argument causes +the results to be displayed in a different window. A default value of thing +at point is given when prompted. + +(fn SYMBOL-FILE)" t) +(autoload 'cider-find-resource "cider-find" "\ +Find the resource at PATH. +Prompt for input as indicated by the variable `cider-prompt-for-symbol'. +A single or double prefix argument inverts the meaning of +`cider-prompt-for-symbol'. A prefix argument of `-` or a double prefix +argument causes the results to be displayed in other window. The default +value is thing at point. + +(fn PATH)" t) +(autoload 'cider-find-ns "cider-find" "\ +Find the file containing NS. +A prefix ARG of `-` or a double prefix argument causes +the results to be displayed in a different window. + +(fn &optional ARG NS)" t) +(autoload 'cider-find-keyword "cider-find" "\ +Find the namespace of the keyword at point and its primary occurrence there. + +For instance - if the keyword at point is \":cider.demo/keyword\", this command +would find the namespace \"cider.demo\" and afterwards find the primary (most relevant or first) +mention of \"::keyword\" there. + +Prompt according to prefix ARG and `cider-prompt-for-symbol'. +A single or double prefix argument inverts the meaning of +`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes +the results to be displayed in a different window. The default value is +thing at point. + +(fn &optional ARG)" t) +(register-definition-prefixes "cider-find" '("cider-")) + + +;;; Generated autoloads from cider-format.el + +(autoload 'cider-format-region "cider-format" "\ +Format the Clojure code in the current region. +START and END represent the region's boundaries. + +(fn START END)" t) +(autoload 'cider-format-defun "cider-format" "\ +Format the code in the current defun." t) +(autoload 'cider-format-buffer "cider-format" "\ +Format the Clojure code in the current buffer." t) +(autoload 'cider-format-edn-buffer "cider-format" "\ +Format the EDN data in the current buffer." t) +(autoload 'cider-format-edn-region "cider-format" "\ +Format the EDN data in the current region. +START and END represent the region's boundaries. + +(fn START END)" t) +(autoload 'cider-format-edn-last-sexp "cider-format" "\ +Format the EDN data of the last sexp." t) +(register-definition-prefixes "cider-format" '("cider--format-")) + + +;;; Generated autoloads from cider-inspector.el + +(autoload 'cider-inspect-last-sexp "cider-inspector" "\ +Inspect the result of the the expression preceding point." t) +(autoload 'cider-inspect-defun-at-point "cider-inspector" "\ +Inspect the result of the \"top-level\" expression at point." t) +(autoload 'cider-inspect-last-result "cider-inspector" "\ +Inspect the most recent eval result." t) +(autoload 'cider-inspect "cider-inspector" "\ +Inspect the result of the preceding sexp. + +With a prefix argument ARG it inspects the result of the \"top-level\" form. +With a second prefix argument it prompts for an expression to eval and inspect. + +(fn &optional ARG)" t) +(autoload 'cider-inspect-expr "cider-inspector" "\ +Evaluate EXPR in NS and inspect its value. +Interactively, EXPR is read from the minibuffer, and NS the +current buffer's namespace. + +(fn EXPR NS)" t) +(autoload 'cider-sync-request:inspect-last-exception "cider-inspector" "\ +Inspects the exception in the cause stack identified by INDEX, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry. + +(fn INDEX &optional V2)") +(register-definition-prefixes "cider-inspector" '("cider-")) + + +;;; Generated autoloads from cider-jar.el + +(register-definition-prefixes "cider-jar" '("cider-jar-")) + + +;;; Generated autoloads from cider-log.el + + (autoload 'cider-log-info "cider-log-info" "Show the Cider log current log buffer, framework, appender and consumer." t) + (autoload 'cider-log-framework "cider-log" "Show the Cider log framework menu." t) + (autoload 'cider-log-appender "cider-log" "Show the Cider log appender menu." t) + (autoload 'cider-log-consumer "cider-log" "Show the Cider log consumer menu." t) + (autoload 'cider-log-event "cider-log" "Show the Cider log event menu." t) +(autoload 'cider-log-show "cider-log" "\ +Ensures the *cider-log* buffer is visible, +setting up a framework, appender and consumer if necessary. + +Honors the `cider-log-framework-name' customization variable. + +This function is offered as an alternative to workflows +based on `transient-mode'." t) + (autoload 'cider-log "cider-log" "Show the Cider log menu." t) +(register-definition-prefixes "cider-log" '("cider-")) + + +;;; Generated autoloads from cider-macroexpansion.el + +(autoload 'cider-macroexpand-1 "cider-macroexpansion" "\ +Invoke \\=`macroexpand-1\\=` on the expression preceding point. +If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of +\\=`macroexpand-1\\=`. + +(fn &optional PREFIX)" t) +(autoload 'cider-macroexpand-all "cider-macroexpansion" "\ +Invoke \\=`macroexpand-all\\=` on the expression preceding point." t) +(register-definition-prefixes "cider-macroexpansion" '("cider-")) + + +;;; Generated autoloads from cider-mode.el + +(defvar cider-mode-line '(:eval (format " cider[%s]" (cider--modeline-info))) "\ +Mode line lighter for cider mode. + +The value of this variable is a mode line template as in +`mode-line-format'. See Info Node `(elisp)Mode Line Format' for details +about mode line templates. + +Customize this variable to change how cider mode displays its status in the +mode line. The default value displays the current connection. Set this +variable to nil to disable the mode line entirely.") +(custom-autoload 'cider-mode-line "cider-mode" t) +(autoload 'cider--setup-menu-for-clojure-major-mode "cider-mode" "\ +Setup a Cider menu for a Clojure major mode's MODE-MAP. + +This menu works as an easy entry-point into CIDER. Even if cider.el isn't +loaded yet, this will be shown in Clojure buffers next to the Clojure menu. + +(fn MODE-MAP)") +(with-eval-after-load 'clojure-mode (cider--setup-menu-for-clojure-major-mode clojure-mode-map)) +(with-eval-after-load 'clojure-ts-mode (cider--setup-menu-for-clojure-major-mode (with-suppressed-warnings ((free-vars clojure-ts-mode-map)) clojure-ts-mode-map))) +(autoload 'cider-mode "cider-mode" "\ +Minor mode for REPL interaction from a Clojure buffer. + +\\{cider-mode-map} + +This is a minor mode. If called interactively, toggle the `Cider mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate the variable `cider-mode'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(register-definition-prefixes "cider-mode" '("cider-")) + + +;;; Generated autoloads from cider-ns.el + +(autoload 'cider-ns-reload "cider-ns" "\ +Send a (require 'ns :reload) to the REPL. + +With an argument PROMPT, it prompts for a namespace name. This is the +Clojure out of the box reloading experience and does not rely on +org.clojure/tools.namespace. See Commentary of this file for a longer list +of differences. From the Clojure doc: \":reload forces loading of all the +identified libs even if they are already loaded\". + +(fn &optional PROMPT)" t) +(autoload 'cider-ns-reload-all "cider-ns" "\ +Send a (require 'ns :reload-all) to the REPL. + +With an argument PROMPT, it prompts for a namespace name. This is the +Clojure out of the box reloading experience and does not rely on +org.clojure/tools.namespace. See Commentary of this file for a longer list +of differences. From the Clojure doc: \":reload-all implies :reload and +also forces loading of all libs that the identified libs directly or +indirectly load via require\". + +(fn &optional PROMPT)" t) +(autoload 'cider-ns-refresh "cider-ns" "\ +Reload modified and unloaded namespaces, using the Reloaded Workflow. +Uses the configured 'refresh dirs' (defaults to the classpath dirs). + +With a single prefix argument, or if MODE is `refresh-all', reload all +namespaces on the classpath dirs unconditionally. + +With a double prefix argument, or if MODE is `clear', clear the state of +the namespace tracker before reloading. This is useful for recovering from +some classes of error (for example, those caused by circular dependencies) +that a normal reload would not otherwise recover from. The trade-off of +clearing is that stale code from any deleted files may not be completely +unloaded. + +With a negative prefix argument, or if MODE is `inhibit-fns', prevent any +refresh functions (defined in `cider-ns-refresh-before-fn' and +`cider-ns-refresh-after-fn') from being invoked. + +(fn &optional MODE)" t) +(register-definition-prefixes "cider-ns" '("cider-ns-")) + + +;;; Generated autoloads from cider-overlays.el + +(register-definition-prefixes "cider-overlays" '("cider-")) + + +;;; Generated autoloads from cider-popup.el + +(register-definition-prefixes "cider-popup" '("cider-")) + + +;;; Generated autoloads from cider-profile.el + +(autoload 'cider-profile-samples "cider-profile" "\ +Displays current max-sample-count. +If optional QUERY is specified, set max-sample-count and display new value. + +(fn &optional QUERY)" t) +(autoload 'cider-profile-var-profiled-p "cider-profile" "\ +Displays the profiling status of var under point. +Prompts for var if none under point or QUERY is present. + +(fn QUERY)" t) +(autoload 'cider-profile-ns-toggle "cider-profile" "\ +Toggle profiling for the ns associated with optional QUERY. + +If optional argument QUERY is non-nil, prompt for ns. Otherwise use +current ns. + +(fn &optional QUERY)" t) +(autoload 'cider-profile-toggle "cider-profile" "\ +Toggle profiling for the given QUERY. +Defaults to the symbol at point. +With prefix arg or no symbol at point, prompts for a var. + +(fn QUERY)" t) +(autoload 'cider-profile-summary "cider-profile" "\ +Display a summary of currently collected profile data." t) +(autoload 'cider-profile-var-summary "cider-profile" "\ +Display profile data for var under point QUERY. +Defaults to the symbol at point. With prefix arg or no symbol at point, +prompts for a var. + +(fn QUERY)" t) +(autoload 'cider-profile-clear "cider-profile" "\ +Clear any collected profile data." t) +(register-definition-prefixes "cider-profile" '("cider-profile-")) + + +;;; Generated autoloads from cider-repl.el + +(register-definition-prefixes "cider-repl" '("cider-")) + + +;;; Generated autoloads from cider-repl-history.el + +(autoload 'cider-repl-history "cider-repl-history" "\ +Display items in the CIDER command history in another buffer." t) +(register-definition-prefixes "cider-repl-history" '("cider-repl-history-")) + + +;;; Generated autoloads from cider-resolve.el + +(register-definition-prefixes "cider-resolve" '("cider-resolve-")) + + +;;; Generated autoloads from cider-scratch.el + +(autoload 'cider-scratch "cider-scratch" "\ +Go to the scratch buffer named `cider-scratch-buffer-name'." t) +(register-definition-prefixes "cider-scratch" '("cider-")) + + +;;; Generated autoloads from cider-selector.el + +(autoload 'cider-selector "cider-selector" "\ +Select a new buffer by type, indicated by a single character. +The user is prompted for a single character indicating the method by +which to choose a new buffer. The `?' character describes the +available methods. OTHER-WINDOW provides an optional target. +See `def-cider-selector-method' for defining new methods. + +(fn &optional OTHER-WINDOW)" t) +(register-definition-prefixes "cider-selector" '("cider-selector-" "def-cider-selector-method")) + + +;;; Generated autoloads from cider-stacktrace.el + +(register-definition-prefixes "cider-stacktrace" '("cider-")) + + +;;; Generated autoloads from cider-test.el + +(defvar cider-auto-test-mode nil "\ +Non-nil if Cider-Auto-Test mode is enabled. +See the `cider-auto-test-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `cider-auto-test-mode'.") +(custom-autoload 'cider-auto-test-mode "cider-test" nil) +(autoload 'cider-auto-test-mode "cider-test" "\ +Toggle automatic testing of Clojure files. + +When enabled this reruns tests every time a Clojure file is loaded. +Only runs tests corresponding to the loaded file's namespace and does +nothing if no tests are defined or if the file failed to load. + +This is a global minor mode. If called interactively, toggle the +`Cider-Auto-Test mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='cider-auto-test-mode)'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(register-definition-prefixes "cider-test" '("cider-")) + + +;;; Generated autoloads from cider-tracing.el + +(autoload 'cider-toggle-trace-var "cider-tracing" "\ +Toggle var tracing. +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates. + +(fn ARG)" t) +(autoload 'cider-toggle-trace-ns "cider-tracing" "\ +Toggle ns tracing. +Defaults to the current ns. With prefix arg QUERY, prompts for a ns. + +(fn QUERY)" t) +(register-definition-prefixes "cider-tracing" '("cider-")) + + +;;; Generated autoloads from cider-util.el + +(autoload 'cider-view-manual "cider-util" "\ +View the manual in your default browser." t) +(register-definition-prefixes "cider-util" '("cider-")) + + +;;; Generated autoloads from cider-xref.el + +(autoload 'cider-xref-fn-refs "cider-xref" "\ +Show all functions that reference the var matching NS and SYMBOL. + +(fn &optional NS SYMBOL)" t) +(autoload 'cider-xref-fn-deps "cider-xref" "\ +Show all functions referenced by the var matching NS and SYMBOL. + +(fn &optional NS SYMBOL)" t) +(autoload 'cider-xref-fn-refs-select "cider-xref" "\ +Displays the references for NS and SYMBOL using completing read. + +(fn &optional NS SYMBOL)" t) +(autoload 'cider-xref-fn-deps-select "cider-xref" "\ +Displays the function dependencies for NS and SYMBOL using completing read. + +(fn &optional NS SYMBOL)" t) +(register-definition-prefixes "cider-xref" '("cider-")) + + +;;; Generated autoloads from cider-xref-backend.el + +(register-definition-prefixes "cider-xref-backend" '("cider--")) + + +;;; Generated autoloads from nrepl-client.el + +(register-definition-prefixes "nrepl-client" '("cider-" "emacs-bug-46284/when-27.1-windows-nt" "nrepl-")) + + +;;; Generated autoloads from nrepl-dict.el + +(register-definition-prefixes "nrepl-dict" '("nrepl-")) + +;;; End of scraped data + +(provide 'cider-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; cider-autoloads.el ends here diff --git a/elpa/cider-20241203.1607/cider-browse-ns.el b/elpa/cider-20241203.1607/cider-browse-ns.el new file mode 100644 index 00000000..4e9e6be7 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-browse-ns.el @@ -0,0 +1,550 @@ +;;; cider-browse-ns.el --- CIDER namespace browser -*- lexical-binding: t; -*- + +;; Copyright © 2014-2024 John Andrews, Bozhidar Batsov and CIDER contributors + +;; Author: John Andrews + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; M-x cider-browse-ns +;; +;; Display a list of all vars in a namespace. +;; Pressing will take you to the cider-doc buffer for that var. +;; Pressing ^ will take you to a list of all namespaces (akin to `dired-mode'). + +;; M-x cider-browse-ns-all +;; +;; Explore Clojure namespaces by browsing a list of all namespaces. +;; Pressing expands into a list of that namespace's vars as if by +;; executing the command (cider-browse-ns "my.ns"). + +;;; Code: + +(require 'cider-client) +(require 'cider-popup) +(require 'cider-util) +(require 'nrepl-dict) + +(require 'subr-x) +(require 'easymenu) +(require 'button) +(require 'cl-lib) +(require 'thingatpt) + + +(defgroup cider-browse-ns nil + "Display contents of namespaces for CIDER." + :prefix "cider-browse-ns-" + :group 'cider) + +(defface cider-browse-ns-extra-info-face + '((t (:inherit shadow))) + "Face for displaying extra info of namespace vars." + :package-version '(cider . "1.4.0")) + +(defcustom cider-browse-ns-default-filters nil + "List of default hide filters to apply to browse-ns buffer. + +Available options include `private', `test', `macro', `function', and +`var'." + :type 'list + :package-version '(cider . "1.4.0")) + +(defconst cider-browse-ns-buffer "*cider-ns-browser*") + +(defvar-local cider-browse-ns-current-ns nil) + +(defvar-local cider-browse-ns-filters nil) +(defvar-local cider-browse-ns-show-all nil) +(defvar-local cider-browse-ns-group-by nil) +(defvar-local cider-browse-ns-items nil) +(defvar-local cider-browse-ns-title nil) +(defvar-local cider-browse-ns-group-by nil) + + +;; Mode Definition + +(defvar cider-browse-ns-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map cider-popup-buffer-mode-map) + (define-key map "d" #'cider-browse-ns-doc-at-point) + (define-key map "s" #'cider-browse-ns-find-at-point) + (define-key map (kbd "RET") #'cider-browse-ns-operate-at-point) + (define-key map "^" #'cider-browse-ns-all) + (define-key map "n" #'next-line) + (define-key map "p" #'previous-line) + + (define-key map "a" #'cider-browse-ns-toggle-all) + + (define-key map (kbd "h p") #'cider-browse-ns-toggle-hide-private) + (define-key map (kbd "h t") #'cider-browse-ns-toggle-hide-test) + (define-key map (kbd "h m") #'cider-browse-ns-toggle-hide-macro) + (define-key map (kbd "h f") #'cider-browse-ns-toggle-hide-function) + (define-key map (kbd "h v") #'cider-browse-ns-toggle-hide-var) + + (define-key map (kbd "g t") #'cider-browse-ns-group-by-type) + (define-key map (kbd "g v") #'cider-browse-ns-group-by-visibility) + + (easy-menu-define cider-browse-ns-mode-menu map + "Menu for CIDER's namespace browser" + '("Namespace Browser" + ["Show doc" cider-browse-ns-doc-at-point] + ["Go to definition" cider-browse-ns-find-at-point] + "--" + ["Browse all namespaces" cider-browse-ns-all])) + map)) + +(defvar cider-browse-ns-mouse-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] #'cider-browse-ns-handle-mouse) + map)) + +(define-derived-mode cider-browse-ns-mode special-mode "browse-ns" + "Major mode for browsing Clojure namespaces. + +\\{cider-browse-ns-mode-map}" + (setq-local electric-indent-chars nil) + (setq-local sesman-system 'CIDER) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t)) + (setq-local cider-browse-ns-current-ns nil)) + +(defun cider-browse-ns--text-face (var-meta) + "Return font-lock-face for a var. +VAR-META contains the metadata information used to decide a face. +Presence of \"arglists\" and \"macro\" indicates a macro form. +Only \"arglists\" indicates a function. Otherwise, its a variable. +If the NAMESPACE is not loaded in the REPL, assume TEXT is a fn." + (cond + ((not var-meta) 'font-lock-function-name-face) + ((and (nrepl-dict-contains var-meta "arglists") + (string= (nrepl-dict-get var-meta "macro") "true")) + 'font-lock-keyword-face) + ((nrepl-dict-contains var-meta "arglists") 'font-lock-function-name-face) + (t 'font-lock-variable-name-face))) + +(defun cider-browse-ns--properties (var var-meta) + "Decorate VAR with a clickable keymap and a face. +VAR-META is used to decide a font-lock face." + (let ((face (cider-browse-ns--text-face var-meta))) + (propertize var + 'font-lock-face face + 'mouse-face 'highlight + 'keymap cider-browse-ns-mouse-map))) + +(defun cider-browse-ns--ns-list (buffer title nss) + "List the namespaces NSS in BUFFER. + +Buffer is rendered with TITLE at the top and lists ITEMS filtered according +to user settings." + (let ((dict (nrepl-dict))) + (dolist (ns nss) + (nrepl-dict-put dict ns (nrepl-dict "ns" "true"))) + (cider-browse-ns--list buffer title dict nil))) + +(defun cider-browse-ns--list (buffer title items ns) + "Initialize rendering of browse-ns BUFFER. + +Initialize the buffer's TITLE, namespace NS, and the nrepl-dict ITEMS to be +displayed." + (with-current-buffer buffer + (cider-browse-ns-mode) + (setq-local cider-browse-ns-items items) + (setq-local cider-browse-ns-title title) + (setq-local cider-browse-ns-filters cider-browse-ns-default-filters) + (setq-local cider-browse-ns-current-ns ns)) + (cider-browse-ns--render-buffer)) + +(defun cider-browse-ns--meta-macro-p (var-meta) + "Return non-nil if VAR-META is the metadata of a macro." + (and (nrepl-dict-contains var-meta "arglists") + (string= (nrepl-dict-get var-meta "macro") "true"))) + +(defun cider-browse-ns--meta-test-p (var-meta) + "Return non-nil if VAR-META is the metadata of a test." + (nrepl-dict-contains var-meta "test")) + +(defun cider-browse-ns--meta-function-p (var-meta) + "Return non-nil if VAR-META is the metadata of a function." + (and (nrepl-dict-contains var-meta "arglists") + (not (cider-browse-ns--meta-macro-p var-meta)))) + +(defun cider-browse-ns--meta-private-p (var-meta) + "Return non-nil if VAR-META indicates a private element." + (string= (nrepl-dict-get var-meta "private") "true")) + +(defun cider-browse-ns--meta-var-p (var-meta) + "Return non-nil if VAR-META indicates a var." + (not (or (cider-browse-ns--meta-test-p var-meta) + (cider-browse-ns--meta-macro-p var-meta) + (cider-browse-ns--meta-function-p var-meta)))) + +(defun cider-browse-ns--item-filter (_ var-meta) + "Return non-nil if item containing VAR-META should be listed in buffer." + (let ((function-filter-p (memq 'function cider-browse-ns-filters)) + (var-filter-p (memq 'var cider-browse-ns-filters)) + (private-filter-p (memq 'private cider-browse-ns-filters)) + (test-filter-p (memq 'test cider-browse-ns-filters)) + (macro-filter-p (memq 'macro cider-browse-ns-filters))) + ;; check if item should be displayed + (let* ((macro-p (cider-browse-ns--meta-macro-p var-meta)) + (function-p (cider-browse-ns--meta-function-p var-meta)) + (private-p (cider-browse-ns--meta-private-p var-meta)) + (test-p (cider-browse-ns--meta-test-p var-meta)) + (var-p (cider-browse-ns--meta-var-p var-meta))) + (or cider-browse-ns-show-all + (not (or (and macro-p macro-filter-p) + (and function-p function-filter-p) + (and test-p test-filter-p) + (and var-p var-filter-p) + (and private-p private-filter-p))))))) + +(defun cider-browse-ns--propertized-item (key items) + "Return propertized line of item KEY in nrepl-dict ITEMS." + (let* ((var-meta (nrepl-dict-get items key)) + (face (cider-browse-ns--text-face (nrepl-dict-get items key))) + (private-p (string= (nrepl-dict-get var-meta "private") "true")) + (test-p (nrepl-dict-contains var-meta "test")) + (ns-p (nrepl-dict-contains var-meta "ns"))) + (concat + (propertize key + 'font-lock-face face + 'ns ns-p) + " " + (cond + (test-p (propertize "(test) " 'face 'cider-browse-ns-extra-info-face)) + (private-p (propertize "(-) " 'face 'cider-browse-ns-extra-info-face)) + (t ""))))) + +(defun cider-browse-ns--display-list (keys items max-length &optional label) + "Render the items of KEYS as condained in the nrepl-dict ITEMS. + +Pad the row to be MAX-LENGTH+1. If LABEL is non-nil, add a header to the +list of items." + (when keys + (when label + (insert " " label ":\n")) + (dolist (key keys) + (let* ((doc (nrepl-dict-get-in items (list key "doc"))) + (doc (when doc (read doc))) + (first-doc-line (cider-browse-ns--first-doc-line doc)) + (item-line (cider-browse-ns--propertized-item key items))) + (insert " ") + (insert item-line) + (when cider-browse-ns-current-ns + (insert (make-string (+ (- max-length (string-width item-line)) 1) ?·)) + (insert " " (propertize first-doc-line 'font-lock-face 'font-lock-doc-face))) + (insert "\n"))) + (insert "\n"))) + +(defun cider-browse-ns--column-width (items) + "Determine the display width of displayed ITEMS." + (let* ((propertized-lines + (seq-map (lambda (key) + (cider-browse-ns--propertized-item key items)) + (nrepl-dict-keys items)))) + (if propertized-lines + (apply #'max (seq-map (lambda (entry) (string-width entry)) + propertized-lines)) + 0))) + +(defun cider-browse-ns--render-items (items) + "Render the nrepl-dict ITEMS to the browse-ns buffer." + (let* ((max-length (cider-browse-ns--column-width items))) + (cl-labels + ((keys-from-pred + (pred items) + (nrepl-dict-keys (nrepl-dict-filter (lambda (_ var-meta) + (funcall pred var-meta)) + items)))) + (cond + ((eql cider-browse-ns-group-by 'type) + (let* ((func-keys (keys-from-pred #'cider-browse-ns--meta-function-p items)) + (macro-keys (keys-from-pred #'cider-browse-ns--meta-macro-p items)) + (var-keys (keys-from-pred #'cider-browse-ns--meta-var-p items)) + (test-keys (keys-from-pred #'cider-browse-ns--meta-test-p items))) + (cider-browse-ns--display-list func-keys items max-length "Functions") + (cider-browse-ns--display-list macro-keys items max-length "Macros") + (cider-browse-ns--display-list var-keys items max-length "Vars") + (cider-browse-ns--display-list test-keys items max-length "Tests"))) + ((eql cider-browse-ns-group-by 'visibility) + (let* ((public-keys + (keys-from-pred + (lambda (var-meta) + (not (cider-browse-ns--meta-private-p var-meta))) + items)) + (private-keys (keys-from-pred #'cider-browse-ns--meta-private-p items))) + (cider-browse-ns--display-list public-keys items max-length "Public") + (cider-browse-ns--display-list private-keys items max-length "Private"))) + (t + (cider-browse-ns--display-list + (nrepl-dict-keys items) items max-length)))))) + +(defun cider-browse-ns--filter (flag) + "Toggle the filter indicated by FLAG and re-render the buffer." + (setq cider-browse-ns-filters + (if (memq flag cider-browse-ns-filters) + (remq flag cider-browse-ns-filters) + (cons flag cider-browse-ns-filters))) + (cider-browse-ns--render-buffer)) + +(defun cider-browse-ns--button-filter (button) + "Handle filter action for BUTTON." + (let ((flag (button-get button 'filter))) + (cider-browse-ns--filter flag))) + +(defun cider-browse-ns--group (flag) + "Set the group-by option to FLAG and re-renderthe buffer." + (setq cider-browse-ns-group-by + (if (eql flag cider-browse-ns-group-by) nil flag)) + (cider-browse-ns--render-buffer)) + +(defun cider-browse-ns--button-group (button) + "Handle grouping action for BUTTON." + (let ((flag (button-get button 'group-by))) + (cider-browse-ns--group flag))) + +(defun cider-browse-ns--toggle-all (_button) + "Toggle the display-all visibility setting." + (setq cider-browse-ns-show-all (not cider-browse-ns-show-all)) + (cider-browse-ns--render-buffer)) + +(defun cider-browse-ns--render-header (&optional filtered-items-ct) + "Render the section at the top of the buffer displaying visibility controls. + +If FILTERED-ITEMS-CT is non-nil, then display a message of how many items +are being filtered." + ;; Display Show line + (insert " Show: ") + (insert-text-button "All" + 'follow-link t + 'action #'cider-browse-ns--toggle-all + ;; 'help-echo (cider-stacktrace-tooltip) + 'face (if cider-browse-ns-show-all + 'cider-stacktrace-filter-active-face + nil)) + (insert "\n") + ;; Display Filters + (let ((filters '(("Private" private) + ("Test" test) + ("Macro" macro) + ("Function" function) + ("Var" var)))) + (insert " Hide: ") + (dolist (filter filters) + (seq-let (title key) filter + (let ((is-active (memq key cider-browse-ns-filters))) + (insert-text-button title + 'filter key + 'follow-link t + 'action #'cider-browse-ns--button-filter + ;; 'help-echo (cider-stacktrace-tooltip) + 'face (if (and is-active (not cider-browse-ns-show-all)) + 'cider-stacktrace-filter-active-face + nil)) + (insert " ")))) + (when filtered-items-ct + (insert (format "(%d items filtered)" filtered-items-ct)))) + (insert "\n") + ;; Groupings + (insert " Group-by: ") + (let ((groupings '(("Type" type) + ("Visibility" visibility)))) + (dolist (grouping groupings) + (seq-let (title key) grouping + (let ((is-active (eql key cider-browse-ns-group-by))) + (insert-text-button title + 'group-by key + 'follow-link t + 'action #'cider-browse-ns--button-group + ;; 'help-echo () + 'face (if is-active + 'cider-stacktrace-filter-active-face + nil))) + (insert " ")))) + (insert "\n\n")) + +(defun cider-browse-ns--render-buffer (&optional buffer) + "Render the sections of the browse-ns buffer. + +Render occurs in BUFFER if non-nil. This function is the main entrypoint +for redisplaying the buffer when filters change." + (with-current-buffer (or buffer (current-buffer)) + (let* ((inhibit-read-only t) + (point (point)) + (filtered-items (nrepl-dict-filter #'cider-browse-ns--item-filter + cider-browse-ns-items)) + (filtered-item-ct (- (length (nrepl-dict-keys cider-browse-ns-items)) + (length (nrepl-dict-keys filtered-items))))) + (erase-buffer) + (insert (propertize (cider-propertize cider-browse-ns-title 'ns) 'ns t) "\n") + (when cider-browse-ns-current-ns + (cider-browse-ns--render-header filtered-item-ct)) + (cider-browse-ns--render-items filtered-items) + (goto-char point)))) + +(defun cider-browse-ns--first-doc-line (doc) + "Return the first line of the given DOC string. +If the first line of the DOC string contains multiple sentences, only +the first sentence is returned. If the DOC string is nil, a Not documented +string is returned." + (if doc + (let* ((split-newline (split-string doc "\n")) + (first-line (car split-newline))) + (cond + ((string-match "\\. " first-line) (substring first-line 0 (match-end 0))) + ((= 1 (length split-newline)) first-line) + (t (concat first-line "...")))) + "Not documented.")) + +(defun cider-browse-ns--combined-vars-with-meta (namespace) + "Return the combined public and private vars in NAMESPACE. + +Private vars have the additional metadata \"private\": \"true\" in their +var-meta map." + (let ((items (cider-sync-request:ns-vars-with-meta namespace)) + (private-items (cider-sync-request:private-ns-vars-with-meta namespace))) + (when private-items + (dolist (key (nrepl-dict-keys private-items)) + (let ((var-meta (nrepl-dict-put (nrepl-dict-get private-items key) + "private" "true"))) + (setq items (nrepl-dict-put items key var-meta))))) + items)) + +;; Interactive Functions + +;;;###autoload +(defun cider-browse-ns (namespace) + "List all NAMESPACE's vars in BUFFER." + (interactive (list (completing-read "Browse namespace: " (cider-sync-request:ns-list)))) + (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer 'select nil 'ancillary) + (cider-browse-ns--list (current-buffer) + namespace + (cider-browse-ns--combined-vars-with-meta namespace) + namespace))) + +;;;###autoload +(defun cider-browse-ns-all () + "List all loaded namespaces in BUFFER." + (interactive) + (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer 'select nil 'ancillary) + (let ((names (cider-sync-request:ns-list))) + (cider-browse-ns--ns-list + (current-buffer) + "All loaded namespaces" + (mapcar (lambda (name) + (cider-browse-ns--properties name nil)) + names))))) + +(defun cider-browse-ns--thing-at-point () + "Get the thing at point. +Return a list of the type ('ns or 'var) and the value." + (let ((ns-p (get-text-property (point) 'ns)) + (line (car (split-string (string-trim (thing-at-point 'line)) " ")))) + (if (or ns-p (string-match "\\." line)) + `(ns ,line) + `(var ,(format "%s/%s" + (or (get-text-property (point) 'cider-browse-ns-current-ns) + cider-browse-ns-current-ns) + line))))) + +(defun cider-browse-ns-toggle-all () + "Toggle showing all of the items in the browse-ns buffer." + (interactive) + (cider-browse-ns--toggle-all nil)) + +(defun cider-browse-ns-toggle-hide-private () + "Toggle visibility of private items displayed in browse-ns buffer." + (interactive) + (cider-browse-ns--filter 'private)) + +(defun cider-browse-ns-toggle-hide-test () + "Toggle visibility of test items displayed in browse-ns buffer." + (interactive) + (cider-browse-ns--filter 'test)) + +(defun cider-browse-ns-toggle-hide-macro () + "Toggle visibility of macro items displayed in browse-ns buffer." + (interactive) + (cider-browse-ns--filter 'macro)) + +(defun cider-browse-ns-toggle-hide-function () + "Toggle visibility of function items displayed in browse-ns buffer." + (interactive) + (cider-browse-ns--filter 'function)) + +(defun cider-browse-ns-toggle-hide-var () + "Toggle visibility of var items displayed in browse-ns buffer." + (interactive) + (cider-browse-ns--filter 'var)) + +(defun cider-browse-ns-group-by-type () + "Toggle visibility of var items displayed in browse-ns buffer." + (interactive) + (cider-browse-ns--group 'type)) + +(defun cider-browse-ns-group-by-visibility () + "Toggle visibility of var items displayed in browse-ns buffer." + (interactive) + (cider-browse-ns--group 'visibility)) + + +(declare-function cider-doc-lookup "cider-doc") + +(defun cider-browse-ns-doc-at-point () + "Show the documentation for the thing at current point." + (interactive) + (let* ((thing (cider-browse-ns--thing-at-point)) + (value (cadr thing))) + ;; value is either some ns or a var + (cider-doc-lookup value))) + +(defun cider-browse-ns-operate-at-point () + "Expand browser according to thing at current point. +If the thing at point is a ns it will be browsed, +and if the thing at point is some var - its documentation will +be displayed." + (interactive) + (let* ((thing (cider-browse-ns--thing-at-point)) + (type (car thing)) + (value (cadr thing))) + (if (eq type 'ns) + (cider-browse-ns value) + (cider-doc-lookup value)))) + +(declare-function cider-find-ns "cider-find") +(declare-function cider-find-var "cider-find") + +(defun cider-browse-ns-find-at-point () + "Find the definition of the thing at point." + (interactive) + (let* ((thing (cider-browse-ns--thing-at-point)) + (type (car thing)) + (value (cadr thing))) + (if (eq type 'ns) + (cider-find-ns nil value) + (cider-find-var current-prefix-arg value)))) + +(defun cider-browse-ns-handle-mouse (_event) + "Handle mouse click EVENT." + (interactive "e") + (cider-browse-ns-operate-at-point)) + +(provide 'cider-browse-ns) + +;;; cider-browse-ns.el ends here diff --git a/elpa/cider-20241203.1607/cider-browse-spec.el b/elpa/cider-20241203.1607/cider-browse-spec.el new file mode 100644 index 00000000..7163a25f --- /dev/null +++ b/elpa/cider-20241203.1607/cider-browse-spec.el @@ -0,0 +1,455 @@ +;;; cider-browse-spec.el --- CIDER spec browser -*- lexical-binding: t; -*- + +;; Copyright © 2017-2024 Juan Monetta, Bozhidar Batsov and CIDER contributors + +;; Author: Juan Monetta + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; M-x cider-browse-spec +;; +;; Display a spec description you can browse. +;; Pressing over a sub spec will take you to the description of that sub spec. +;; Pressing ^ takes you to the list of all specs. + +;; M-x cider-browse-spec-all +;; +;; Explore clojure.spec registry by browsing a list of all specs. +;; Pressing over a spec display the spec description you can browse. + +;;; Code: + +(require 'cider-client) +(require 'cider-popup) +(require 'cider-util) +(require 'cl-lib) +(require 'nrepl-dict) +(require 'seq) +(require 'subr-x) +(require 'help-mode) + +;; The buffer names used by the spec browser +(defconst cider-browse-spec-buffer "*cider-spec-browser*") +(defconst cider-browse-spec-example-buffer "*cider-spec-example*") + +;; Mode Definition + +(defvar cider-browse-spec-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map (make-composed-keymap button-buffer-map + cider-popup-buffer-mode-map)) + (define-key map (kbd "RET") #'cider-browse-spec--browse-at) + (define-key map "n" #'forward-button) + (define-key map "p" #'backward-button) + map) + "Keymap for `cider-browse-spec-mode'.") + +(define-derived-mode cider-browse-spec-mode special-mode "Specs" + "Major mode for browsing Clojure specs. + +\\{cider-browse-spec-mode-map}" + (setq-local electric-indent-chars nil) + (setq-local sesman-system 'CIDER) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t))) + +(defvar cider-browse-spec--current-spec nil) + +(defvar cider-browse-spec-view-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map help-mode-map) + (define-key map (kbd "RET") #'cider-browse-spec--browse-at) + (define-key map "^" #'cider-browse-spec-all) + (define-key map "e" #'cider-browse-spec--print-curr-spec-example) + (define-key map "n" #'forward-button) + (define-key map "p" #'backward-button) + map) + "Keymap for `cider-browse-spec-view-mode'.") + +(define-derived-mode cider-browse-spec-view-mode help-mode "Spec" + "Major mode for displaying CIDER spec. + +\\{cider-browse-spec-view-mode-map}" + (setq-local cider-browse-spec--current-spec nil) + (setq-local electric-indent-chars nil) + (setq-local sesman-system 'CIDER) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t))) + +(defvar cider-browse-spec-example-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map cider-popup-buffer-mode-map) + (define-key map "^" #'cider-browse-spec-all) + (define-key map "e" #'cider-browse-spec--print-curr-spec-example) + (define-key map "g" #'revert-buffer) + map) + "Keymap for `cider-browse-spec-example-mode'.") + +(define-derived-mode cider-browse-spec-example-mode special-mode "Example" + "Major mode for Clojure spec examples. + +\\{cider-browse-spec-example-mode-map}" + (setq-local electric-indent-chars nil) + (setq-local revert-buffer-function #'cider-browse-spec--example-revert-buffer-function) + (setq-local sesman-system 'CIDER) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t))) + +;; Non interactive functions + +(define-button-type 'cider-browse-spec--spec + 'action #'cider-browse-spec--browse-at + 'face nil + 'follow-link t + 'help-echo "View spec") + +(defun cider-browse-spec--draw-list-buffer (buffer title specs) + "Reset contents of BUFFER. +Display TITLE at the top and SPECS are indented underneath." + (with-current-buffer buffer + (cider-browse-spec-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (goto-char (point-max)) + (insert (cider-propertize title 'emph) "\n") + (dolist (spec-name specs) + (insert (propertize " " 'spec-name spec-name)) + (thread-first + (cider-font-lock-as-clojure spec-name) + (insert-text-button 'type 'cider-browse-spec--spec) + (button-put 'spec-name spec-name)) + (insert (propertize "\n" 'spec-name spec-name))) + (goto-char (point-min))))) + +(defun cider--qualified-keyword-p (str) + "Return non nil if STR is a namespaced keyword." + (string-match-p "^:.+/.+$" str)) + +(defun cider--spec-fn-p (value fn-name) + "Return non nil if VALUE is clojure.spec.[alpha]/FN-NAME." + (string-match-p (concat "^\\(clojure.spec\\|clojure.spec.alpha\\|clojure.alpha.spec\\)/" fn-name "$") value)) + +(defun cider-browse-spec--render-schema-map (spec-form) + "Render the s/schema map declaration SPEC-FORM." + (let ((name-spec-pairs (seq-partition (cdaadr spec-form) 2))) + (format "(s/schema\n {%s})" + (string-join + (thread-last + (seq-sort-by #'car #'string< name-spec-pairs) + (mapcar (lambda (s) (concat (cl-first s) " " (cider-browse-spec--pprint (cl-second s)))))) + "\n ")))) + +(defun cider-browse-spec--render-schema-vector (spec-form) + "Render the s/schema vector declaration SPEC-FORM." + (format "(s/schema\n [%s])" + (string-join + (thread-last + (cl-second spec-form) + (mapcar (lambda (s) (cider-browse-spec--pprint s)))) + "\n "))) + +(defun cider-browse-spec--render-schema (spec-form) + "Render the s/schema SPEC-FORM." + (let ((schema-args (cl-second spec-form))) + (if (and (listp schema-args) + (nrepl-dict-p (cl-first schema-args))) + (cider-browse-spec--render-schema-map spec-form) + (cider-browse-spec--render-schema-vector spec-form)))) + +(defun cider-browse-spec--render-select (spec-form) + "Render the s/select SPEC-FORM." + (let ((keyset (cl-second spec-form)) + (selection (cl-third spec-form))) + (format "(s/select\n %s\n [%s])" + (cider-browse-spec--pprint keyset) + (string-join + (thread-last + selection + (mapcar (lambda (s) (cider-browse-spec--pprint s)))) + "\n ")))) + +(defun cider-browse-spec--render-union (spec-form) + "Render the s/union SPEC-FORM." + (let ((keyset (cl-second spec-form)) + (selection (cl-third spec-form))) + (format "(s/union\n %s\n [%s])" + (cider-browse-spec--pprint keyset) + (string-join + (thread-last + selection + (mapcar (lambda (s) (cider-browse-spec--pprint s)))) + "\n ")))) + +(defun cider-browse-spec--render-vector (spec-form) + "Render SPEC-FORM as a vector." + (format "[%s]" (string-join (mapcar #'cider-browse-spec--pprint spec-form)))) + +(defun cider-browse-spec--render-map-entry (spec-form) + "Render SPEC-FORM as a map entry." + (let ((key (cl-first spec-form)) + (value (cl-second spec-form))) + (format "%s %s" (cider-browse-spec--pprint key) + (if (listp value) + (cider-browse-spec--render-vector value) + (cider-browse-spec--pprint value))))) + +(defun cider-browse-spec--render-map (spec-form) + "Render SPEC-FORM as a map." + (let ((map-entries (cl-rest spec-form))) + (format "{%s}" (thread-last + (seq-partition map-entries 2) + (seq-map #'cider-browse-spec--render-map-entry) + (string-join))))) + +(defun cider-browse-spec--pprint (form) + "Given a spec FORM builds a multi line string with a pretty render of that FORM." + (cond ((stringp form) + (if (cider--qualified-keyword-p form) + (with-temp-buffer + (thread-first + form + (insert-text-button 'type 'cider-browse-spec--spec) + (button-put 'spec-name form)) + (buffer-string)) + ;; to make it easier to read replace all clojure.spec ns with s/ + ;; and remove all clojure.core ns + (thread-last + form + (replace-regexp-in-string "^\\(clojure.spec\\|clojure.spec.alpha\\|clojure.alpha.spec\\)/" "s/") + (replace-regexp-in-string "^\\(clojure.core\\)/" "")))) + + ((and (listp form) (stringp (cl-first form))) + (let ((form-tag (cl-first form))) + (cond + ;; prettier fns #() + ((string-equal form-tag "clojure.core/fn") + (if (equal (cl-second form) '("%")) + (format "#%s" (cl-reduce #'concat (mapcar #'cider-browse-spec--pprint (cl-rest (cl-rest form))))) + (format "(fn [%%] %s)" (cl-reduce #'concat (mapcar #'cider-browse-spec--pprint (cl-rest (cl-rest form))))))) + ;; prettier (s/and ) + ((cider--spec-fn-p form-tag "and") + (format "(s/and\n%s)" (string-join (thread-last + (cl-rest form) + (mapcar #'cider-browse-spec--pprint) + (mapcar (lambda (x) (format "%s" x)))) + "\n"))) + ;; prettier (s/or ) + ((cider--spec-fn-p form-tag "or") + (let ((name-spec-pair (seq-partition (cl-rest form) 2))) + (format "(s/or\n%s)" (string-join + (thread-last + name-spec-pair + (mapcar (lambda (s) (format "%s %s" (cl-first s) (cider-browse-spec--pprint (cl-second s)))))) + "\n")))) + ;; prettier (s/merge ) + ((cider--spec-fn-p form-tag "merge") + (format "(s/merge\n%s)" (string-join (thread-last + (cl-rest form) + (mapcar #'cider-browse-spec--pprint) + (mapcar (lambda (x) (format "%s" x)))) + "\n"))) + ;; prettier (s/keys ) + ((cider--spec-fn-p form-tag "keys") + (let ((keys-args (seq-partition (cl-rest form) 2))) + (format "(s/keys%s)" (thread-last + keys-args + (mapcar (lambda (s) + (let ((key-type (cl-first s)) + (specs-vec (cl-second s))) + (concat "\n" key-type + " [" + (string-join (thread-last + specs-vec + (mapcar #'cider-browse-spec--pprint) + (mapcar (lambda (x) (format "%s" x)))) + "\n") + "]")))) + (cl-reduce #'concat))))) + ;; prettier (s/multi-spec) + ((cider--spec-fn-p form-tag "multi-spec") + (let ((multi-method (cl-second form)) + (retag (cl-third form)) + (sub-specs (cl-rest (cl-rest (cl-rest form))))) + (format "(s/multi-spec %s %s\n%s)" + multi-method + retag + (string-join + (thread-last + sub-specs + (mapcar (lambda (s) + (concat "\n\n" (cl-first s) " " (cider-browse-spec--pprint (cl-second s)))))) + "\n")))) + ;; prettier (s/cat ) + ((cider--spec-fn-p form-tag "cat") + (let ((name-spec-pairs (seq-partition (cl-rest form) 2))) + (format "(s/cat %s)" + (thread-last + name-spec-pairs + (mapcar (lambda (s) + (concat "\n" (cl-first s) " " (cider-browse-spec--pprint (cl-second s))))) + (cl-reduce #'concat))))) + ;; prettier (s/alt ) + ((cider--spec-fn-p form-tag "alt") + (let ((name-spec-pairs (seq-partition (cl-rest form) 2))) + (format "(s/alt %s)" + (thread-last + name-spec-pairs + (mapcar (lambda (s) + (concat "\n" (cl-first s) " " (cider-browse-spec--pprint (cl-second s))))) + (cl-reduce #'concat))))) + ;; prettier (s/fspec ) + ((cider--spec-fn-p form-tag "fspec") + (thread-last + (seq-partition (cl-rest form) 2) + (cl-remove-if (lambda (s) (and (stringp (cl-second s)) + (string-empty-p (cl-second s))))) + (mapcar (lambda (s) + (format "\n%-11s: %s" (pcase (cl-first s) + (":args" "arguments") + (":ret" "returns") + (":fn" "invariants")) + (cider-browse-spec--pprint (cl-second s))))) + (cl-reduce #'concat) + (format "%s"))) + ;; prettier (s/schema ) + ((cider--spec-fn-p form-tag "schema") + (cider-browse-spec--render-schema form)) + ;; prettier (s/select ) + ((cider--spec-fn-p form-tag "select") + (cider-browse-spec--render-select form)) + ;; prettier (s/union ) + ((cider--spec-fn-p form-tag "union") + (cider-browse-spec--render-union form)) + ;; every other with no special management + (t (format "(%s %s)" + (cider-browse-spec--pprint form-tag) + (string-join (mapcar #'cider-browse-spec--pprint (cl-rest form)) " ")))))) + ((nrepl-dict-p form) + (cider-browse-spec--render-map form)) + (t (format "%s" form)))) + +(defun cider-browse-spec--pprint-indented (spec-form) + "Indent (pretty-print) and font-lock SPEC-FORM. +Return the result as a string." + (with-temp-buffer + (clojure-mode) + (insert (cider-browse-spec--pprint spec-form)) + (indent-region (point-min) (point-max)) + (font-lock-ensure) + (buffer-string))) + +(defun cider-browse-spec--draw-spec-buffer (buffer spec spec-form) + "Reset contents of BUFFER and draws everything needed to browse the SPEC-FORM. +Display SPEC as a title and uses `cider-browse-spec--pprint' to display +a more user friendly representation of SPEC-FORM." + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (cider--help-setup-xref (list #'cider-browse-spec spec) nil buffer) + (goto-char (point-max)) + (insert (cider-font-lock-as-clojure spec) "\n\n") + (insert (cider-browse-spec--pprint-indented spec-form)) + (cider--make-back-forward-xrefs) + (current-buffer)))) + +(defun cider-browse-spec--browse (spec) + "Browse SPEC." + (cider-ensure-connected) + (cider-ensure-op-supported "spec-form") + ;; Expand auto-resolved keywords + (when-let* ((val (and (string-match-p "^::.+" spec) + (nrepl-dict-get (cider-sync-tooling-eval spec (cider-current-ns)) "value")))) + (setq spec val)) + (with-current-buffer (cider-popup-buffer cider-browse-spec-buffer 'select #'cider-browse-spec-view-mode 'ancillary) + (setq-local cider-browse-spec--current-spec spec) + (cider-browse-spec--draw-spec-buffer (current-buffer) + spec + (cider-sync-request:spec-form spec)) + (goto-char (point-min)) + (current-buffer))) + +(defun cider-browse-spec--browse-at (&optional pos) + "View the definition of a spec. + +Optional argument POS is the position of a spec, defaulting to point. POS +may also be a button, so this function can be used a the button's `action' +property." + (interactive) + (let ((pos (or pos (point)))) + (when-let* ((spec (button-get pos 'spec-name))) + (cider-browse-spec--browse spec)))) + +;; Interactive Functions + +(defun cider-browse-spec--print-curr-spec-example () + "Generate and print an example of the current spec." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "spec-example") + (if-let* ((spec cider-browse-spec--current-spec)) + (if-let* ((example (cider-sync-request:spec-example spec))) + (with-current-buffer (cider-popup-buffer cider-browse-spec-example-buffer 'select #'cider-browse-spec-example-mode 'ancillary) + (setq-local cider-browse-spec--current-spec spec) + (let ((inhibit-read-only t)) + (insert "Example of " (cider-font-lock-as-clojure spec)) + (insert "\n\n") + (insert (cider-font-lock-as-clojure example)) + (goto-char (point-min)))) + (error (format "No example for spec %s" spec))) + (error "No current spec"))) + +(defun cider-browse-spec--example-revert-buffer-function (&rest _) + "`revert-buffer' function for `cider-browse-spec-example-mode'. + +Generates a new example for the current spec." + (cider-browse-spec--print-curr-spec-example)) + +;;;###autoload +(defun cider-browse-spec (spec) + "Browse SPEC definition." + (interactive (list (completing-read "Browse spec: " + (cider-sync-request:spec-list) + nil nil + (cider-symbol-at-point)))) + (cider-browse-spec--browse spec)) + +(defun cider-browse-spec-regex (regex) + "Open the list of specs that matches REGEX in a popup buffer. +Displays all specs when REGEX is nil." + (cider-ensure-connected) + (cider-ensure-op-supported "spec-list") + (let ((filter-regex (or regex ""))) + (with-current-buffer (cider-popup-buffer cider-browse-spec-buffer 'select nil 'ancillary) + (let ((specs (cider-sync-request:spec-list filter-regex))) + (cider-browse-spec--draw-list-buffer (current-buffer) + (if (string-empty-p filter-regex) + "All specs in registry" + (format "All specs matching regex `%s' in registry" filter-regex)) + specs))))) + +;;;###autoload +(defun cider-browse-spec-all (&optional arg) + "Open list of specs in a popup buffer. + +With a prefix argument ARG, prompts for a regexp to filter specs. +No filter applied if the regexp is the empty string." + (interactive "P") + (cider-browse-spec-regex (if arg (read-string "Filter regex: ") ""))) + +(provide 'cider-browse-spec) + +;;; cider-browse-spec.el ends here diff --git a/elpa/cider-20241203.1607/cider-cheatsheet.el b/elpa/cider-20241203.1607/cider-cheatsheet.el new file mode 100644 index 00000000..fbc07dad --- /dev/null +++ b/elpa/cider-20241203.1607/cider-cheatsheet.el @@ -0,0 +1,640 @@ +;;; cider-cheatsheet.el --- Quick reference for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2019-2024 Kris Jenkins, Bozhidar Batsov and CIDER contributors +;; +;; Author: Kris Jenkins +;; Kato Muso + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; A quick reference system for Clojure. Fast, searchable & available offline. + +;;; Code: + +(require 'cider-doc) +(require 'cl-lib) +(require 'map) +(require 'seq) +(require 'subr-x) + +(defgroup cider-cheatsheet nil + "Clojure cheatsheet in CIDER." + :prefix "cider-cheatsheet-" + :group 'cider) + +(defconst cider-cheatsheet-buffer "*cider-cheatsheet*") + +(defcustom cider-cheatsheet-auto-select-buffer t + "Whether to auto-select the cheatsheet popup buffer." + :type 'boolean + :package-version '(cider . "1.15.0")) + +(defcustom cider-cheatsheet-default-action-function #'cider-doc-lookup + "Function to use on a var when it is selected. + +By default, documentation for a var is displayed using `cider-doc-lookup`, +but it can also be set to `cider-clojuredocs-lookup` to show documentation +from ClojureDocs or any other function accepting a var as an argument." + :type '(choice (const cider-doc-lookup) + (const cider-clojuredocs-lookup) + function) + :package-version '(cider . "1.15.0")) + +(defconst cider-cheatsheet-hierarchy + '(("Documentation" + ("REPL" + (clojure.repl doc find-doc apropos dir source pst) + (clojure.java.javadoc javadoc))) + ("Primitives" + ("Numbers" + ("Arithmetic" + (clojure.core + - * / quot rem mod inc dec max min abs) + (clojure.math floor-div floor-mod ceil floor rint round pow sqrt cbrt E exp expm1 log log10 log1p PI sin cos tan asin acos atan atan2)) + ("Arbitrary Precision Arithmetic" + (clojure.core +\' -\' *\' inc\' dec\')) + ("Compare" + (clojure.core == < > <= >= compare)) + ("Bitwise" + (clojure.core bit-and bit-or bit-xor bit-not bit-flip bit-set bit-shift-right bit-shift-left bit-and-not bit-clear bit-test unsigned-bit-shift-right)) + ("Cast" + (clojure.core byte short int long float double bigdec bigint num rationalize biginteger)) + ("Test" + (clojure.core zero? pos? neg? even? odd? number? rational? integer? ratio? decimal? float? double? int? nat-int? neg-int? pos-int? NaN? infinite?)) + ("Random" + (clojure.core rand rand-int) + (clojure.math random)) + ("BigDecimal" + (clojure.core with-precision)) + ("Unchecked" + (clojure.core *unchecked-math* unchecked-add unchecked-dec unchecked-inc unchecked-multiply unchecked-negate unchecked-subtract)) + ("Ratios" + (clojure.core numerator denominator ratio?))) + ("Strings" + ("Create" + (clojure.core str format)) + ("Use" + (clojure.core count get subs compare parse-boolean parse-double parse-long parse-uuid) + (clojure.string join escape split split-lines replace replace-first reverse index-of last-index-of)) + ("Regex" + (clojure.core re-find re-seq re-matches re-pattern re-matcher re-groups) + (clojure.string replace replace-first re-quote-replacement)) + ("Letters" + (clojure.string capitalize lower-case upper-case)) + ("Trim" + (clojure.string trim trim-newline triml trimr)) + ("Test" + (clojure.core string?) + (clojure.string blank? starts-with? ends-with? includes?))) + ("Other" + ("Characters" + (clojure.core char char? char-name-string char-escape-string)) + ("Keywords" + (clojure.core keyword keyword? find-keyword)) + ("Symbols" + (clojure.core symbol symbol? gensym)))) + ("Collections" + ("Generic ops" + (clojure.core count empty not-empty into conj bounded-count)) + ("Tree walking" + (clojure.walk walk prewalk prewalk-demo prewalk-replace postwalk postwalk-demo postwalk-replace keywordize-keys stringify-keys)) + ("Content tests" + (clojure.core distinct? empty? every? not-every? some not-any?)) + ("Capabilities" + (clojure.core sequential? associative? sorted? counted? reversible?)) + ("Type tests" + (clojure.core coll? list? vector? set? map? seq? record? map-entry?)) + ("Lists" + ("Create" + (clojure.core list list*)) + ("Examine" + (clojure.core first nth peek)) + ("Change" + (clojure.core cons conj rest pop))) + ("Vectors" + ("Create" + (clojure.core vector vec vector-of mapv filterv)) + ("Examine" + (clojure.core nth get peek)) + ("Change" + (clojure.core assoc assoc-in pop subvec replace conj rseq update update-in)) + ("Ops" + (clojure.core reduce-kv))) + ("Sets" + ("Create unsorted" + (clojure.core set hash-set)) + ("Create sorted" + (clojure.core sorted-set sorted-set-by) + (clojure.data.avl sorted-set sorted-set-by) + (clojure.data.int-map int-set dense-int-set)) + ("Examine" + (clojure.core get contains?)) + ("Change" + (clojure.core conj disj)) + ("Set ops" + (clojure.set union difference intersection select)) + ("Test" + (clojure.set subset? superset?)) + ("Sorted sets" + (clojure.core rseq subseq rsubseq))) + ("Maps" + ("Create unsorted" + (clojure.core hash-map array-map zipmap bean frequencies group-by) + (clojure.set index)) + ("Create sorted" + (clojure.core sorted-map sorted-map-by) + (clojure.data.avl sorted-map sorted-map-by) + (clojure.data.priority-map priority-map) + (clojure.data.int-map int-map)) + ("Examine" + (clojure.core get get get-in contains? find keys vals)) + ("Change" + (clojure.core assoc assoc-in dissoc merge merge-with select-keys update update-in update-keys update-vals) + (clojure.set rename-keys map-invert)) + ("Ops" + (clojure.core reduce-kv)) + ("Entry" + (clojure.core key val)) + ("Sorted maps" + (clojure.core rseq subseq rsubseq))) + ("Queues" + ("Examine" + (clojure.core peek)) + ("Change" + (clojure.core conj pop))) + ("Relations" + ("Relational algebra" + (clojure.set join select project union difference intersection index rename))) + ("Transients" + ("Create" + (clojure.core transient persistent!)) + ("Change" + (clojure.core conj! pop! assoc! dissoc! disj!))) + ("Misc" + ("Compare" + (clojure.core = identical? not= not compare) + (clojure.data diff)) + ("Test" + (clojure.core true? false? instance? nil? some?))) + ("Hashes" + (clojure.core hash hash-ordered-coll hash-unordered-coll mix-collection-hash))) + ("Sequences" + ("Creating a Lazy Seq" + ("From collection" + (clojure.core seq vals keys rseq subseq rsubseq sequence)) + ("From producer fn" + (clojure.core lazy-seq repeatedly iterate iteration)) + ("From constant" + (clojure.core repeat range)) + ("From other" + (clojure.core file-seq line-seq resultset-seq re-seq tree-seq xml-seq iterator-seq enumeration-seq)) + ("From seq" + (clojure.core keep keep-indexed))) + ("Seq in, Seq out" + ("Get shorter" + (clojure.core distinct filter remove take-nth for dedupe random-sample)) + ("Get longer" + (clojure.core cons conj concat lazy-cat mapcat cycle interleave interpose)) + ("Tail-items" + (clojure.core rest nthrest next fnext nnext drop drop-while take-last for)) + ("Head-items" + (clojure.core take take-while butlast drop-last for)) + ("Change" + (clojure.core conj concat distinct flatten group-by partition partition-all partition-by split-at split-with filter remove replace shuffle)) + ("Rearrange" + (clojure.core reverse sort sort-by compare)) + ("Process items" + (clojure.core map pmap map-indexed mapcat for replace seque))) + ("Using a Seq" + ("Extract item" + (clojure.core first second last rest next ffirst nfirst fnext nnext nth nthnext rand-nth when-first max-key min-key)) + ("Construct coll" + (clojure.core zipmap into reduce reductions set vec into-array to-array-2d mapv filterv)) + ("Pass to fn" + (clojure.core apply)) + ("Search" + (clojure.core some filter)) + ("Force evaluation" + (clojure.core doseq dorun doall run!)) + ("Check for forced" + (clojure.core realized?)))) + ("Transducers" + ("Off the shelf" + (clojure.core map mapcat filter remove take take-while take-nth drop drop-while replace partition-by partition-all keep keep-indexed map-indexed distinct interpose cat dedupe random-sample halt-when)) + ("Create your own" + (clojure.core completing ensure-reduced unreduced)) + ("Use" + (clojure.core into sequence transduce eduction)) + ("Early termination" + (clojure.core reduced reduced? deref))) + ("Spec" + ("Operations" + (clojure.spec.alpha valid? conform unform explain explain-data explain-str explain-out form describe assert check-asserts check-asserts?)) + ("Generator ops" + (clojure.spec.alpha gen exercise exercise-fn)) + ("Defn & Registry" + (clojure.spec.alpha def fdef registry get-spec spec? spec with-gen)) + ("Logical" + (clojure.spec.alpha and or)) + ("Collection" + (clojure.spec.alpha coll-of map-of every every-kv keys merge)) + ("Regex" + (clojure.spec.alpha cat alt * + \? & keys*)) + ("Range" + (clojure.spec.alpha int-in inst-in double-in int-in-range? inst-in-range?)) + ("Other" + (clojure.spec.alpha nilable multi-spec fspec conformer)) + ("Custom explain" + (clojure.spec.alpha explain-printer *explain-out*)) + ("Predicates with test.check generators" + ("Numbers" + (clojure.core number? rational? integer? ratio? decimal? float? zero? double? int? nat-int? neg-int? pos-int?)) + ("Symbols, keywords" + (clojure.core keyword? symbol? ident? qualified-ident? qualified-keyword? qualified-symbol? simple-ident? simple-keyword? simple-symbol?)) + ("Scalars" + (clojure.core string? true? false? nil? some? boolean? bytes? inst? uri? uuid?)) + ("Collections" + (clojure.core list? map? set? vector? associative? coll? sequential? seq? empty? indexed? seqable?)) + ("Other" + (clojure.core any?)))) + ("IO" + ("To/from ..." + (clojure.core spit slurp)) + ("To *out*" + (clojure.core pr prn print printf println newline) + (clojure.pprint print-table)) + ("To writer" + (clojure.pprint pprint cl-format)) + ("To string" + (clojure.core format with-out-str pr-str prn-str print-str println-str)) + ("From *in*" + (clojure.core read-line) + (clojure.edn read) + (clojure.tools.reader.edn read)) + ("From reader" + (clojure.core line-seq) + (clojure.edn read) + (clojure.tools.reader.edn read)) + ("From string" + (clojure.core with-in-str) + (clojure.edn read-string) + (clojure.tools.reader.edn read-string)) + ("Open" + (clojure.core with-open) + (clojure.java.io reader writer input-stream output-stream)) + ("Misc" + (clojure.core flush file-seq *in* *out* *err*) + (clojure.java.io file copy delete-file resource as-file as-url as-relative-path make-parents)) + ("Data readers" + (clojure.core *data-readers* default-data-readers *default-data-reader-fn*)) + ("Tap" + (clojure.core tap> add-tap remove-tap)) + ("Interop" + (clojure.java.io make-writer make-reader make-output-stream make-input-stream))) + ("Functions" + ("Create" + (:special fn) + (clojure.core defn defn- definline identity constantly memfn comp complement partial juxt memoize fnil every-pred some-fn)) + ("Call" + (clojure.core apply -> ->> trampoline as-> cond-> cond->> some-> some->>)) + ("Test" + (clojure.core fn? ifn?))) + ("Abstractions" + ("Protocols" + ("Define" + (clojure.core defprotocol)) + ("Extend" + (clojure.core extend-type)) + ("Reify" + (clojure.core reify)) + ("Test" + (clojure.core satisfies? extends?)) + ("Other" + (clojure.core extend extend-protocol extenders))) + ("Records" + ("Define" + (clojure.core defrecord)) + ("Test" + (clojure.core record?))) + ("Types" + ("Define" + (clojure.core deftype)) + ("With methods" + (clojure.core deftype))) + ("Multimethods" + ("Define" + (clojure.core defmulti)) + ("Method define" + (clojure.core defmethod)) + ("Dispatch" + (clojure.core get-method methods)) + ("Remove" + (clojure.core remove-method remove-all-methods)) + ("Prefer" + (clojure.core prefer-method prefers)) + ("Relation" + (clojure.core derive underive isa? parents ancestors descendants make-hierarchy)))) + ("Macros" + ("Create" + (clojure.core defmacro definline)) + ("Debug" + (clojure.core macroexpand-1 macroexpand) + (clojure.walk macroexpand-all)) + ("Branch" + (clojure.core and or when when-not when-let when-first if-not if-let cond condp case when-some if-some)) + ("Loop" + (clojure.core for doseq dotimes while)) + ("Arrange" + (clojure.core .. doto -> ->> as-> cond-> cond->> some-> some->>)) + ("Scope" + (clojure.core binding locking time with-in-str with-local-vars with-open with-out-str with-precision with-redefs with-redefs-fn)) + ("Lazy" + (clojure.core lazy-cat lazy-seq delay)) + ("Doc" + (clojure.core assert comment) + (clojure.repl doc))) + ("Metadata" + (clojure.core meta with-meta vary-meta alter-meta! reset-meta! test) + (clojure.repl doc find-doc)) + ("Special Forms" + ("General" + (:special def if do let letfn quote var fn loop recur set! throw try monitor-enter monitor-exit)) + ("Binding Forms / Destructuring" + (:special let fn loop) + (clojure.core defn defmacro for doseq if-let when-let if-some when-some))) + ("Vars and global environment" + ("Def variants" + (:special def) + (clojure.core defn defn- definline defmacro defmethod defmulti defonce defrecord)) + ("Interned vars" + (clojure.core declare intern binding find-var) + (:special var)) + ("Var objects" + (clojure.core with-local-vars var-get var-set alter-var-root var? bound? thread-bound?)) + ("Var validators" + (clojure.core set-validator! get-validator))) + ("Namespaces" + ("Current" + (clojure.core *ns*)) + ("Create/Switch" + (clojure.core ns in-ns create-ns)) + ("Add" + (clojure.core alias import intern refer) + (:special def)) + ("Find" + (clojure.core all-ns find-ns)) + ("Examine" + (clojure.core ns-name ns-aliases ns-map ns-interns ns-publics ns-refers ns-imports)) + ("From symbol" + (clojure.core resolve ns-resolve namespace the-ns requiring-resolve)) + ("Remove" + (clojure.core ns-unalias ns-unmap remove-ns))) + ("Loading" + ("Load libs" + (clojure.core require use import refer)) + ("List loaded" + (clojure.core loaded-libs)) + ("Load misc" + (clojure.core load load-file load-reader load-string))) + ("Concurrency" + ("Atoms" + (clojure.core atom swap! reset! compare-and-set! swap-vals! reset-vals!)) + ("Futures" + (clojure.core future future-call future-done? future-cancel future-cancelled? future?)) + ("Threads" + (clojure.core bound-fn bound-fn* get-thread-bindings push-thread-bindings pop-thread-bindings thread-bound?)) + ("Volatiles" + (clojure.core volatile! vreset! vswap! volatile?)) + ("Misc" + (clojure.core locking pcalls pvalues pmap seque promise deliver)) + ("Refs and Transactions" + ("Create" + (clojure.core ref)) + ("Examine" + (clojure.core deref)) + ("Transaction" + (clojure.core sync dosync io!)) + ("In transaction" + (clojure.core ensure ref-set alter commute)) + ("Validators" + (clojure.core set-validator! get-validator)) + ("History" + (clojure.core ref-history-count ref-min-history ref-max-history))) + ("Agents and Asynchronous Actions" + ("Create" + (clojure.core agent)) + ("Examine" + (clojure.core agent-error)) + ("Change state" + (clojure.core send send-off restart-agent send-via set-agent-send-executor! set-agent-send-off-executor!)) + ("Block waiting" + (clojure.core await await-for)) + ("Ref validators" + (clojure.core set-validator! get-validator)) + ("Watchers" + (clojure.core add-watch remove-watch)) + ("Thread handling" + (clojure.core shutdown-agents)) + ("Error" + (clojure.core error-handler set-error-handler! error-mode set-error-mode!)) + ("Misc" + (clojure.core *agent* release-pending-sends)))) + ("Java Interoperation" + ("General" + (clojure.core .. doto bean comparator enumeration-seq import iterator-seq memfn class class? bases supers type gen-class gen-interface definterface) + (:special new set!)) + ("Cast" + (clojure.core boolean byte short char int long float double bigdec bigint num cast biginteger)) + ("Exceptions" + (:special throw try catch finally) + (clojure.repl pst) + (clojure.core ex-info ex-data Throwable->map StackTraceElement->vec ex-cause ex-message) + (clojure.main ex-triage ex-str err->msg report-error)) + ("Arrays" + ("Create" + (clojure.core make-array object-array boolean-array byte-array short-array char-array int-array long-array float-array double-array aclone to-array to-array-2d into-array)) + ("Use" + (clojure.core aget aset aset-boolean aset-byte aset-short aset-char aset-int aset-long aset-float aset-double alength amap areduce)) + ("Cast" + (clojure.core booleans bytes shorts chars ints longs floats doubles))) + ("Proxy" + ("Create" + (clojure.core proxy get-proxy-class construct-proxy init-proxy)) + ("Misc" + (clojure.core proxy-mappings proxy-super update-proxy)))) + ("Zippers" + ("Create" + (clojure.zip zipper seq-zip vector-zip xml-zip)) + ("Get loc" + (clojure.zip up down left right leftmost rightmost)) + ("Get seq" + (clojure.zip lefts rights path children)) + ("Change" + (clojure.zip make-node replace edit insert-child insert-left insert-right append-child remove)) + ("Move" + (clojure.zip next prev)) + ("Misc" + (clojure.zip root node branch? end?)) + ("XML" + (clojure.data.zip.xml attr attr= seq-test tag= text text= xml-> xml1->))) + ("Other" + ("XML" + (clojure.xml parse) + (clojure.core xml-seq)) + ("REPL" + (clojure.core *1 *2 *3 *e *print-dup* *print-length* *print-level* *print-meta* *print-readably*)) + ("Code" + (clojure.core *compile-files* *compile-path* *file* *warn-on-reflection* compile loaded-libs test)) + ("Misc" + (clojure.core eval force hash *clojure-version* clojure-version *command-line-args* random-uuid)) + ("Browser / Shell" + (clojure.java.browse browse-url) + (clojure.java.shell sh with-sh-dir with-sh-env)) + ("EDN" + (clojure.edn read read-string)) + ("Pretty Printing" + (clojure.pprint pprint print-table pp *print-right-margin*)) + ("Compiling Code & Class Generation" + (clojure.core *compile-files* *compile-path* *file* *warn-on-reflection* compile gen-class gen-interface loaded-libs test))) + ("Reader Conditionals" + (clojure.core reader-conditional reader-conditional? tagged-literal tagged-literal?)) + ("Unit Tests" + ("Defining" + (clojure.test deftest deftest- testing is are)) + ("Running" + (clojure.test run-tests run-all-tests test-vars)) + ("Fixtures" + (clojure.test use-fixtures join-fixtures compose-fixtures))) + ("Async" + ("Main" + (clojure.core.async go go-loop ! >!! chan put! take take! close! timeout offer! poll! promise-chan)) + ("Choice" + (clojure.core.async alt! alt!! alts! alts!! do-alts)) + ("Buffering" + (clojure.core.async buffer dropping-buffer sliding-buffer unblocking-buffer?)) + ("Pipelines" + (clojure.core.async pipeline pipeline-async pipeline-blocking)) + ("Threading" + (clojure.core.async thread thread-call)) + ("Mixing" + (clojure.core.async admix solo-mode mix unmix unmix-all toggle merge pipe unique)) + ("Multiples" + (clojure.core.async mult tap untap untap-all)) + ("Publish/Subscribe" + (clojure.core.async pub sub unsub unsub-all)) + ("Higher Order" + (clojure.core.async filter< filter> map map< map> mapcat< mapcat> partition partition-by reduce remove< remove> split)) + ("Pre-Populate" + (clojure.core.async into onto-chan to-chan)))) + "A data structure for Clojure cheatsheet information. + +It's a tree, where the head of each list determines the context of the rest +of the list. The head may be: + + - A string, in which case it's a (sub)heading for the rest of the items. + + - A symbol, in which case it's the Clojure namespace of the symbols that + follow it. + + - The keyword :special, in which case it's a Clojure special form + + - Any other keyword, in which case it's a typed item that will be passed + through. + +Note that some Clojure symbols appear in more than once. This is entirely +intentional. For instance, `map` belongs in the sections on collections +and transducers.") + +(defun cider-cheatsheet--expand-vars (list) + "Expand the symbols in LIST to fully-qualified var names. + +This list is supposed to have the following format: + + (my-ns var1 var2 var3)" + (let ((ns (car list)) + (vars (cdr list))) + (if (eq ns :special) + (mapcar #'symbol-name vars) + (mapcar (lambda (var) (format "%s/%s" ns var)) vars)))) + +(defun cider-cheatsheet--flatten-hierarchy (hierarchy &optional sections) + "Transform HIERARCHY to lists each representing a path with SECTIONS before var." + (seq-mapcat (lambda (node) + (if (stringp (car node)) + (cider-cheatsheet--flatten-hierarchy (cdr node) (cons (car node) sections)) + (mapcar (lambda (var) (reverse (cons var sections))) + (cider-cheatsheet--expand-vars node)))) + hierarchy)) + +;;;###autoload +(defun cider-cheatsheet-select (&optional flat) + "Navigate cheatsheet sections and show documentation for selected var. + +With a prefix argument FLAT, represent each candidate as a full path to var." + (interactive "P") + (if flat + (let* ((hierarchy (cider-cheatsheet--flatten-hierarchy cider-cheatsheet-hierarchy)) + (paths (mapcar (lambda (sections) (string-join sections " > ")) hierarchy)) + (path (completing-read "Select path: " paths)) + (var (car (last (split-string path " > "))))) + (funcall cider-cheatsheet-default-action-function var)) + (let ((hierarchy cider-cheatsheet-hierarchy)) + (while (stringp (caar hierarchy)) + (let* ((sections (mapcar #'car hierarchy)) + (section (completing-read "Select section: " sections))) + (setq hierarchy (map-elt hierarchy section)))) + (let* ((vars (seq-mapcat #'cider-cheatsheet--expand-vars hierarchy)) + (var (completing-read "Select var: " vars))) + (funcall cider-cheatsheet-default-action-function var))))) + +(cl-defun cider-cheatsheet--insert-hierarchy (hierarchy &optional (level 0)) + "Insert HIERARCHY with visual indentation for LEVEL." + (dolist (node hierarchy) + (if (stringp (car node)) + (progn + (insert (make-string (* level 2) ?\s) (car node) "\n") + (cider-cheatsheet--insert-hierarchy (cdr node) (1+ level))) + (dolist (var (cider-cheatsheet--expand-vars node)) + (insert (make-string (* level 2) ?\s)) + (insert-text-button var + 'var var + 'action (lambda (btn) + (funcall cider-cheatsheet-default-action-function + (button-get btn 'var))) + 'help-echo (format "Show documentation for %s" var)) + (insert "\n"))))) + +(defun cider-cheatsheet--buffer-contents () + "Generate cheatsheet buffer contents based on the cheatsheet hierarchy." + (with-temp-buffer + (cider-cheatsheet--insert-hierarchy cider-cheatsheet-hierarchy) + (buffer-string))) + +;;;###autoload +(defun cider-cheatsheet () + "Display cheatsheet in a popup buffer." + (interactive) + (with-current-buffer (cider-popup-buffer cider-cheatsheet-buffer + cider-cheatsheet-auto-select-buffer) + (read-only-mode -1) + (insert (cider-cheatsheet--buffer-contents)) + (read-only-mode 1) + (goto-char (point-min)))) + +(provide 'cider-cheatsheet) + +;;; cider-cheatsheet.el ends here diff --git a/elpa/cider-20241203.1607/cider-classpath.el b/elpa/cider-20241203.1607/cider-classpath.el new file mode 100644 index 00000000..3ebe8650 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-classpath.el @@ -0,0 +1,109 @@ +;;; cider-classpath.el --- Basic Java classpath browser -*- lexical-binding: t; -*- + +;; Copyright © 2014-2024 Bozhidar Batsov and CIDER contributors + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Basic Java classpath browser for CIDER. + +;;; Code: + +(require 'cider-client) +(require 'cider-popup) +(require 'subr-x) + +(defvar cider-classpath-buffer "*cider-classpath*") + +(defvar cider-classpath-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map cider-popup-buffer-mode-map) + (define-key map (kbd "RET") #'cider-classpath-operate-on-point) + (define-key map "n" #'next-line) + (define-key map "p" #'previous-line) + map)) + +(defvar cider-classpath-mouse-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] #'cider-classpath-handle-mouse) + map)) + +(define-derived-mode cider-classpath-mode special-mode "classpath" + "Major mode for browsing the entries in Java's classpath. + +\\{cider-classpath-mode-map}" + (setq-local electric-indent-chars nil) + (setq-local sesman-system 'CIDER) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t))) + +(defun cider-classpath-list (buffer items) + "Populate BUFFER with ITEMS." + (with-current-buffer buffer + (cider-classpath-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (dolist (item items) + (insert item "\n")) + (goto-char (point-min))))) + +(defun cider-classpath-properties (text) + "Decorate TEXT with a clickable keymap and function face." + (let ((face (cond + ((not (file-exists-p text)) 'font-lock-warning-face) + ((file-directory-p text) 'dired-directory) + (t 'default)))) + (propertize text + 'font-lock-face face + 'mouse-face 'highlight + 'keymap cider-classpath-mouse-map))) + +(defun cider-classpath-operate-on-point () + "Expand browser according to thing at current point." + (interactive) + (let* ((bol (line-beginning-position)) + (eol (line-end-position)) + (line (buffer-substring-no-properties bol eol))) + (find-file-other-window line))) + +(defun cider-classpath-handle-mouse (_event) + "Handle mouse click EVENT." + (interactive "e") + (cider-classpath-operate-on-point)) + +;;;###autoload +(defun cider-classpath () + "List all classpath entries." + (interactive) + (cider-ensure-connected) + (with-current-buffer (cider-popup-buffer cider-classpath-buffer 'select nil 'ancillary) + (cider-classpath-list (current-buffer) + (mapcar (lambda (name) + (cider-classpath-properties name)) + (cider-classpath-entries))))) + +;;;###autoload +(defun cider-open-classpath-entry () + "Open a classpath entry." + (interactive) + (cider-ensure-connected) + (when-let* ((entry (completing-read "Classpath entries: " (cider-classpath-entries)))) + (find-file-other-window entry))) + +(provide 'cider-classpath) + +;;; cider-classpath.el ends here diff --git a/elpa/cider-20241203.1607/cider-client.el b/elpa/cider-20241203.1607/cider-client.el new file mode 100644 index 00000000..26b22299 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-client.el @@ -0,0 +1,904 @@ +;;; cider-client.el --- A layer of abstraction above low-level nREPL client code. -*- lexical-binding: t -*- + +;; Copyright © 2013-2024 Bozhidar Batsov +;; +;; Author: Bozhidar Batsov + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; A layer of abstraction above the low-level nREPL client code. + +;;; Code: + +(require 'map) +(require 'seq) +(require 'subr-x) +(require 'parseedn) + +(require 'clojure-mode) +(require 'spinner) + +(require 'cider-connection) +(require 'cider-completion-context) +(require 'cider-common) +(require 'cider-util) +(require 'nrepl-client) + + +;;; Eval spinner +(defcustom cider-eval-spinner-type 'progress-bar + "Appearance of the evaluation spinner. + +Value is a symbol. The possible values are the symbols in the +`spinner-types' variable." + :type 'symbol + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-show-eval-spinner t + "When true, show the evaluation spinner in the mode line." + :type 'boolean + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-eval-spinner-delay 1 + "Amount of time, in seconds, after which the evaluation spinner will be shown." + :type 'integer + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-enhanced-cljs-completion-p t + "This setting enables dynamic cljs completions. +That is, expressions at point are evaluated and the properties of the +resulting value are used to compute completions." + :type 'boolean + :group 'cider + :package-version '(cider . "0.23.0")) + +(defcustom cider-before-eval-hook nil + "List of functions to call before eval request is sent to nrepl." + :type 'hook + :group 'cider + :package-version '(cider . "1.2.0")) + +(defcustom cider-after-eval-done-hook nil + "List of functions to call after eval was responded by nrepl with done status." + :type 'hook + :group 'cider + :package-version '(cider . "1.2.0")) + +(defun cider-spinner-start (buffer) + "Start the evaluation spinner in BUFFER. +Do nothing if `cider-show-eval-spinner' is nil." + (when cider-show-eval-spinner + (with-current-buffer buffer + (spinner-start cider-eval-spinner-type nil + cider-eval-spinner-delay)))) + +(defun cider-eval-spinner (eval-buffer response) + "Handle RESPONSE stopping the spinner. +EVAL-BUFFER is the buffer where the spinner was started." + ;; buffer still exists and + ;; we've got status "done" from nrepl + ;; stop the spinner + (when (and (buffer-live-p eval-buffer) + (let ((status (nrepl-dict-get response "status"))) + (or (member "done" status) + (member "eval-error" status) + (member "error" status)))) + (with-current-buffer eval-buffer + (when spinner-current (spinner-stop))))) + + +;;; Evaluation helpers +(defun cider-ns-form-p (form) + "Check if FORM is an ns form." + (string-match-p "\\`[[:space:]]*\(ns\\([[:space:]]*$\\|[[:space:]]+\\)" form)) + +(defun cider-ns-from-form (ns-form) + "Get ns substring from NS-FORM." + (when (string-match "^[ \t\n]*\(ns[ \t\n]+\\([^][ \t\n(){}]+\\)" ns-form) + (match-string-no-properties 1 ns-form))) + +(defvar-local cider-buffer-ns nil + "Current Clojure namespace of some buffer. +Useful for special buffers (e.g. REPL, doc buffers) that have to keep track +of a namespace. This should never be set in Clojure buffers, as there the +namespace should be extracted from the buffer's ns form.") + +(defun cider-current-ns (&optional no-default no-repl-check) + "Return the current ns. +The ns is extracted from the ns form for Clojure buffers and from +`cider-buffer-ns' for all other buffers. If it's missing, use the current +REPL's ns, otherwise fall back to \"user\". +When NO-DEFAULT is non-nil, it will return nil instead of \"user\". +When NO-REPL-CHECK is non-nil, `cider-current-repl' will not be queried, +improving performance (at the possible cost of accuracy)." + (or cider-buffer-ns + (cider-get-ns-name) + (unless no-repl-check + (when-let* ((repl (cider-current-repl))) + (buffer-local-value 'cider-buffer-ns repl))) + (if no-default nil "user"))) + +(defun cider-path-to-ns (relpath) + "Transform RELPATH to Clojure namespace. +Remove extension and substitute \"/\" with \".\", \"_\" with \"-\"." + (thread-last + relpath + (file-name-sans-extension) + (replace-regexp-in-string "/" ".") + (replace-regexp-in-string "_" "-"))) + +(defun cider-expected-ns (&optional path) + "Return the namespace string matching PATH, or nil if not found. +If PATH is nil, use the path to the file backing the current buffer. The +command falls back to `clojure-expected-ns' in the absence of an active +nREPL connection." + (if (cider-connected-p) + (let* ((path (file-truename (or path buffer-file-name))) + (relpath (thread-last + (cider-classpath-entries) + (seq-filter #'file-directory-p) + (seq-map (lambda (dir) + (when (file-in-directory-p path dir) + (file-relative-name path dir)))) + (seq-filter #'identity) + (seq-sort (lambda (a b) + (< (length a) (length b)))) + (car)))) + (if relpath + (cider-path-to-ns relpath) + (clojure-expected-ns path))) + (clojure-expected-ns path))) + +(defun cider-nrepl-op-supported-p (op &optional connection skip-ensure) + "Check whether the CONNECTION supports the nREPL middleware OP. +Skip check if repl is active if SKIP-ENSURE is non nil." + (nrepl-op-supported-p op (or connection (cider-current-repl nil (if skip-ensure + nil + 'ensure))))) + +(defun cider-ensure-op-supported (op) + "Check for support of middleware op OP. +Signal an error if it is not supported." + (unless (cider-nrepl-op-supported-p op) + (user-error "`%s' requires the nREPL op \"%s\" (provided by cider-nrepl)" this-command op))) + +(defun cider-nrepl-send-request (request callback &optional connection tooling) + "Send REQUEST and register response handler CALLBACK. +REQUEST is a pair list of the form (\"op\" \"operation\" \"par1-name\" + \"par1\" ... ). +If CONNECTION is provided dispatch to that connection instead of +the current connection. Return the id of the sent message. +If TOOLING is truthy then the tooling session is used." + (nrepl-send-request request callback (or connection (cider-current-repl 'any 'ensure)) tooling)) + +(defun cider-nrepl-send-sync-request (request &optional connection abort-on-input) + "Send REQUEST to the nREPL server synchronously using CONNECTION. +Hold till final \"done\" message has arrived and join all response messages +of the same \"op\" that came along and return the accumulated response. +If ABORT-ON-INPUT is non-nil, the function will return nil +at the first sign of user input, so as not to hang the +interface." + (nrepl-send-sync-request request + (or connection (cider-current-repl 'any 'ensure)) + abort-on-input)) + +(defun cider-nrepl-send-unhandled-request (request &optional connection) + "Send REQUEST to the nREPL CONNECTION and ignore any responses. +Immediately mark the REQUEST as done. Return the id of the sent message." + (let* ((conn (or connection (cider-current-repl 'any 'ensure))) + (id (nrepl-send-request request #'ignore conn))) + (with-current-buffer conn + (nrepl--mark-id-completed id)) + id)) + +(defun cider-nrepl-request:eval (input callback &optional ns line column additional-params connection) + "Send the request INPUT and register the CALLBACK as the response handler. +If NS is non-nil, include it in the request. LINE and COLUMN, if non-nil, +define the position of INPUT in its buffer. ADDITIONAL-PARAMS is a plist +to be appended to the request message. CONNECTION is the connection +buffer, defaults to (cider-current-repl)." + (let ((connection (or connection (cider-current-repl nil 'ensure))) + (eval-buffer (current-buffer))) + (run-hooks 'cider-before-eval-hook) + (nrepl-request:eval input + (lambda (response) + (when cider-show-eval-spinner + (cider-eval-spinner connection response)) + (when (and (buffer-live-p eval-buffer) + (member "done" (nrepl-dict-get response "status"))) + (with-current-buffer eval-buffer + (run-hooks 'cider-after-eval-done-hook))) + (funcall callback response)) + connection + ns line column additional-params) + (cider-spinner-start connection))) + +(defun cider-nrepl-sync-request:eval (input &optional connection ns) + "Send the INPUT to the nREPL CONNECTION synchronously. +If NS is non-nil, include it in the eval request." + (nrepl-sync-request:eval input (or connection (cider-current-repl nil 'ensure)) ns)) + +(defcustom cider-format-code-options nil + "A map of options that will be passed to `cljfmt' to format code. +Assuming this is the Clojure map you want to use as `cljfmt' options: + + {:indents {org.me/foo [[:inner 0]]} + :alias-map {\"me\" \"org.me\"}} + +you need to encode it as the following plist: + + '((\"indents\" ((\"org.me/foo\" ((\"inner\" 0))))) (\"alias-map\" ((\"me\" \"org.me\"))))" + :type 'list + :group 'cider + :package-version '(cider . "1.1.0")) + +(defun cider--nrepl-format-code-request-map (&optional format-options) + "Map to merge into requests that require code formatting. +If non-nil, FORMAT-OPTIONS specifies the options cljfmt will use to format +the code. See `cider-format-code-options` for details." + (when format-options + (let* ((indents-dict (when (assoc "indents" format-options) + (thread-last + (cadr (assoc "indents" format-options)) + (map-pairs) + (seq-mapcat #'identity) + (apply #'nrepl-dict)))) + (alias-map-dict (when (assoc "alias-map" format-options) + (thread-last + (cadr (assoc "alias-map" format-options)) + (map-pairs) + (seq-mapcat #'identity) + (apply #'nrepl-dict))))) + (thread-last + (map-merge 'list + (when indents-dict + `(("indents" ,indents-dict))) + (when alias-map-dict + `(("alias-map" ,alias-map-dict)))) + (map-pairs) + (seq-mapcat #'identity) + (apply #'nrepl-dict))))) + +(defcustom cider-print-fn 'pprint + "Sets the function to use for printing. + +nil – to defer to nREPL to choose the printing function. This will use +the bound value of \\=`nrepl.middleware.print/*print-fn*\\=`, which +defaults to the equivalent of \\=`clojure.core/pr\\=`. + +`pr' – to use the equivalent of \\=`clojure.core/pr\\=`. + +`pprint' – to use \\=`clojure.pprint/pprint\\=` (this is the default). + +`fipp' – to use the Fast Idiomatic Pretty Printer, approximately 5-10x +faster than \\=`clojure.core/pprint\\=`. + +`puget' – to use Puget, which provides canonical serialization of data on +top of fipp, but at a slight performance cost. + +`zprint' – to use zprint, a fast and flexible alternative to the libraries +mentioned above. + +Alternatively can be the namespace-qualified name of a Clojure var whose +function takes three arguments: the object to print, the +\\=`java.io.PrintWriter\\=` to print on, and a (possibly nil) map of +options. If the function cannot be resolved, will behave as if set to +nil." + :type '(choice (const nil) + (const pr) + (const pprint) + (const fipp) + (const puget) + (const zprint) + string) + :group 'cider + :package-version '(cider . "0.21.0")) + +(defcustom cider-print-options nil + "A map of options that will be passed to `cider-print-fn'. +Here's an example for `pprint': + + '((\"length\" 50) (\"right-margin\" 70))" + :type 'list + :group 'cider + :package-version '(cider . "0.21.0")) + +(make-obsolete-variable 'cider-pprint-fn 'cider-print-fn "0.21") +(make-obsolete-variable 'cider-pprint-options 'cider-print-options "0.21") + +(defcustom cider-print-quota (* 1024 1024) + "A hard limit on the number of bytes to return from any printing operation. +Set to nil for no limit." + :type 'integer + :group 'cider + :package-version '(cider . "0.21.0")) + +(defcustom cider-print-buffer-size (* 4 1024) + "The size in bytes of each value/output chunk when using print streaming. +Smaller values mean smaller data chunks and faster feedback, but they also mean +smaller results that can be font-locked as Clojure in the REPL buffers, as only +a single chunk result can be font-locked. + +The default value in nREPL is 1024." + :type 'integer + :group 'cider + :package-version '(cider . "0.25.0")) + +(defun cider--print-fn () + "Return the value to send in the nrepl.middleware.print/print slot." + (pcase cider-print-fn + (`pr "cider.nrepl.pprint/pr") + (`pprint "cider.nrepl.pprint/pprint") + (`fipp "cider.nrepl.pprint/fipp-pprint") + (`puget "cider.nrepl.pprint/puget-pprint") + (`zprint "cider.nrepl.pprint/zprint-pprint") + (_ cider-print-fn))) + +(defvar cider--print-options-mapping + '((right-margin + ((fipp . width) (puget . width) (zprint . width))) + (length + ((fipp . print-length) (puget . print-length) (zprint . max-length))) + (level + ((fipp . print-level) (puget . print-level) (zprint . max-depth)))) + "A mapping of print option for the various supported print engines.") + +(defun cider--print-option (name printer) + "Convert the generic NAME to its PRINTER specific variant. +E.g. pprint's right-margin would become width for fipp. +The function is useful when you want to generate dynamically +print options. + +NAME can be a string or a symbol. PRINTER has to be a symbol. +The result will be a string." + (let* ((name (cider-maybe-intern name)) + (result (cdr (assoc printer (cadr (assoc name cider--print-options-mapping)))))) + (symbol-name (or result name)))) + +(defun cider--nrepl-print-request-map (&optional right-margin) + "Map to merge into requests that require pretty-printing. +RIGHT-MARGIN specifies the maximum column-width of the printed result, and +is included in the request if non-nil." + (let* ((width-option (cider--print-option "right-margin" cider-print-fn)) + (print-options (thread-last + (map-merge 'hash-table + `((,width-option ,right-margin)) + cider-print-options) + (map-pairs) + (seq-mapcat #'identity) + (apply #'nrepl-dict)))) + (map-merge 'list + `(("nrepl.middleware.print/stream?" "1")) + (when cider-print-fn + `(("nrepl.middleware.print/print" ,(cider--print-fn)))) + (when cider-print-quota + `(("nrepl.middleware.print/quota" ,cider-print-quota))) + (when cider-print-buffer-size + `(("nrepl.middleware.print/buffer-size" ,cider-print-buffer-size))) + (unless (nrepl-dict-empty-p print-options) + `(("nrepl.middleware.print/options" ,print-options)))))) + +(defun cider--nrepl-pr-request-map () + "Map to merge into requests that do not require pretty printing." + (let ((print-options (thread-last + cider-print-options + (map-pairs) + (seq-mapcat #'identity) + (apply #'nrepl-dict)))) + (map-merge 'list + `(("nrepl.middleware.print/print" "cider.nrepl.pprint/pr") + ("nrepl.middleware.print/stream?" nil)) + (unless (nrepl-dict-empty-p print-options) + `(("nrepl.middleware.print/options" ,print-options))) + (when cider-print-quota + `(("nrepl.middleware.print/quota" ,cider-print-quota)))))) + +(defun cider--nrepl-content-type-map () + "Map to be merged into an eval request to make it use content-types." + '(("content-type" "true"))) + +(defun cider-tooling-eval (input callback &optional ns connection) + "Send the request INPUT to CONNECTION and register the CALLBACK. +NS specifies the namespace in which to evaluate the request. Requests +evaluated in the tooling nREPL session don't affect the thread-local +bindings of the primary eval nREPL session (e.g. this is not going to +clobber *1/2/3)." + ;; namespace forms are always evaluated in the "user" namespace + (nrepl-request:eval input + callback + (or connection (cider-current-repl nil 'ensure)) + ns nil nil nil 'tooling)) + +(defun cider-sync-tooling-eval (input &optional ns connection) + "Send the request INPUT to CONNECTION and evaluate in synchronously. +NS specifies the namespace in which to evaluate the request. Requests +evaluated in the tooling nREPL session don't affect the thread-local +bindings of the primary eval nREPL session (e.g. this is not going to +clobber *1/2/3)." + ;; namespace forms are always evaluated in the "user" namespace + (nrepl-sync-request:eval input + (or connection (cider-current-repl nil 'ensure)) + ns + 'tooling)) + +(defun cider-library-present-p (lib-ns) + "Check whether LIB-NS is present. +If a certain well-known ns in a library is present we assume that library +itself is present." + (nrepl-dict-get (cider-sync-tooling-eval (format "(require '%s)" lib-ns)) "value")) + + +;;; Interrupt evaluation + +(defun cider-interrupt-handler (buffer) + "Create an interrupt response handler for BUFFER." + (nrepl-make-response-handler buffer nil nil nil nil)) + +(defun cider-interrupt () + "Interrupt any pending evaluations." + (interactive) + ;; FIXME: does this work correctly in cljc files? + (with-current-buffer (cider-current-repl nil 'ensure) + (let ((pending-request-ids (cider-util--hash-keys nrepl-pending-requests))) + (dolist (request-id pending-request-ids) + (nrepl-request:interrupt + request-id + (cider-interrupt-handler (current-buffer)) + (cider-current-repl)))))) + +(defun cider-nrepl-eval-session () + "Return the eval nREPL session id of the current connection." + (with-current-buffer (cider-current-repl) + nrepl-session)) + +(defun cider-nrepl-tooling-session () + "Return the tooling nREPL session id of the current connection." + (with-current-buffer (cider-current-repl) + nrepl-tooling-session)) + +(declare-function ido-exit-minibuffer "ido" t) + +;; Not used anywhere, except in documentation as a suggestion for users. +(defmacro cider--with-temporary-ido-keys (UP DOWN &rest body) + "Temporarily define UP, DOWN keys for ido and execute BODY. + +This makes the UX for auto-completion more streamlined, +since one often wants to go to the next candidate (DOWN key) +without having to specify a Java class for the current candidate +\(because the current candidate may be irrelevant to the user)." + `(if (bound-and-true-p ido-common-completion-map) + (let ((original-up-binding (lookup-key ido-common-completion-map (kbd ,UP))) + (original-down-binding (lookup-key ido-common-completion-map (kbd ,DOWN)))) + (define-key ido-common-completion-map (kbd ,UP) (lambda () + (interactive) + (ido-exit-minibuffer))) + (define-key ido-common-completion-map (kbd ,DOWN) (lambda () + (interactive) + (ido-exit-minibuffer))) + (unwind-protect + (progn ,@body) + (define-key ido-common-completion-map (kbd ,UP) original-up-binding) + (define-key ido-common-completion-map (kbd ,DOWN) original-down-binding))) + ,@body)) + +(defun cider-class-choice-completing-read (prompt candidates) + "A completing read that can be customized with the `advice' mechanism, +forwarding PROMPT and CANDIDATES as-is. + +See also: `cider--with-temporary-ido-keys'." + (completing-read prompt candidates)) + +(defun cider--var-choice (var-info) + "Prompt to choose from among multiple VAR-INFO candidates, if required. +This is needed only when the symbol queried is an unqualified host platform +method, and multiple classes have a so-named member. If VAR-INFO does not +contain a `candidates' key, it is returned as is." + (let ((candidates (nrepl-dict-get var-info "candidates"))) + (if candidates + (let* ((classes (nrepl-dict-keys candidates)) + (choice (cider-class-choice-completing-read "Member in class: " classes)) + (info (nrepl-dict-get candidates choice))) + info) + var-info))) + +;; FIXME: Now that nREPL supports a lookup op natively, we should +;; remove this eval-based hack at some point. +(defconst cider-info-form " +(do + (require 'clojure.java.io) + (require 'clojure.walk) + + (if-let [var (resolve '%s)] + (let [info (meta var)] + (-> info + (update :ns str) + (update :name str) + (update :file (comp str clojure.java.io/resource)) + (cond-> (:macro info) (update :macro str)) + (cond-> (:special-form info) (update :special-form str)) + (cond-> (:protocol info) (update :protocol str)) + (cond-> (:arglists info) (update :arglists str)) + (assoc :arglists-str (str (:arglists info))) + (clojure.walk/stringify-keys))))) +") + +(defun cider-fallback-eval:info (var) + "Obtain VAR metadata via a regular eval. +Used only when the info nREPL middleware is not available." + (let* ((response (cider-sync-tooling-eval (format cider-info-form var))) + (var-info (nrepl-dict-from-hash (parseedn-read-str (nrepl-dict-get response "value"))))) + var-info)) + +(defun cider-var-info (var &optional all) + "Return info for VAR as an nREPL dict. +When multiple matching vars are returned you'll be prompted to select one, +unless ALL is truthy." + (when (and var (not (string= var ""))) + (let ((var-info (cond + ((cider-nrepl-op-supported-p "info") (cider-sync-request:info var nil nil (cider-completion-get-context t))) + ((cider-nrepl-op-supported-p "lookup") (cider-sync-request:lookup var)) + (t (cider-fallback-eval:info var))))) + (if all var-info (cider--var-choice var-info))))) + +(defun cider-member-info (class member) + "Return info for MEMBER of CLASS as an nREPL dict." + (when (and class member) + (cider-sync-request:info nil class member (cider-completion-get-context t)))) + + +;;; Requests + +(declare-function cider-load-file-handler "cider-eval") +(defun cider-request:load-file (file-contents file-path file-name &optional connection callback) + "Perform the nREPL \"load-file\" op. +FILE-CONTENTS, FILE-PATH and FILE-NAME are details of the file to be +loaded. If CONNECTION is nil, use `cider-current-repl'. If CALLBACK +is nil, use `cider-load-file-handler'." + (cider-nrepl-send-request `("op" "load-file" + "file" ,file-contents + "file-path" ,file-path + "file-name" ,file-name) + (or callback + (cider-load-file-handler (current-buffer))) + connection)) + + +;;; Sync Requests + +(defcustom cider-filtered-namespaces-regexps + '("^cider.nrepl" "^refactor-nrepl" "^nrepl") + "List of regexps used to filter out some vars/symbols/namespaces. +When nil, nothing is filtered out. Otherwise, all namespaces matching any +regexp from this list are dropped out of the \"ns-list\" op. Also, +\"apropos\" won't include vars from such namespaces. This list is passed +on to the nREPL middleware without any pre-processing. So the regexps have +to be in Clojure format (with twice the number of backslashes) and not +Emacs Lisp." + :type '(repeat string) + :safe #'listp + :group 'cider + :package-version '(cider . "0.13.0")) + +(defun cider-sync-request:apropos (query &optional search-ns docs-p privates-p case-sensitive-p) + "Send \"apropos\" request for regexp QUERY. + +Optional arguments include SEARCH-NS, DOCS-P, PRIVATES-P, CASE-SENSITIVE-P." + (let* ((query (replace-regexp-in-string "[ \t]+" ".+" query)) + (response (cider-nrepl-send-sync-request + `("op" "apropos" + "ns" ,(cider-current-ns) + "query" ,query + ,@(when search-ns `("search-ns" ,search-ns)) + ,@(when docs-p '("docs?" "t")) + ,@(when privates-p '("privates?" "t")) + ,@(when case-sensitive-p '("case-sensitive?" "t")) + "exclude-regexps" ,cider-filtered-namespaces-regexps)))) + (if (member "apropos-regexp-error" (nrepl-dict-get response "status")) + (user-error "Invalid regexp: %s" (nrepl-dict-get response "error-msg")) + (nrepl-dict-get response "apropos-matches")))) + +(defun cider-sync-request:classpath () + "Return a list of classpath entries." + (cider-ensure-op-supported "classpath") + (thread-first + '("op" "classpath") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "classpath"))) + +(defun cider--get-abs-path (path project) + "Resolve PATH to an absolute path relative to PROJECT. +Do nothing if PATH is already absolute." + (if (not (file-name-absolute-p path)) + (expand-file-name path project) + path)) + +(defun cider-fallback-eval:classpath () + "Return a list of classpath entries using eval. + +Sometimes the classpath contains entries like src/main and we need to +resolve those to absolute paths." + (when (cider-runtime-clojure-p) + (let ((classpath (thread-first + "(seq (.split (System/getProperty \"java.class.path\") \":\"))" + (cider-sync-tooling-eval) + (nrepl-dict-get "value") + read)) + (project (clojure-project-dir))) + (mapcar (lambda (path) (cider--get-abs-path path project)) classpath)))) + +(defun cider-classpath-entries () + "Return a list of classpath entries." + (seq-map #'expand-file-name ; normalize filenames for e.g. Windows + (if (cider-nrepl-op-supported-p "classpath") + (cider-sync-request:classpath) + (cider-fallback-eval:classpath)))) + +(defun cider-sync-request:completion (prefix) + "Return a list of completions for PREFIX using nREPL's \"completion\" op." + (when-let* ((dict (thread-first `("op" "completions" + "ns" ,(cider-current-ns) + "prefix" ,prefix) + (cider-nrepl-send-sync-request (cider-current-repl) + 'abort-on-input)))) + (nrepl-dict-get dict "completions"))) + +(defun cider-sync-request:complete (prefix context) + "Return a list of completions for PREFIX using nREPL's \"complete\" op. +CONTEXT represents a completion context for compliment." + (when-let* ((dict (thread-first `("op" "complete" + "ns" ,(cider-current-ns) + "prefix" ,prefix + "context" ,context + ,@(when cider-enhanced-cljs-completion-p '("enhanced-cljs-completion?" "t"))) + (cider-nrepl-send-sync-request (cider-current-repl) + 'abort-on-input)))) + (nrepl-dict-get dict "completions"))) + +(defun cider-sync-request:complete-flush-caches () + "Send \"complete-flush-caches\" op to flush Compliment's caches." + (cider-nrepl-send-sync-request (list "op" "complete-flush-caches" + "session" (cider-nrepl-eval-session)) + nil + 'abort-on-input)) + +(defun cider-sync-request:info (symbol &optional class member context) + "Send \"info\" op with parameters SYMBOL or CLASS and MEMBER, honor CONTEXT." + (let ((var-info (thread-first `("op" "info" + "ns" ,(cider-current-ns) + ,@(when symbol `("sym" ,symbol)) + ,@(when class `("class" ,class)) + ,@(when member `("member" ,member)) + ,@(when context `("context" ,context))) + (cider-nrepl-send-sync-request (cider-current-repl))))) + (if (member "no-info" (nrepl-dict-get var-info "status")) + nil + var-info))) + +(defun cider-sync-request:lookup (symbol &optional lookup-fn) + "Send \"lookup\" op request with parameters SYMBOL and LOOKUP-FN." + (let ((var-info (thread-first `("op" "lookup" + "ns" ,(cider-current-ns) + ,@(when symbol `("sym" ,symbol)) + ,@(when lookup-fn `("lookup-fn" ,lookup-fn))) + (cider-nrepl-send-sync-request (cider-current-repl))))) + (if (member "lookup-error" (nrepl-dict-get var-info "status")) + nil + (nrepl-dict-get var-info "info")))) + +(defun cider-sync-request:eldoc (symbol &optional class member context) + "Send \"eldoc\" op with parameters SYMBOL or CLASS and MEMBER, honor CONTEXT." + (when-let* ((eldoc (thread-first `("op" "eldoc" + "ns" ,(cider-current-ns) + ,@(when symbol `("sym" ,symbol)) + ,@(when class `("class" ,class)) + ,@(when member `("member" ,member)) + ,@(when context `("context" ,context))) + (cider-nrepl-send-sync-request (cider-current-repl) + 'abort-on-input)))) + (if (member "no-eldoc" (nrepl-dict-get eldoc "status")) + nil + eldoc))) + +(defun cider-sync-request:eldoc-datomic-query (symbol) + "Send \"eldoc-datomic-query\" op with parameter SYMBOL." + (when-let* ((eldoc (thread-first `("op" "eldoc-datomic-query" + "ns" ,(cider-current-ns) + ,@(when symbol `("sym" ,symbol))) + (cider-nrepl-send-sync-request nil 'abort-on-input)))) + (if (member "no-eldoc" (nrepl-dict-get eldoc "status")) + nil + eldoc))) + +(defun cider-sync-request:spec-list (&optional filter-regex) + "Get a list of the available specs in the registry. +Optional argument FILTER-REGEX filters specs. By default, all specs are +returned." + (setq filter-regex (or filter-regex "")) + (thread-first `("op" "spec-list" + "filter-regex" ,filter-regex + "ns" ,(cider-current-ns)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "spec-list"))) + +(defun cider-sync-request:spec-form (spec) + "Get SPEC's form from registry." + (thread-first `("op" "spec-form" + "spec-name" ,spec + "ns" ,(cider-current-ns)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "spec-form"))) + +(defun cider-sync-request:spec-example (spec) + "Get an example for SPEC." + (thread-first `("op" "spec-example" + "spec-name" ,spec) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "spec-example"))) + +(defun cider-sync-request:ns-list () + "Get a list of the available namespaces." + (thread-first `("op" "ns-list" + "exclude-regexps" ,cider-filtered-namespaces-regexps) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "ns-list"))) + +(defun cider-sync-request:ns-vars (ns) + "Get a list of the vars in NS." + (thread-first `("op" "ns-vars" + "ns" ,ns) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "ns-vars"))) + +(defun cider-sync-request:ns-path (ns &optional favor-url) + "Get the path to the file containing NS, FAVOR-URL if specified. + +FAVOR-URL ensures a Java URL is returned. + +* This always is the case if the underlying runtime is JVM Clojure. +* For ClojureScript, the default is a resource name. + * This often cannot be open by `cider-find-file' + (unless there was already a buffer opening that file) + +Generally, you always want to FAVOR-URL. +The option is kept for backwards compatibility. + +Note that even when favoring a url, the url itself might be nil, +in which case we'll fall back to the resource name." + (unless ns + (error "No ns provided")) + (let ((response (cider-nrepl-send-sync-request `("op" "ns-path" + "ns" ,ns)))) + (nrepl-dbind-response response (path url) + (if (and favor-url url) + url + path)))) + +(defun cider-sync-request:ns-vars-with-meta (ns) + "Get a map of the vars in NS to its metadata information." + (thread-first `("op" "ns-vars-with-meta" + "ns" ,ns) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "ns-vars-with-meta"))) + +(defun cider-sync-request:private-ns-vars-with-meta (ns) + "Get a map of the vars in NS to its metadata information." + (thread-first `("op" "ns-vars-with-meta" + "ns" ,ns + "var-query" ,(nrepl-dict "private?" "t" + "include-meta-key" '("private"))) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "ns-vars-with-meta"))) + +(defun cider-sync-request:ns-load-all () + "Load all project namespaces." + (thread-first '("op" "ns-load-all") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "loaded-ns"))) + +(defun cider-sync-request:resource (name) + "Perform nREPL \"resource\" op with resource name NAME." + (thread-first `("op" "resource" + "name" ,name) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "resource-path"))) + +(defun cider-sync-request:resources-list () + "Return a list of all resources on the classpath. +The result entries are relative to the classpath." + (when-let* ((resources (thread-first '("op" "resources-list") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "resources-list")))) + (seq-map (lambda (resource) (nrepl-dict-get resource "relpath")) resources))) + +(defun cider-sync-request:fn-refs (ns sym) + "Return a list of functions that reference the function identified by NS and SYM." + (cider-ensure-op-supported "fn-refs") + (thread-first `("op" "fn-refs" + "ns" ,ns + "sym" ,sym) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "fn-refs"))) + +(defun cider-sync-request:fn-deps (ns sym) + "Return a list of function deps for the function identified by NS and SYM." + (cider-ensure-op-supported "fn-deps") + (thread-first `("op" "fn-deps" + "ns" ,ns + "sym" ,sym) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "fn-deps"))) + +(defun cider-sync-request:format-code (code &optional format-options) + "Perform nREPL \"format-code\" op with CODE. +FORMAT-OPTIONS is an optional configuration map for cljfmt." + (let* ((request `("op" "format-code" + "options" ,(cider--nrepl-format-code-request-map format-options) + "code" ,code)) + (response (cider-nrepl-send-sync-request request)) + (err (nrepl-dict-get response "err"))) + (when err + ;; err will be a stacktrace with a first line that looks like: + ;; "clojure.lang.ExceptionInfo: Unmatched delimiter ]" + (error (car (split-string err "\n")))) + (nrepl-dict-get response "formatted-code"))) + +(defun cider-sync-request:format-edn (edn right-margin) + "Perform \"format-edn\" op with EDN and RIGHT-MARGIN." + (let* ((request (thread-last + (map-merge 'list + `(("op" "format-edn") + ("edn" ,edn)) + (cider--nrepl-print-request-map right-margin)) + (seq-mapcat #'identity))) + (response (cider-nrepl-send-sync-request request)) + (err (nrepl-dict-get response "err"))) + (when err + ;; err will be a stacktrace with a first line that looks like: + ;; "clojure.lang.ExceptionInfo: Unmatched delimiter ]" + (error (car (split-string err "\n")))) + (nrepl-dict-get response "formatted-edn"))) + +;;; Dealing with input +;; TODO: Replace this with some nil handler. +(defun cider-stdin-handler (&optional _buffer) + "Make a stdin response handler for _BUFFER." + (nrepl-make-response-handler (current-buffer) + (lambda (_buffer _value)) + (lambda (_buffer _out)) + (lambda (_buffer _err)) + nil)) + +(defun cider-need-input (buffer) + "Handle an need-input request from BUFFER." + (with-current-buffer buffer + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map (kbd "C-c C-c") #'abort-recursive-edit) + (let ((stdin (condition-case nil + (concat (read-from-minibuffer "Stdin: " nil map) "\n") + (quit nil)))) + (nrepl-request:stdin stdin + (cider-stdin-handler buffer) + (cider-current-repl)))))) + +(provide 'cider-client) + +;;; cider-client.el ends here diff --git a/elpa/cider-20241203.1607/cider-clojuredocs.el b/elpa/cider-20241203.1607/cider-clojuredocs.el new file mode 100644 index 00000000..bfe8800d --- /dev/null +++ b/elpa/cider-20241203.1607/cider-clojuredocs.el @@ -0,0 +1,203 @@ +;;; cider-clojuredocs.el --- ClojureDocs integration -*- lexical-binding: t -*- + +;; Copyright © 2014-2024 Bozhidar Batsov and CIDER contributors +;; +;; Author: Bozhidar Batsov + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; A few commands for ClojureDocs documentation lookup. + +;;; Code: + +(require 'subr-x) +(require 'url-vars) + +(require 'cider-client) +(require 'cider-common) +(require 'cider-docstring) +(require 'cider-popup) +(require 'cider-util) +(require 'nrepl-dict) + +(defconst cider-clojuredocs-url "https://clojuredocs.org/") + +(defconst cider-clojuredocs-buffer "*cider-clojuredocs*") + +(defun cider-sync-request:clojuredocs-lookup (ns sym) + "Perform nREPL \"clojuredocs-lookup\" op with NS and SYM." + (thread-first `("op" "clojuredocs-lookup" + "ns" ,ns + "sym" ,sym) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "clojuredocs"))) + +(defun cider-sync-request:clojuredocs-refresh () + "Refresh the ClojureDocs cache." + (thread-first '("op" "clojuredocs-refresh-cache") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "status"))) + +(defun cider-clojuredocs-replace-special (name) + "Convert the dashes in NAME to a ClojureDocs friendly format. +We need to handle \"?\", \".\", \"..\" and \"/\"." + (thread-last + name + (replace-regexp-in-string "\\?" "_q") + (replace-regexp-in-string "\\(\\.+\\)" "_\\1") + (replace-regexp-in-string "/" "fs"))) + +(defun cider-clojuredocs-url (name ns) + "Generate a ClojureDocs url from NAME and NS." + (let ((base-url cider-clojuredocs-url)) + (when (and name ns) + (concat base-url ns "/" (cider-clojuredocs-replace-special name))))) + +(defun cider-clojuredocs-web-lookup (sym) + "Open the ClojureDocs documentation for SYM in a web browser." + (if-let* ((var-info (cider-var-info sym))) + (let ((name (nrepl-dict-get var-info "name")) + (ns (nrepl-dict-get var-info "ns"))) + (browse-url (cider-clojuredocs-url name ns))) + (error "Symbol %s not resolved" sym))) + +;;;###autoload +(defun cider-clojuredocs-web (&optional arg) + "Open ClojureDocs documentation in the default web browser. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates." + (interactive "P") + (funcall (cider-prompt-for-symbol-function arg) + "ClojureDocs doc for" + #'cider-clojuredocs-web-lookup)) + +;;;###autoload +(defun cider-clojuredocs-refresh-cache () + "Refresh the ClojureDocs cache." + (interactive) + (let ((result (cider-sync-request:clojuredocs-refresh))) + (if (member "ok" result) + (message "ClojureDocs cache refreshed successfully") + (message "An error occurred while trying to refresh the ClojureDocs cache")))) + +(defun cider-create-clojuredocs-buffer (content) + "Create a new ClojureDocs buffer with CONTENT." + (with-current-buffer (cider-popup-buffer cider-clojuredocs-buffer t) + (read-only-mode -1) + (set-syntax-table clojure-mode-syntax-table) + (local-set-key (kbd "C-c C-d C-c") 'cider-clojuredocs) + (insert content) + (cider-popup-buffer-mode 1) + (view-mode 1) + (goto-char (point-min)) + (current-buffer))) + +(defun cider-clojuredocs--insert-overview (dict) + "Insert \"Overview\" section based on data from DICT." + (insert (format "= %s/%s\n" + (nrepl-dict-get dict "ns") + (nrepl-dict-get dict "name"))) + (newline) + (when-let ((arglists (nrepl-dict-get dict "arglists"))) + (dolist (arglist arglists) + (insert (format " [%s]\n" arglist))) + (newline)) + (when-let* ((doc (nrepl-dict-get dict "doc")) + (doc (cider-docstring--format doc))) + (insert doc "\n") + (newline))) + +(defun cider-clojuredocs--insert-see-also (dict) + "Insert \"See Also\" section based on data from DICT." + (insert "== See Also\n") + (newline) + (if-let ((see-alsos (nrepl-dict-get dict "see-alsos"))) + (dolist (see-also see-alsos) + (insert "* ") + (insert-text-button see-also + 'sym see-also + 'action (lambda (btn) + (cider-clojuredocs-lookup (button-get btn 'sym))) + 'help-echo (format "Press Enter or middle click to jump to %s" see-also)) + (insert "\n")) + (insert "Not available\n")) + (newline)) + +(defun cider-clojuredocs--insert-examples (dict) + "Insert \"Examples\" section based on data from DICT." + (insert "== Examples\n") + (newline) + (if-let ((examples (nrepl-dict-get dict "examples"))) + (dolist (example examples) + (insert (cider-font-lock-as-clojure example) "\n") + (insert "-------------------------------------------------\n")) + (insert "Not available\n")) + (newline)) + +(defun cider-clojuredocs--insert-notes (dict) + "Insert \"Notes\" section based on data from DICT." + (insert "== Notes\n") + (newline) + (if-let ((notes (nrepl-dict-get dict "notes"))) + (dolist (note notes) + (insert note "\n") + (insert "-------------------------------------------------\n")) + (insert "Not available\n")) + (newline)) + +(defun cider-clojuredocs--content (dict) + "Generate a nice string from DICT." + (with-temp-buffer + (cider-clojuredocs--insert-overview dict) + (cider-clojuredocs--insert-see-also dict) + (cider-clojuredocs--insert-examples dict) + (cider-clojuredocs--insert-notes dict) + (buffer-string))) + +(defun cider-clojuredocs-lookup (sym) + "Look up the ClojureDocs documentation for SYM." + (if-let ((docs (cider-sync-request:clojuredocs-lookup (cider-current-ns) sym))) + (progn + (pop-to-buffer (cider-create-clojuredocs-buffer (cider-clojuredocs--content docs))) + ;; highlight the symbol in question in the docs buffer + (highlight-regexp + (regexp-quote + (or (cadr (split-string sym "/")) + sym)) + 'bold)) + (user-error "ClojureDocs documentation for %s is not found" sym))) + +;;;###autoload +(defun cider-clojuredocs (&optional arg) + "Open ClojureDocs documentation in a popup buffer. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates." + (interactive "P") + (when (cider-clojurescript-major-mode-p) + (user-error "`cider-clojuredocs' doesn't support ClojureScript")) + (funcall (cider-prompt-for-symbol-function arg) + "ClojureDocs doc for" + #'cider-clojuredocs-lookup)) + +(provide 'cider-clojuredocs) + +;;; cider-clojuredocs.el ends here diff --git a/elpa/cider-20241203.1607/cider-common.el b/elpa/cider-20241203.1607/cider-common.el new file mode 100644 index 00000000..f3e6582f --- /dev/null +++ b/elpa/cider-20241203.1607/cider-common.el @@ -0,0 +1,467 @@ +;;; cider-common.el --- Common use functions -*- lexical-binding: t; -*- + +;; Copyright © 2015-2024 Artur Malabarba + +;; Author: Artur Malabarba + +;; 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 . + +;;; Commentary: + +;; Common functions that are useful in both Clojure buffers and REPL +;; buffers. + +;;; Code: + +(require 'subr-x) +(require 'nrepl-dict) +(require 'cider-util) +(require 'xref) +(require 'tramp) + +(defcustom cider-prompt-for-symbol nil + "Controls when to prompt for symbol when a command requires one. + +When non-nil, always prompt, and use the symbol at point as the default +value at the prompt. + +When nil, attempt to use the symbol at point for the command, and only +prompt if that throws an error." + :type '(choice (const :tag "always" t) + (const :tag "dwim" nil)) + :group 'cider + :package-version '(cider . "0.9.0")) + +(defcustom cider-special-mode-truncate-lines t + "If non-nil, contents of CIDER's special buffers will be line-truncated. +Should be set before loading CIDER." + :type 'boolean + :group 'cider + :package-version '(cider . "0.15.0")) + +(defun cider--should-prompt-for-symbol (&optional invert) + "Return the value of the variable `cider-prompt-for-symbol'. +Optionally invert the value, if INVERT is truthy." + (if invert (not cider-prompt-for-symbol) cider-prompt-for-symbol)) + +(defun cider-prompt-for-symbol-function (&optional invert) + "Prompt for symbol if funcall `cider--should-prompt-for-symbol' is truthy. +Otherwise attempt to use the symbol at point for the command, and only +prompt if that throws an error. + +INVERT inverts the semantics of the function `cider--should-prompt-for-symbol'." + (if (cider--should-prompt-for-symbol invert) + #'cider-read-symbol-name + #'cider-try-symbol-at-point)) + +(defun cider--kw-to-symbol (kw) + "Convert the keyword KW to a symbol." + (when kw + (replace-regexp-in-string "\\`:+" "" kw))) + +;;; Minibuffer +(defvar cider-minibuffer-history '() + "History list of expressions read from the minibuffer.") + +(defvar cider-minibuffer-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map (kbd "TAB") #'complete-symbol) + (define-key map (kbd "M-TAB") #'complete-symbol) + map) + "Minibuffer keymap used for reading Clojure expressions.") + +(declare-function cider-complete-at-point "cider-completion") +(declare-function cider-eldoc "cider-eldoc") +(defun cider-read-from-minibuffer (prompt &optional value skip-colon) + "Read a string from the minibuffer, prompting with PROMPT. +If VALUE is non-nil, it is inserted into the minibuffer as initial-input. +PROMPT need not end with \": \". If it doesn't, VALUE is displayed on the +prompt as a default value (used if the user doesn't type anything) and is +not used as initial input (input is left empty). +If SKIP-COLON is non-nil, no \": \" is forced at the end of the prompt." + (minibuffer-with-setup-hook + (lambda () + (set-syntax-table clojure-mode-syntax-table) + (add-hook 'completion-at-point-functions + #'cider-complete-at-point nil t) + (setq-local eldoc-documentation-function #'cider-eldoc) + (run-hooks 'eval-expression-minibuffer-setup-hook)) + (let* ((has-colon (string-match ": \\'" prompt)) + (input (read-from-minibuffer (cond + (has-colon prompt) + (skip-colon prompt) + (value (format "%s (default %s): " prompt value)) + (t (format "%s: " prompt))) + (when has-colon value) ; initial-input + cider-minibuffer-map nil + 'cider-minibuffer-history + (unless has-colon value)))) ; default-value + (if (and (equal input "") value (not has-colon)) + value + input)))) + +(defun cider-read-symbol-name (prompt callback) + "Read a symbol name using PROMPT with a default of the one at point. +Use CALLBACK as the completing read var callback." + (funcall callback (cider-read-from-minibuffer + prompt + ;; if the thing at point is a keyword we treat it as symbol + (cider--kw-to-symbol (cider-symbol-at-point 'look-back))))) + +(defun cider-try-symbol-at-point (prompt callback) + "Call CALLBACK with symbol at point. +On failure, read a symbol name using PROMPT and call CALLBACK with that." + (condition-case nil (funcall callback (cider--kw-to-symbol (cider-symbol-at-point 'look-back))) + ('error (funcall callback (cider-read-from-minibuffer prompt))))) + +(declare-function cider-mode "cider-mode") + +(defcustom cider-jump-to-pop-to-buffer-actions + '((display-buffer-reuse-window display-buffer-same-window)) + "Determines what window `cider-jump-to` uses. +The value is passed as the `action` argument to `pop-to-buffer`. + +The default value means: + +- If the target file is already visible in a window, reuse it (switch to it). +- Otherwise, open the target buffer in the current window. + +For further details, see https://docs.cider.mx/cider/config/basic_config.html#control-what-window-to-use-when-jumping-to-a-definition" + :type 'sexp + :group 'cider + :package-version '(cider . "0.24.0")) + +(defun cider-jump-to (buffer &optional pos other-window) + "Push current point onto marker ring, and jump to BUFFER and POS. +POS can be either a number, a cons, or a symbol. +If a number, it is the character position (the point). +If a cons, it specifies the position as (LINE . COLUMN). COLUMN can be nil. +If a symbol, `cider-jump-to' searches for something that looks like the +symbol's definition in the file. +If OTHER-WINDOW is non-nil don't reuse current window." + (with-no-warnings + (xref-push-marker-stack)) + (if other-window + (pop-to-buffer buffer 'display-buffer-pop-up-window) + (pop-to-buffer buffer cider-jump-to-pop-to-buffer-actions)) + (with-current-buffer buffer + (widen) + (goto-char (point-min)) + (cider-mode +1) + (let ((status + (cond + ;; Line-column specification. + ((consp pos) + (forward-line (1- (or (car pos) 1))) + (if (cdr pos) + (move-to-column (cdr pos)) + (back-to-indentation))) + ;; Point specification. + ((numberp pos) + (goto-char pos)) + ;; Symbol or string. + (pos + ;; Try to find (def full-name ...). + (if (or (save-excursion + (search-forward-regexp (format "(def.*\\s-\\(%s\\)" (regexp-quote pos)) + nil 'noerror)) + (let ((name (replace-regexp-in-string ".*/" "" pos))) + ;; Try to find (def name ...). + (or (save-excursion + (search-forward-regexp (format "(def.*\\s-\\(%s\\)" (regexp-quote name)) + nil 'noerror)) + ;; Last resort, just find the first occurrence of `name'. + (save-excursion + (search-forward name nil 'noerror))))) + (goto-char (match-beginning 0)) + (message "Can't find %s in %s" pos (buffer-file-name)) + 'not-found)) + (t 'not-found)))) + (unless (eq status 'not-found) + ;; Make sure the location we jump to is centered within the target window + (recenter))))) + +(defun cider--find-buffer-for-file (file) + "Return a buffer visiting FILE. +If FILE is a temp buffer name, return that buffer." + (if (string-prefix-p "*" file) + file + (and file + (not (cider--tooling-file-p file)) + (cider-find-file file)))) + +(defun cider--jump-to-loc-from-info (info &optional other-window) + "Jump to location give by INFO. +INFO object is returned by `cider-var-info' or `cider-member-info'. +OTHER-WINDOW is passed to `cider-jump-to'." + (let* ((line (nrepl-dict-get info "line")) + (file (nrepl-dict-get info "file")) + (name (nrepl-dict-get info "name")) + ;; the filename might actually be a REPL buffer name + (buffer (cider--find-buffer-for-file file))) + (if buffer + (cider-jump-to buffer (if line (cons line nil) name) other-window) + (error "No source location")))) + +(declare-function url-filename "url-parse" (cl-x) t) + +(defun cider--url-to-file (url) + "Return the filename from the resource URL. +Uses `url-generic-parse-url' to parse the url. The filename is extracted and +then url decoded. If the decoded filename has a Windows device letter followed +by a colon immediately after the leading '/' then the leading '/' is dropped to +create a valid path." + (let ((filename (url-unhex-string (url-filename (url-generic-parse-url url))))) + (if (string-match "^/\\([a-zA-Z]:/.*\\)" filename) + (match-string 1 filename) + filename))) + +(defun cider-make-tramp-prefix (method user host &optional port) + "Constructs a Tramp file prefix from METHOD, USER, HOST, PORT. +It originated from Tramp's `tramp-make-tramp-file-name'. The original be +forced to make full file name with `with-parsed-tramp-file-name', not providing +prefix only option." + (concat tramp-prefix-format + (unless (zerop (length method)) + (concat method tramp-postfix-method-format)) + (unless (zerop (length user)) + (concat user tramp-postfix-user-format)) + (when host + (if (string-match tramp-ipv6-regexp host) + (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) + host)) + (when port + (concat "#" port)) + tramp-postfix-host-format)) + +(defun cider-tramp-prefix (&optional buffer) + "Use the filename for BUFFER to determine a tramp prefix. +Defaults to the current buffer. Return the tramp prefix, or nil +if BUFFER is local." + (let* ((buffer (or buffer (current-buffer))) + (name (or (buffer-file-name buffer) + (with-current-buffer buffer + default-directory)))) + (when (tramp-tramp-file-p name) + (with-parsed-tramp-file-name name v + (with-no-warnings + (cider-make-tramp-prefix v-method v-user v-host v-port)))))) + +(defun cider--client-tramp-filename (name &optional buffer) + "Return the tramp filename for path NAME relative to BUFFER. +If BUFFER has a tramp prefix, it will be added as a prefix to NAME. +If the resulting path is an existing tramp file, it returns the path, +otherwise, nil." + (let* ((buffer (or buffer (current-buffer))) + (name (replace-regexp-in-string "^file:" "" name)) + (name (concat (cider-tramp-prefix buffer) name))) + (if (and (tramp-tramp-file-p name) + (tramp-handle-file-exists-p name)) + name))) + +(defun cider--server-filename (name) + "Return the nREPL server-relative filename for NAME." + (if (tramp-tramp-file-p name) + (with-parsed-tramp-file-name name nil + localname) + name)) + +(defcustom cider-path-translations nil + "Alist of path prefixes to path prefixes. +Useful to intercept the location of a path in a container (or virtual +machine) and translate to the original location. If your project is located +at \"~/projects/foo\" and the src directory of foo is mounted at \"/src\" +in the container, the alist would be `((\"/src\" \"~/projects/foo/src\"))." + :type '(alist :key-type string :value-type string) + :group 'cider + :package-version '(cider . "0.23.0")) + +(defun cider--translate-path (path direction &optional return-all) + "Attempt to translate the PATH in the given DIRECTION, optionally RETURN-ALL. +Looks at `cider-path-translations' for (container . host) alist of path +prefixes and translates PATH from container to host or vice-versa depending on +whether DIRECTION is 'from-nrepl or 'to-nrepl." + (seq-let [from-fn to-fn path-fn] (cond ((eq direction 'from-nrepl) '(car cdr identity)) + ((eq direction 'to-nrepl) '(cdr car expand-file-name))) + (let ((f (lambda (translation) + (let ((path (funcall path-fn path)) + (prefix (file-name-as-directory (expand-file-name (funcall from-fn translation))))) + (when (string-prefix-p prefix path) + (replace-regexp-in-string (format "^%s" (regexp-quote prefix)) + (file-name-as-directory + (expand-file-name (funcall to-fn translation))) + path)))))) + (if return-all + (seq-filter #'identity (mapcar f cider-path-translations)) + (seq-some f cider-path-translations))))) + +(defun cider--all-path-translations () + "Returns `cider-path-translations' if non-empty, else seeks a present value." + (or cider-path-translations + ;; cider-path-translations often is defined as a directory-local variable, + ;; so after jumping to a .jar file, its value can be lost, + ;; so we have to figure out a possible translation: + (thread-last (buffer-list) + (seq-map (lambda (buffer) + (buffer-local-value 'cider-path-translations buffer))) + (seq-filter #'identity) + (seq-uniq) + (apply #'append) + (seq-uniq)))) + +(defun cider--translate-path-from-nrepl (path) + "Attempt to translate the nREPL PATH to a local path." + (cider--translate-path path 'from-nrepl)) + +(defun cider--translate-path-to-nrepl (path) + "Attempt to translate the local PATH to an nREPL path." + (cider--translate-path (expand-file-name path) 'to-nrepl)) + +(defvar cider-from-nrepl-filename-function + (with-no-warnings + (lambda (path) + (let ((path* (if (eq system-type 'cygwin) + (cygwin-convert-file-name-from-windows path) + path))) + (or (cider--translate-path-from-nrepl path*) path*)))) + "Function to translate nREPL namestrings to Emacs filenames.") + +(defcustom cider-prefer-local-resources nil + "Prefer local resources to remote (tramp) ones when both are available." + :type 'boolean + :group 'cider) + +(defun cider--file-path (path) + "Return PATH's local or tramp path using `cider-prefer-local-resources'. +If no local or remote file exists, return nil." + (let* ((local-path (funcall cider-from-nrepl-filename-function path)) + (tramp-path (and local-path (cider--client-tramp-filename local-path)))) + (cond ((equal local-path "") "") + ((and cider-prefer-local-resources (file-exists-p local-path)) + local-path) + ((and tramp-path (file-exists-p tramp-path)) + tramp-path) + ((and local-path (file-exists-p local-path)) + local-path) + (t + (when-let* ((cider-path-translations (cider--all-path-translations))) + (thread-last (cider--translate-path local-path 'from-nrepl :return-all) + (seq-filter #'file-exists-p) + car)))))) + +(declare-function archive-extract "arc-mode") +(declare-function archive-zip-extract "arc-mode") + +(defun cider-find-file (url) + "Return a buffer visiting the file URL if it exists, or nil otherwise. +If URL has a scheme prefix, it must represent a fully-qualified file path +or an entry within a zip/jar archive. If AVFS (archive virtual file +system; see online docs) is mounted the archive entry is opened inside the +AVFS directory, otherwise the entry is archived into a temporary read-only +buffer. If URL doesn't contain a scheme prefix and is an absolute path, it +is treated as such. Finally, if URL is relative, it is expanded within each +of the open Clojure buffers till an existing file ending with URL has been +found." + (require 'arc-mode) + (cond ((string-match "^file:\\(.+\\)" url) + (when-let* ((file (cider--url-to-file (match-string 1 url))) + (path (cider--file-path file))) + (find-file-noselect path))) + ((string-match "^\\(jar\\|zip\\):\\(file:.+\\)!/\\(.+\\)" url) + (when-let* ((entry (match-string 3 url)) + (file (cider--url-to-file (match-string 2 url))) + (path (cider--file-path file)) + (name (format "%s:%s" path entry)) + (avfs (format "%s%s#uzip/%s" + (expand-file-name (or (getenv "AVFSBASE") "~/.avfs/")) + path entry))) + (cond + ;; 1) use avfs + ((file-exists-p avfs) + (find-file-noselect avfs)) + ;; 2) already uncompressed + ((find-buffer-visiting name)) + ;; 3) on remotes use Emacs built-in archiving + ((tramp-tramp-file-p path) + (find-file path) + (goto-char (point-min)) + ;; anchor to eol to prevent eg. clj matching cljs. + (re-search-forward (concat entry "$")) + (let ((archive-buffer (current-buffer))) + (archive-extract) + (kill-buffer archive-buffer)) + (current-buffer)) + ;; 4) Use external zip program to extract a single file + (t + (with-current-buffer (generate-new-buffer + (file-name-nondirectory entry)) + ;; Use appropriate coding system for bytes read from unzip cmd to + ;; display Emacs native newlines regardless of whether the file + ;; uses unix LF or dos CRLF line endings. + ;; It's important to avoid spurious CR characters, which may + ;; appear as `^M', because they can confuse clojure-mode's symbol + ;; detection, e.g. `clojure-find-ns', and break `cider-find-var'. + ;; `clojure-find-ns' uses Emacs' (thing-at-point 'symbol) as + ;; part of identifying a file's namespace, and when a file + ;; isn't decoded properly, namespaces can be reported as + ;; `my.lib^M' which `cider-find-var' won't know what to do with. + (let ((coding-system-for-read 'prefer-utf-8)) + (archive-zip-extract path entry)) + (set-visited-file-name name) + (setq-local default-directory (file-name-directory path)) + (setq-local buffer-read-only t) + (set-buffer-modified-p nil) + (set-auto-mode) + (current-buffer)))))) + (t (if-let* ((path (cider--file-path url))) + (find-file-noselect path) + (unless (file-name-absolute-p url) + (let ((cider-buffers (cider-util--clojure-buffers)) + (url (file-name-nondirectory url))) + (or (cl-loop for bf in cider-buffers + for path = (with-current-buffer bf + (expand-file-name url)) + if (and path (file-exists-p path)) + return (find-file-noselect path)) + (cl-loop for bf in cider-buffers + if (string= (buffer-name bf) url) + return bf)))))))) + +(defun cider--open-other-window-p (arg) + "Test prefix value ARG to see if it indicates displaying results in other window." + (let ((narg (prefix-numeric-value arg))) + (pcase narg + (-1 t) ; - + (16 t) ; empty empty + (_ nil)))) + +(defun cider-abbreviate-ns (namespace) + "Return a string that abbreviates NAMESPACE." + (when namespace + (let* ((names (reverse (split-string namespace "\\."))) + (lastname (car names))) + (concat (mapconcat (lambda (s) (concat (substring s 0 1) ".")) + (reverse (cdr names)) + "") + lastname)))) + +(defun cider-last-ns-segment (namespace) + "Return the last segment of NAMESPACE." + (when namespace + (car (reverse (split-string namespace "\\."))))) + + +(provide 'cider-common) +;;; cider-common.el ends here diff --git a/elpa/cider-20241203.1607/cider-completion-context.el b/elpa/cider-20241203.1607/cider-completion-context.el new file mode 100644 index 00000000..3ebbf203 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-completion-context.el @@ -0,0 +1,116 @@ +;;; cider-completion-context.el --- Context parsing -*- lexical-binding: t -*- + +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Bozhidar Batsov +;; Artur Malabarba + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Context-parsing utilities. Extracted from cider-completion.el. + +;;; Code: + +(defcustom cider-completion-use-context t + "When true, uses context at point to improve completion suggestions." + :type 'boolean + :group 'cider + :package-version '(cider . "0.7.0")) + +(defun cider-completion--bounds-of-non-string-symbol-at-point () + "Returns the bounds of the symbol at point, unless it's inside a string." + (let ((sap (symbol-at-point))) + (when (and sap (not (nth 3 (syntax-ppss)))) + (bounds-of-thing-at-point 'symbol)))) + +(defun cider-completion-symbol-start-pos () + "Find the starting position of the symbol at point, unless inside a string." + (car (cider-completion--bounds-of-non-string-symbol-at-point))) + +(defun cider-completion-symbol-end-pos () + "Find the end position of the symbol at point, unless inside a string." + (cdr (cider-completion--bounds-of-non-string-symbol-at-point))) + +(defun cider-completion-get-info-context-at-point () + "Extract a context at point that is suitable for eldoc and info ops. +Note that this context is slightly different than that of +`cider-completion-get-context-at-point': this one does not include +the current symbol at point." + (when (save-excursion + (condition-case _ + (progn + (up-list) + (check-parens) + t) + (scan-error nil) + (user-error nil))) + (save-excursion + (let* ((pref-start (cider-completion-symbol-start-pos)) + (context (cider-defun-at-point)) + (end (cider-completion-symbol-end-pos)) + (_ (beginning-of-defun-raw)) + (expr-start (point)) + (_ (if (derived-mode-p 'cider-repl-mode) + (goto-char (point-max)) + (end-of-defun))) + (expr-end (point))) + (string-remove-suffix "\n" + (concat (when pref-start (substring context 0 (- pref-start expr-start))) + "__prefix__" + (substring context (- (- expr-end end))))))))) + +(defun cider-completion-get-context-at-point () + "Extract the context at point. +If point is not inside the list, returns nil; otherwise return \"top-level\" +form, with symbol at point replaced by __prefix__." + (when (save-excursion + (condition-case _ + (progn + (up-list) + (check-parens) + t) + (scan-error nil) + (user-error nil))) + (save-excursion + (let* ((pref-end (point)) + (pref-start (cider-completion-symbol-start-pos)) + (context (cider-defun-at-point)) + (_ (beginning-of-defun-raw)) + (expr-start (point))) + (concat (when pref-start (substring context 0 (- pref-start expr-start))) + "__prefix__" + (substring context (- pref-end expr-start))))))) + +(defun cider-completion-get-context (&optional info) + "Extract context depending (maybe of INFO type). + +Output depends on `cider-completion-use-context' and the current major mode." + (if cider-completion-use-context + ;; We use ignore-errors here since grabbing the context + ;; might fail because of unbalanced parens, or other + ;; technical reasons, yet we don't want to lose all + ;; completions and throw error to user because of that. + (or (ignore-errors + (if info + (cider-completion-get-info-context-at-point) + (cider-completion-get-context-at-point))) + "nil") + "nil")) + +(provide 'cider-completion-context) +;;; cider-completion-context.el ends here diff --git a/elpa/cider-20241203.1607/cider-completion.el b/elpa/cider-20241203.1607/cider-completion.el new file mode 100644 index 00000000..1e89adca --- /dev/null +++ b/elpa/cider-20241203.1607/cider-completion.el @@ -0,0 +1,331 @@ +;;; cider-completion.el --- Smart REPL-powered code completion -*- lexical-binding: t -*- + +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Bozhidar Batsov +;; Artur Malabarba + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Smart REPL-powered code completion and integration with company-mode. + +;;; Code: + +(require 'subr-x) +(require 'thingatpt) + +(require 'cider-client) +(require 'cider-common) +(require 'cider-completion-context) +(require 'cider-doc) +(require 'cider-docstring) +(require 'cider-eldoc) +(require 'nrepl-dict) +(require 'seq) + +(defcustom cider-annotate-completion-candidates t + "When true, annotate completion candidates with some extra information." + :type 'boolean + :group 'cider + :package-version '(cider . "0.8.0")) + +(defcustom cider-annotate-completion-function + #'cider-default-annotate-completion-function + "Controls how the annotations for completion candidates are formatted. +Must be a function that takes two arguments: the abbreviation of the +candidate type according to `cider-completion-annotations-alist' and the +candidate's namespace." + :type 'function + :group 'cider + :package-version '(cider . "0.9.0")) + +(defcustom cider-completion-annotations-alist + '(("class" "c") + ("field" "fi") + ("function" "f") + ("import" "i") + ("keyword" "k") + ("local" "l") + ("macro" "m") + ("method" "me") + ("namespace" "n") + ("protocol" "p") + ("protocol-function" "pf") + ("record" "r") + ("special-form" "s") + ("static-field" "sf") + ("static-method" "sm") + ("type" "t") + ("var" "v")) + "Controls the abbreviations used when annotating completion candidates. + +Must be a list of elements with the form (TYPE . ABBREVIATION), where TYPE +is a possible value of the candidate's type returned from the completion +backend, and ABBREVIATION is a short form of that type." + :type '(alist :key-type string :value-type string) + :group 'cider + :package-version '(cider . "0.9.0")) + +(defconst cider-completion-kind-alist + '(("class" class) + ("field" field) + ("function" function) + ("import" class) + ("keyword" keyword) + ("local" variable) + ("macro" macro) + ("method" method) + ("namespace" module) + ("protocol" enum) + ("protocol-function" enum-member) + ("record" struct) + ("special-form" keyword) + ("static-field" field) + ("static-method" interface) + ("type" parameter) + ("var" variable)) + "Icon mapping for company-mode.") + +(defcustom cider-completion-annotations-include-ns 'unqualified + "Controls passing of namespaces to `cider-annotate-completion-function'. + +When set to 'always, the candidate's namespace will always be passed if it +is available. When set to 'unqualified, the namespace will only be passed +if the candidate is not namespace-qualified." + :type '(choice (const always) + (const unqualified) + (const :tag "never" nil)) + :group 'cider + :package-version '(cider . "0.9.0")) + +(defun cider-completion--parse-candidate-map (candidate-map) + "Get \"candidate\" from CANDIDATE-MAP. +Put type and ns properties on the candidate" + (let ((candidate (nrepl-dict-get candidate-map "candidate")) + (type (nrepl-dict-get candidate-map "type")) + (ns (nrepl-dict-get candidate-map "ns"))) + (put-text-property 0 1 'type type candidate) + (put-text-property 0 1 'ns ns candidate) + candidate)) + +(defun cider-complete (prefix) + "Complete PREFIX with context at point. +Completion relies on nREPL middleware. First +we check if cider-nrepl's complete op is available +and afterward we fallback on nREPL's built-in +completion functionality." + (cond + ;; if we don't have a connection, end early + ((not (cider-connected-p)) nil) + ;; next we try if cider-nrepl's completion is available + ((cider-nrepl-op-supported-p "complete") + (let* ((context (cider-completion-get-context)) + (candidates (cider-sync-request:complete prefix context))) + (mapcar #'cider-completion--parse-candidate-map candidates))) + ;; then we fallback to nREPL's built-in op (available in nREPL 0.8+) + ((cider-nrepl-op-supported-p "completions") + (mapcar #'cider-completion--parse-candidate-map (cider-sync-request:completion prefix))) + (t nil))) + +(defun cider-completion--get-candidate-type (symbol) + "Get candidate type for SYMBOL." + (let ((type (get-text-property 0 'type symbol))) + (or (cadr (assoc type cider-completion-annotations-alist)) + type))) + +(defun cider-completion--get-candidate-ns (symbol) + "Get candidate ns for SYMBOL." + (when (or (eq 'always cider-completion-annotations-include-ns) + (and (eq 'unqualified cider-completion-annotations-include-ns) + (not (cider-namespace-qualified-p symbol)))) + (get-text-property 0 'ns symbol))) + +(defun cider-default-annotate-completion-function (type ns) + "Get completion function based on TYPE and NS." + (concat (when ns (format " (%s)" ns)) + (when type (format " <%s>" type)))) + +(defun cider-company-symbol-kind (symbol) + "Get SYMBOL kind for company-mode." + (let ((type (get-text-property 0 'type symbol))) + (or (cadr (assoc type cider-completion-kind-alist)) + type))) + +(defun cider-annotate-symbol (symbol) + "Return a string suitable for annotating SYMBOL. +If SYMBOL has a text property `type` whose value is recognised, its +abbreviation according to `cider-completion-annotations-alist' will be +used. If `type` is present but not recognised, its value will be used +unaltered. If SYMBOL has a text property `ns`, then its value will be used +according to `cider-completion-annotations-include-ns'. The formatting is +performed by `cider-annotate-completion-function'." + (when cider-annotate-completion-candidates + (let* ((type (cider-completion--get-candidate-type symbol)) + (ns (cider-completion--get-candidate-ns symbol))) + (funcall cider-annotate-completion-function type ns)))) + +(defun cider-complete-at-point () + "Complete the symbol at point." + (when-let* ((bounds (or (bounds-of-thing-at-point 'symbol) + (cons (point) (point)))) + (bounds-string (buffer-substring (car bounds) (cdr bounds)))) + (when (and (cider-connected-p) + (not (or (cider-in-string-p) (cider-in-comment-p)))) + (let* (last-bounds-string + last-result + (complete + (lambda () + ;; We are Not using the prefix extracted within the (prefix pred action) + ;; lambda. In certain completion styles, the prefix might be an empty + ;; string, which is unreliable. A more dependable method is to use the + ;; string defined by the bounds of the symbol at point. + ;; + ;; Caching just within the function is sufficient. Keeping it local + ;; ensures that it will not extend across different CIDER sessions. + (unless (string= bounds-string last-bounds-string) + (setq last-bounds-string bounds-string) + (setq last-result (cider-complete bounds-string))) + last-result))) + (list (car bounds) (cdr bounds) + (lambda (prefix pred action) + ;; When the 'action is 'metadata, this lambda returns metadata about this + ;; capf, when action is (boundaries . suffix), it returns nil. With every + ;; other value of 'action (t, nil, or lambda), 'action is forwarded to + ;; (complete-with-action), together with (cider-complete), prefix and pred. + ;; And that function performs the completion based on those arguments. + ;; + ;; This api is better described in the section + ;; '21.6.7 Programmed Completion' of the elisp manual. + (cond ((eq action 'metadata) `(metadata (category . cider))) ;; defines a completion category named 'cider, used later in our `completion-category-overrides` logic. + ((eq (car-safe action) 'boundaries) nil) + (t (with-current-buffer (current-buffer) + (complete-with-action action (funcall complete) prefix pred))))) + :annotation-function #'cider-annotate-symbol + :company-kind #'cider-company-symbol-kind + :company-doc-buffer #'cider-create-compact-doc-buffer + :company-location #'cider-company-location + :company-docsig #'cider-company-docsig))))) + +(defun cider-completion-flush-caches () + "Force Compliment to refill its caches. +This command should be used if Compliment fails to pick up new classnames +and methods from dependencies that were loaded dynamically after the REPL +has started." + (interactive) + (cider-sync-request:complete-flush-caches)) + +(defun cider-company-location (var) + "Open VAR's definition in a buffer. +Returns the cons of the buffer itself and the location of VAR's definition +in the buffer." + (when-let* ((info (cider-var-info var)) + (file (nrepl-dict-get info "file")) + (line (nrepl-dict-get info "line")) + (buffer (cider-find-file file))) + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (cons buffer (point)))))) + +(defun cider-company-docsig (thing) + "Return signature for THING." + (when-let ((eldoc-info (cider-eldoc-info thing))) + (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 + (cider-eldoc-thing-type eldoc-info)) + (cider-eldoc-format-arglist arglists 0))))) + +;; Fuzzy completion for company-mode + +(defun cider-company-unfiltered-candidates (string &rest _) + "Return CIDER completion candidates for STRING as is, unfiltered." + (cider-complete string)) + +;; defines a completion style named `cider' (which ideally would have been named `cider-fuzzy'). +;; note that there's already a completion category named `cider' (grep for `(metadata (category . cider))` in this file), +;; which can be confusing given the identical name. +;; The `cider' completion style should be removed because the `flex' style is essentially equivalent. +;; (To be fair, `flex' was introduced in Emacs 27, 3 years in after our commit 04e428b +;; which introduced `cider-company-enable-fuzzy-completion') +(add-to-list 'completion-styles-alist + '(cider + ;; Use `ignore' in place of "try-competion function". + ignore + cider-company-unfiltered-candidates + "CIDER backend-driven completion style.")) + +(defun cider-company-enable-fuzzy-completion () + "Enables `cider' completion style for CIDER in all buffers. + +DEPRECATED: please use `cider-enable-cider-completion-style' instead." + (interactive) + (cider-enable-cider-completion-style)) + +(defun cider-enable-cider-completion-style () + "Enables `cider' completion style for CIDER in all buffers. + +This style supports non-prefix completion candidates returned by the +completion backend. Only affects the `cider' completion category." + (interactive) + (let* ((cider (assq 'cider completion-category-overrides)) + (found-styles (assq 'styles cider)) + (new-styles (if found-styles + (cons 'styles (cons 'cider (cdr found-styles))) + '(styles cider basic))) + (new-cider (if cider + (cons 'cider + (cons new-styles + (seq-remove (lambda (x) (equal 'styles (car x))) + (cdr cider)))) + (list 'cider new-styles))) + (new-overrides (cons new-cider + (seq-remove (lambda (x) (equal 'cider (car x))) + completion-category-overrides)))) + (setq completion-category-overrides new-overrides))) + +(make-obsolete 'cider-company-enable-fuzzy-completion 'cider-enable-cider-completion-style "1.17.0") + +(defun cider-enable-flex-completion () + "Enables `flex' (fuzzy) completion for CIDER in all buffers. + +Only affects the `cider' completion category.`" + (interactive) + (when (< emacs-major-version 27) + (user-error "`cider-enable-flex-completion' requires Emacs 27 or later")) + (let ((found-styles (when-let ((cider (assq 'cider completion-category-overrides))) + (assq 'styles cider))) + (found-cycle (when-let ((cider (assq 'cider completion-category-overrides))) + (assq 'cycle cider)))) + (setq completion-category-overrides (seq-remove (lambda (x) + (equal 'cider (car x))) + completion-category-overrides)) + (unless found-styles + (setq found-styles '(styles basic))) + (unless (member 'flex found-styles) + ;; This expression makes sure that 'flex style has a priority over other + ;; styles, see https://github.com/clojure-emacs/cider/pull/3696. + (setq found-styles (apply #'list 'styles 'flex (cdr found-styles)))) + (add-to-list 'completion-category-overrides (apply #'list 'cider found-styles (when found-cycle + (list found-cycle)))))) + +(provide 'cider-completion) +;;; cider-completion.el ends here diff --git a/elpa/cider-20241203.1607/cider-connection.el b/elpa/cider-20241203.1607/cider-connection.el new file mode 100644 index 00000000..35a8f2f0 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-connection.el @@ -0,0 +1,1091 @@ +;;; cider-connection.el --- Connection and session life-cycle management for CIDER -*- lexical-binding: t -*- +;; +;; Copyright © 2019-2024 Artur Malabarba, Bozhidar Batsov, Vitalie Spinu and CIDER contributors +;; +;; Author: Artur Malabarba +;; Bozhidar Batsov +;; Vitalie Spinu +;; +;; Keywords: languages, clojure, cider +;; +;; 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 . +;; +;; This file is not part of GNU Emacs. +;; +;; +;;; Commentary: +;; +;; +;;; Code: + +(require 'nrepl-client) +(require 'cl-lib) +(require 'format-spec) +(require 'sesman) +(require 'sesman-browser) +(require 'spinner) +(require 'cider-popup) +(require 'cider-util) + +(defcustom cider-session-name-template "%J:%h:%p" + "Format string to use for session names. +See `cider-format-connection-params' for available format characters." + :type 'string + :group 'cider + :package-version '(cider . "0.18.0")) + +(defcustom cider-redirect-server-output-to-repl t + "Controls whether nREPL server output would be redirected to the REPL. +When non-nil the output would end up in both the nrepl-server buffer (when +available) and the matching REPL buffer." + :type 'boolean + :group 'cider + :safe #'booleanp + :package-version '(cider . "0.17.0")) + +(defcustom cider-auto-mode t + "When non-nil, automatically enable and disable CIDER in all Clojure buffers. + +After an initial connection, `cider-mode' is added to `clojure-mode-hook' and +automatically enabled on all existing Clojure buffers. After the last +connection has been closed, `cider-mode' is disabled in all Clojure buffers, and +has to be manually re-enabled via \\[cider-mode]. + +Useful for switching between alternative minor modes like `inf-clojure-mode'." + :type 'boolean + :group 'cider + :safe #'booleanp + :package-version '(cider . "0.9.0")) + +(defcustom cider-merge-sessions nil + "Controls session combination behaviour. + +Symbol `host' combines all sessions of a project associated with the same host. +Symbol `project' combines all sessions of a project. + +All other values do not combine any sessions." + :type '(choice (const :tag "Combine all sessions with the same host" host) + (const :tag "Combine all sessions from the same project" project) + (other :tag "Do not combine any sessions")) + :group 'cider + :safe #'symbolp + :package-version '(cider . "1.5")) + +(defcustom cider-reuse-dead-repls 'prompt + "How to deal with existing dead REPL buffers when initializing a connection. + +Possible choices are `prompt', `auto', `any', and nil. +- `prompt' means to always ask the user for a decision. +- `auto' means to automatically reuse a dead REPL without prompting the user + if it is the only available option. When there are multiple buffers to + choose from, the user is is prompted for a choice. +- `any' (or any other non-nil value) means to reuse any dead REPL buffer + available, by default the most relevant according to various heuristics, + and never prompt the user. +- nil means to start a new REPL each time, ignoring existing buffers." + :type '(choice (const :tag "Always prompt for what to do with dead REPLs" prompt) + (const :tag "Reuse dead REPL, prompting only for multiple choice" auto) + (const :tag "Reuse any available dead REPL and never prompt" any) + (const :tag "Never reuse dead REPLs" nil)) + :group 'cider + :safe #'symbolp + :package-version '(cider . "1.8")) + +(defconst cider-required-nrepl-version "0.6.0" + "The minimum nREPL version that's known to work properly with CIDER.") + +(defcustom cider-clojurec-eval-destination 'multi + "The REPL type to be chosen in .cljc buffers." + :type '(choice (const :tag "Clojure" clj) + (const :tag "ClojureScript" cljs) + (const :tag "Multi (evaluate in Clojure and ClojureScript simultaneously)" multi)) + :group 'cider + :package-version '(cider . "1.8")) + +;;; Connect + +(defun cider-nrepl-connect (params) + "Start nrepl client and create the REPL. +PARAMS is a plist containing :host, :port, :server and other parameters for +`cider-repl-create'." + (process-buffer + (nrepl-start-client-process + (plist-get params :host) + (plist-get params :port) + (plist-get params :server) + (lambda (_) + (cider-repl-create params)) + (plist-get params :socket-file)))) + +(defun cider-sessions () + "Return a list of all active CIDER sessions." + (sesman-sessions 'CIDER)) + +(defun cider-connected-p () + "Return t if CIDER is currently connected, nil otherwise." + (process-live-p (get-buffer-process (cider-current-repl)))) + +(defun cider-ensure-connected () + "Ensure there is a linked CIDER session." + (sesman-ensure-session 'CIDER)) + +(defun cider--session-server (session) + "Return server buffer for SESSION or nil if there is no server." + (seq-some (lambda (r) + (buffer-local-value 'nrepl-server-buffer r)) + (cdr session))) + +(defun cider--gather-session-params (session) + "Gather all params for a SESSION." + (let (params) + (dolist (repl (cdr session)) + (setq params (cider--gather-connect-params params repl))) + (when-let* ((server (cider--session-server session))) + (setq params (cider--gather-connect-params params server))) + params)) + +(defun cider--gather-connect-params (&optional params proc-buffer) + "Gather all relevant connection parameters into PARAMS plist. +PROC-BUFFER is either server or client buffer, defaults to current buffer." + (let ((proc-buffer (or proc-buffer (current-buffer)))) + (with-current-buffer proc-buffer + (unless nrepl-endpoint + (error "This is not a REPL or SERVER buffer; is there an active REPL?")) + (let ((server-buf (if (nrepl-server-p proc-buffer) + proc-buffer + nrepl-server-buffer))) + (cl-loop for l on nrepl-endpoint by #'cddr + do (setq params (plist-put params (car l) (cadr l)))) + (setq params (thread-first params + (plist-put :project-dir nrepl-project-dir))) + (when (buffer-live-p server-buf) + (setq params (thread-first params + (plist-put :server (get-buffer-process server-buf)) + (plist-put :server-command nrepl-server-command)))) + ;; repl-specific parameters (do not pollute server params!) + (unless (nrepl-server-p proc-buffer) + (setq params (thread-first params + (plist-put :session-name cider-session-name) + (plist-put :repl-type cider-repl-type) + (plist-put :cljs-repl-type cider-cljs-repl-type) + (plist-put :repl-init-function cider-repl-init-function)))) + params)))) + +(defun cider--close-buffer (buffer) + "Close the BUFFER and kill its associated process (if any)." + (when (buffer-live-p buffer) + (when-let* ((proc (get-buffer-process buffer))) + (when (process-live-p proc) + (delete-process proc))) + (kill-buffer buffer))) + +(declare-function cider-repl-emit-interactive-stderr "cider-repl") +(defun cider--close-connection (repl &optional no-kill) + "Close connection associated with REPL. +When NO-KILL is non-nil stop the connection but don't kill the REPL +buffer." + (when (buffer-live-p repl) + (with-current-buffer repl + (when spinner-current (spinner-stop)) + (when nrepl-tunnel-buffer + (cider--close-buffer nrepl-tunnel-buffer)) + (when no-kill + ;; inform sentinel not to kill the server, if any + (thread-first (get-buffer-process repl) + (process-plist) + (plist-put :keep-server t)))) + (let ((proc (get-buffer-process repl))) + (when (and (process-live-p proc) + (or (not nrepl-server-buffer) + ;; Sync request will hang if the server is dead. + (process-live-p (get-buffer-process nrepl-server-buffer)))) + (nrepl-sync-request:close repl) + ;; give a chance to the REPL to respond to the closing of the connection + (sleep-for 0.5) + (delete-process proc))) + (when-let* ((messages-buffer (and nrepl-log-messages + (nrepl-messages-buffer repl)))) + (kill-buffer messages-buffer)) + (unless no-kill + (kill-buffer repl))) + (when repl + (sesman-remove-object 'CIDER nil repl (not no-kill) t))) + +(defun cider-emit-manual-warning (section-id format &rest args) + "Emit a warning to the REPL and link to the online manual. +SECTION-ID is the section to link to. The link is added on the last line. +FORMAT is a format string to compile with ARGS and display on the REPL." + (let ((message (apply #'format format args))) + (cider-repl-emit-interactive-stderr + (concat "WARNING: " message " (" + (cider--manual-button "More information" section-id) + ")\n")))) + +(defvar cider-version) +(defun cider--check-required-nrepl-version () + "Check whether we're using a compatible nREPL version." + (if-let* ((nrepl-version (cider--nrepl-version))) + (when (version< nrepl-version cider-required-nrepl-version) + (cider-emit-manual-warning "troubleshooting.html#warning-saying-you-have-to-use-newer-nrepl" + "CIDER requires nREPL %s (or newer) to work properly" + cider-required-nrepl-version)))) + +(defvar cider-minimum-clojure-version) +(defun cider--check-clojure-version-supported () + "Ensure that we are meeting the minimum supported version of Clojure." + (if-let* ((clojure-version (cider--clojure-version)) + ;; drop all qualifiers from the version string + ;; e.g. 1.10.0-master-SNAPSHOT becomes simply 1.10.0 + (clojure-version (car (split-string clojure-version "-")))) + (when (version< clojure-version cider-minimum-clojure-version) + (cider-emit-manual-warning "basics/installation.html#prerequisites" + "Clojure version (%s) is not supported (minimum %s). CIDER will not work." + clojure-version cider-minimum-clojure-version)))) + +(defun cider--strip-version-patch (v) + "Strips everything but major.minor from the version, returning a version list. +V is the version string to strip the patch from." + (seq-take (version-to-list v) 2)) + +(defun cider--compatible-middleware-version-p (required-ver ver) + "Checks that the available middleware version is compatible with the required. +We look only at the major and minor components. When the major +version is 0, only check that the minor versions match. When the major version +is > 0, first check that the major version matches, then that the minor +version is >= the required minor version. +VER the 'installed' version, +REQUIRED-VER the version required by cider." + (let ((ver* (cider--strip-version-patch ver)) + (required-ver* (cider--strip-version-patch required-ver))) + (cond ((= 0 (car required-ver*)) (= (cadr required-ver*) + (cadr ver*))) + (t (and (= (car required-ver*) + (car ver*)) + (version-list-<= required-ver* ver*)))))) + +(defvar cider-required-middleware-version) +(defun cider--check-middleware-compatibility () + "CIDER frontend/backend compatibility check. +Retrieve the underlying connection's CIDER-nREPL version and checks if the +middleware used is compatible with CIDER. If not, will display a warning +message in the REPL area." + (let* ((version-dict (nrepl-aux-info "cider-version" (cider-current-repl))) + (middleware-version (nrepl-dict-get version-dict "version-string"))) + (cond + ((null middleware-version) + (cider-emit-manual-warning "troubleshooting.html#cider-complains-of-the-cider-nrepl-version" + "CIDER requires cider-nrepl to be fully functional. Some features will not be available without it!")) + ((not (cider--compatible-middleware-version-p cider-required-middleware-version middleware-version)) + (cider-emit-manual-warning "troubleshooting.html#cider-complains-of-the-cider-nrepl-version" + "CIDER %s requires cider-nrepl %s, but you're currently using cider-nrepl %s. The version mismatch might break some functionality!" + cider-version cider-required-middleware-version middleware-version))))) + +(declare-function cider-interactive-eval-handler "cider-eval") +(declare-function cider-nrepl-send-request "cider-client") +;; TODO: Use some null handler here +(defun cider--subscribe-repl-to-server-out () + "Subscribe to the nREPL server's *out*." + (cider-nrepl-send-request '("op" "out-subscribe") + (cider-interactive-eval-handler (current-buffer)))) + +(defvar cider-mode) +(declare-function cider-mode "cider-mode") +(defun cider-enable-on-existing-clojure-buffers () + "Enable CIDER's minor mode on existing Clojure buffers. +See command `cider-mode'." + (interactive) + (add-hook 'clojure-mode-hook #'cider-mode) + (add-hook 'clojure-ts-mode-hook #'cider-mode) + (dolist (buffer (cider-util--clojure-buffers)) + (with-current-buffer buffer + (unless cider-mode + (cider-mode +1) + ;; In global-eldoc-mode, a new file-visiting buffer calls + ;; `turn-on-eldoc-mode' which enables eldoc-mode if it's supported in that + ;; buffer as determined by `eldoc--supported-p'. Cider's eldoc support + ;; allows new buffers in cider-mode to enable eldoc-mode. As of 2021-04, + ;; however, clojure-mode itself has no eldoc support, so old clojure + ;; buffers opened before cider started aren't necessarily in eldoc-mode. + ;; Here, we've enabled cider-mode for this old clojure buffer, and now, if + ;; global-eldoc-mode is enabled, try to enable eldoc-mode as if the buffer + ;; had just been created with cider-mode. + (when global-eldoc-mode + (turn-on-eldoc-mode)))))) + +(declare-function cider--debug-mode "cider-debug") +(defun cider-disable-on-existing-clojure-buffers () + "Disable `cider-mode' and related commands on existing Clojure buffers." + (interactive) + (dolist (buffer (cider-util--clojure-buffers)) + (with-current-buffer buffer + (cider--debug-mode -1) + (cider-mode -1)))) + +(defun cider-possibly-disable-on-existing-clojure-buffers () + "Disable `cider-mode' in all Clojure buffers if all CIDER sessions are closed." + (unless (cider-sessions) + (cider-disable-on-existing-clojure-buffers))) + +(defun cider--set-connection-capabilities (&optional conn-buffer) + "Set `cider-connection-capabilities' for CONN-BUFFER during repl init. +See `cider-connection-capabilities'." + (with-current-buffer (or conn-buffer (current-buffer)) + (setf cider-connection-capabilities + (append + (pcase (cider-runtime) + ('clojure '(clojure jvm-compilation-errors)) + ('babashka '(babashka jvm-compilation-errors)) + ('nbb '(cljs)) + ('scittle '(cljs)) + (_ '())) + (when + (eq cider-repl-type 'cljs) + '(cljs)))))) + +(declare-function cider--debug-init-connection "cider-debug") +(declare-function cider-repl-init "cider-repl") +(declare-function cider-nrepl-op-supported-p "cider-client") +(declare-function cider-nrepl-request:eval "cider-client") + +(defun cider--connected-handler () + "Handle CIDER initialization after nREPL connection has been established. +This function is appended to `nrepl-connected-hook' in the client process +buffer." + ;; `nrepl-connected-hook' is run in the connection buffer + ;; `cider-enlighten-mode' changes eval to include the debugger, so we inhibit + ;; it here as the debugger isn't necessarily initialized yet + (let ((cider-enlighten-mode nil)) + ;; after initialization, set mode-line and buffer name. + (cider-set-repl-type cider-repl-type) + (cider-repl-init + (current-buffer) + (lambda () + ;; Init logic that's specific to Clojure's nREPL and cider-nrepl + (when (cider-runtime-clojure-p) + (cider--check-required-nrepl-version) + (cider--check-clojure-version-supported) + (cider--check-middleware-compatibility) + + ;; Redirect the nREPL's terminal output to a REPL buffer. + ;; If we don't do this the server's output will end up + ;; in the *nrepl-server* buffer. + (when (and cider-redirect-server-output-to-repl + (cider-nrepl-op-supported-p "out-subscribe")) + (cider--subscribe-repl-to-server-out)) + + ;; Middleware on cider-nrepl's side is deferred until first usage, but + ;; loading middleware concurrently can lead to occasional "require" issues + ;; (likely a Clojure bug). Thus, we load the heavy debug middleware towards + ;; the end, allowing for the faster "server-out" middleware to load + ;; first. + (cider--debug-init-connection)) + + (cider--set-connection-capabilities) + + (when cider-repl-init-function + (funcall cider-repl-init-function)) + + (when cider-auto-mode + (cider-enable-on-existing-clojure-buffers)) + + (run-hooks 'cider-connected-hook))))) + +(defun cider--disconnected-handler () + "Cleanup after nREPL connection has been lost or closed. +This function is appended to `nrepl-disconnected-hook' in the client +process buffer." + ;; `nrepl-connected-hook' is run in the connection buffer + (when cider-auto-mode + (cider-possibly-disable-on-existing-clojure-buffers)) + (run-hooks 'cider-disconnected-hook)) + + +;;; Connection Info + +(defun cider--java-version () + "Retrieve the underlying connection's Java version." + (with-current-buffer (cider-current-repl) + (when nrepl-versions + (thread-first nrepl-versions + (nrepl-dict-get "java") + (nrepl-dict-get "version-string"))))) + +(defun cider--clojure-version () + "Retrieve the underlying connection's Clojure version." + (with-current-buffer (cider-current-repl) + (when nrepl-versions + (thread-first nrepl-versions + (nrepl-dict-get "clojure") + (nrepl-dict-get "version-string"))))) + +(defun cider--nrepl-version () + "Retrieve the underlying connection's nREPL version." + (with-current-buffer (cider-current-repl) + (when nrepl-versions + (thread-first nrepl-versions + (nrepl-dict-get "nrepl") + (nrepl-dict-get "version-string"))))) + +(defun cider--babashka-version () + "Retrieve the underlying connection's Babashka version." + (with-current-buffer (cider-current-repl) + (when nrepl-versions + (nrepl-dict-get nrepl-versions "babashka")))) + +(defun cider--babashka-nrepl-version () + "Retrieve the underlying connection's babashka.nrepl version." + (with-current-buffer (cider-current-repl) + (when nrepl-versions + (nrepl-dict-get nrepl-versions "babashka.nrepl")))) + +(defun cider--nbb-nrepl-version () + "Retrieve the underlying connection's nbb version. + +Note that this is currently not a real version number. +But helps us know if this is a nbb repl, or not." + (with-current-buffer (cider-current-repl) + (when nrepl-versions + (nrepl-dict-get nrepl-versions "nbb-nrepl")))) + +(defun cider--scittle-nrepl-version () + "Retrieve the underlying connection's scittle version." + (with-current-buffer (cider-current-repl) + (when nrepl-versions + (nrepl-dict-get nrepl-versions "scittle-nrepl")))) + +(defun cider-runtime () + "Return the runtime of the nREPl server." + (cond + ((cider--clojure-version) 'clojure) + ((cider--babashka-version) 'babashka) + ((cider--nbb-nrepl-version) 'nbb) + ((cider--scittle-nrepl-version) 'scittle) + (t 'generic))) + +(defun cider-runtime-clojure-p () + "Check if the current runtime is Clojure." + (eq (cider-runtime) 'clojure)) + +(defun cider--connection-info (connection-buffer &optional genericp) + "Return info about CONNECTION-BUFFER. +Info contains project name, current REPL namespace, host:port endpoint and +runtime details. When GENERICP is non-nil, don't provide specific info +about this buffer (like variable `cider-repl-type')." + (with-current-buffer connection-buffer + (cond + ((cider--clojure-version) + (format "%s%s@%s:%s (Java %s, Clojure %s, nREPL %s)" + (if genericp "" (upcase (concat (symbol-name cider-repl-type) " "))) + (or (cider--project-name nrepl-project-dir) "") + (plist-get nrepl-endpoint :host) + (plist-get nrepl-endpoint :port) + (cider--java-version) + (cider--clojure-version) + (cider--nrepl-version))) + ((cider--babashka-version) + (format "%s%s@%s:%s (Babashka %s, babashka.nrepl %s)" + (if genericp "" (upcase (concat (symbol-name cider-repl-type) " "))) + (or (cider--project-name nrepl-project-dir) "") + (plist-get nrepl-endpoint :host) + (plist-get nrepl-endpoint :port) + (cider--babashka-version) + (cider--babashka-nrepl-version))) + (t + (format "%s%s@%s:%s" + (if genericp "" (upcase (concat (symbol-name cider-repl-type) " "))) + (or (cider--project-name nrepl-project-dir) "") + (plist-get nrepl-endpoint :host) + (plist-get nrepl-endpoint :port)))))) + +(defvar-local cider-connection-capabilities '() + "A list of some of the capabilities of this connection buffer. +In other words - what assumptions we make about the runtime. +This is more general than +`cider-nrepl-op-supported-p' and `cider-library-present-p'. +But does not need to replace them.") + +(defun cider-connection-has-capability-p (capability &optional conn-buf) + "Return non nil when the cider connection has CAPABILITY for CONN-BUF. +By default it assumes the connection buffer is current." + (with-current-buffer (or conn-buf (current-buffer)) + (member capability cider-connection-capabilities))) + + +;;; Connection Management Commands + +(defun cider-quit (&optional repl) + "Quit the CIDER connection associated with REPL. +REPL defaults to the current REPL." + (interactive) + (let ((repl (or repl + (sesman-browser-get 'object) + (cider-current-repl nil 'ensure)))) + (cider--close-connection repl)) + ;; if there are no more sessions we can kill all ancillary buffers + (unless (cider-sessions) + (cider-close-ancillary-buffers)) + ;; need this to refresh sesman browser + (run-hooks 'sesman-post-command-hook)) + +(defun cider-restart (&optional repl) + "Restart CIDER connection associated with REPL. +REPL defaults to the current REPL. Don't restart the server or other +connections within the same session. Use `sesman-restart' to restart the +entire session." + (interactive) + (let* ((repl (or repl + (sesman-browser-get 'object) + (cider-current-repl nil 'ensure))) + (params (thread-first () + (cider--gather-connect-params repl) + (plist-put :session-name (sesman-session-name-for-object 'CIDER repl)) + (plist-put :repl-buffer repl)))) + (cider--close-connection repl 'no-kill) + (cider-nrepl-connect params) + ;; need this to refresh sesman browser + (run-hooks 'sesman-post-command-hook))) + +(defun cider-close-ancillary-buffers () + "Close buffers that are shared across connections." + (interactive) + (dolist (buf-name cider-ancillary-buffers) + (when (get-buffer buf-name) + (kill-buffer buf-name)))) + +(defun cider-describe-connection (&optional repl) + "Display information about the connection associated with REPL. +REPL defaults to the current REPL." + (interactive) + (let ((repl (or repl + (sesman-browser-get 'object) + (cider-current-repl nil 'ensure)))) + (message "%s" (cider--connection-info repl)))) + +(defconst cider-nrepl-session-buffer "*cider-nrepl-session*") + +(declare-function cider-nrepl-eval-session "cider-client") +(declare-function cider-nrepl-tooling-session "cider-client") +(defun cider-describe-nrepl-session () + "Describe an nREPL session." + (interactive) + (cider-ensure-connected) + (let* ((repl (cider-current-repl nil 'ensure)) + (selected-session (completing-read "Describe nREPL session: " (nrepl-sessions repl)))) + (when (and selected-session (not (equal selected-session ""))) + (let* ((session-info (nrepl-sync-request:describe repl)) + (ops (nrepl-dict-keys (nrepl-dict-get session-info "ops"))) + (session-id (nrepl-dict-get session-info "session")) + (session-type (cond + ((equal session-id (cider-nrepl-eval-session)) "Active eval") + ((equal session-id (cider-nrepl-tooling-session)) "Active tooling") + (t "Unknown")))) + (with-current-buffer (cider-popup-buffer cider-nrepl-session-buffer 'select nil 'ancillary) + (read-only-mode -1) + (insert (format "Session: %s\n" session-id) + (format "Type: %s session\n" session-type) + (format "Supported ops:\n")) + (mapc (lambda (op) (insert (format " * %s\n" op))) ops))) + (display-buffer cider-nrepl-session-buffer)))) + +(defun cider-list-nrepl-middleware () + "List the loaded nREPL middleware." + (interactive) + (cider-ensure-connected) + (let* ((repl (cider-current-repl nil 'ensure)) + (middleware (nrepl-middleware repl))) + (with-current-buffer (cider-popup-buffer "*cider-nrepl-middleware*" 'select nil 'ancillary) + (read-only-mode -1) + (insert (format "Currently loaded middleware:\n")) + (mapc (lambda (mw) (insert (format " * %s\n" mw))) middleware)) + (display-buffer "*cider-nrepl-middleware*"))) + + +;;; Sesman's Session-Wise Management UI + +(cl-defmethod sesman-project ((_system (eql CIDER))) + "Find project directory." + (clojure-project-dir (cider-current-dir))) + +(cl-defmethod sesman-more-relevant-p ((_system (eql CIDER)) session1 session2) + "Figure out if SESSION1 or SESSION2 is more relevant." + (sesman-more-recent-p (cdr session1) (cdr session2))) + +(declare-function cider-classpath-entries "cider-client") + +(defvar cider-sesman-browser-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "j q") #'cider-quit) + (define-key map (kbd "j k") #'cider-quit) + (define-key map (kbd "j r") #'cider-restart) + (define-key map (kbd "j d") #'cider-describe-connection) + (define-key map (kbd "j i") #'cider-describe-connection) + (define-key map (kbd "C-c C-q") #'cider-quit) + (define-key map (kbd "C-c C-r") #'cider-restart) + (define-key map (kbd "C-c M-r") #'cider-restart) + (define-key map (kbd "C-c C-d") #'cider-describe-connection) + (define-key map (kbd "C-c M-d") #'cider-describe-connection) + (define-key map (kbd "C-c C-i") #'cider-describe-connection) + map) + "Map active on REPL objects in sesman browser.") + +(cl-defmethod sesman-session-info ((_system (eql CIDER)) session) + "Obtain info for a CIDER SESSION." + (list :objects (cdr session) + :map cider-sesman-browser-map)) + +(declare-function cider "cider") +(cl-defmethod sesman-start-session ((_system (eql CIDER))) + "Start a connection of any type interactively. +Fallback on `cider' command." + (call-interactively #'cider)) + +(cl-defmethod sesman-quit-session ((_system (eql CIDER)) session) + "Quit a CIDER SESSION." + (mapc #'cider--close-connection (cdr session)) + ;; if there are no more session we can kill all ancillary buffers + (unless (cider-sessions) + (cider-close-ancillary-buffers))) + +(cl-defmethod sesman-restart-session ((_system (eql CIDER)) session) + "Restart a CIDER SESSION." + (let* ((ses-name (car session)) + (repls (cdr session)) + (srv-buf (cider--session-server session))) + (if srv-buf + ;; session with a server + (let ((s-params (cider--gather-connect-params nil srv-buf))) + ;; 1) kill all connections, but keep the buffers + (mapc (lambda (conn) + (cider--close-connection conn 'no-kill)) + repls) + ;; 2) kill the server + (nrepl-kill-server-buffer srv-buf) + ;; 3) start server + (nrepl-start-server-process + (plist-get s-params :project-dir) + (plist-get s-params :server-command) + (lambda (server-buf) + ;; 4) restart the repls reusing the buffer + (dolist (r repls) + (cider-nrepl-connect + (thread-first () + (cider--gather-connect-params r) + ;; server params (:port, :project-dir etc) have precedence + (cider--gather-connect-params server-buf) + (plist-put :session-name ses-name) + (plist-put :repl-buffer r)))) + (sesman-browser-revert-all 'CIDER) + (message "Restarted CIDER %s session" ses-name)))) + ;; server-less session + (dolist (r repls) + (cider--close-connection r 'no-kill) + (cider-nrepl-connect + (thread-first () + (cider--gather-connect-params r) + (plist-put :session-name ses-name) + (plist-put :repl-buffer r))))))) + +(defun cider--ensure-spec-is-not-invokable (spec) + "Ensures SPEC cannot be invoked as a function. + +Invokeable specs are an Emacs 29 feature +that we don't intend to use in this context." + (let ((spec-char (car spec)) + (spec-value (cdr spec))) + `(,spec-char + . + ,(if (symbolp spec-value) + (prin1-to-string spec-value) + spec-value)))) + +(defun cider-format-connection-params (template params) + "Format PARAMS with TEMPLATE string. +The following formats can be used in TEMPLATE string: + + %h - host + %H - remote host, empty for local hosts + %p - port + %j - short project name, or directory name if no project + %J - long project name including parent dir name + %r - REPL type (clj or cljs) + %S - type of the ClojureScript runtime (Browser, Node, Figwheel etc.) + %s - session name as defined by `cider-session-name-template'. + +In case some values are empty, extra separators (: and -) are automatically +removed." + (let* ((dir (directory-file-name + (abbreviate-file-name + (or (plist-get params :project-dir) + (clojure-project-dir (cider-current-dir)) + default-directory)))) + (short-proj (file-name-nondirectory (directory-file-name dir))) + (parent-dir (ignore-errors + (thread-first dir + file-name-directory + directory-file-name file-name-nondirectory + file-name-as-directory))) + (long-proj (format "%s%s" (or parent-dir "") short-proj)) + ;; use `dir` if it is shorter than `long-proj` or `short-proj` + (short-proj (if (>= (length short-proj) (length dir)) + dir + short-proj)) + (long-proj (if (>= (length long-proj) (length dir)) + dir + long-proj)) + (port (or (plist-get params :port) "")) + (host (or (plist-get params :host) "localhost")) + (remote-host (if (member host '("localhost" "127.0.0.1")) + "" + host)) + (repl-type (or (plist-get params :repl-type) "unknown")) + (cljs-repl-type (or (and (eq repl-type 'cljs) + (plist-get params :cljs-repl-type)) + "")) + (specs `((?h . ,host) + (?H . ,remote-host) + (?p . ,port) + (?j . ,short-proj) + (?J . ,long-proj) + (?r . ,repl-type) + (?S . ,cljs-repl-type))) + (ses-name (or (plist-get params :session-name) + (format-spec cider-session-name-template specs))) + (specs (append `((?s . ,ses-name)) specs)) + (specs (mapcar #'cider--ensure-spec-is-not-invokable specs))) + (thread-last (format-spec template specs) + ;; remove extraneous separators + (replace-regexp-in-string "\\([:-]\\)[:-]+" "\\1") + (replace-regexp-in-string "\\(^[:-]\\)\\|\\([:-]$\\)" "") + (replace-regexp-in-string "[:-]\\([])*]\\)" "\\1")))) + +(defun cider-make-session-name (params) + "Create new session name given plist of connection PARAMS. +Session name can be customized with `cider-session-name-template'." + (let* ((root-name (cider-format-connection-params cider-session-name-template params)) + (other-names (mapcar #'car (sesman-sessions 'CIDER))) + (name root-name) + (i 2)) + (while (member name other-names) + (setq name (concat root-name "#" (number-to-string i)) + i (+ i 1))) + name)) + + +;;; REPL Buffer Init + +(defvar-local cider-cljs-repl-type nil + "The type of the ClojureScript runtime ('browser, 'node, 'figwheel, etc.).") + +(defvar-local cider-repl-type nil + "The type of this REPL buffer, usually either clj or cljs.") + +(defvar-local cider-repl-cljs-upgrade-pending nil + "Is the cljs repl currently pending?") + +(defun cider-repl-type (repl-buffer) + "Get REPL-BUFFER's type." + (buffer-local-value 'cider-repl-type repl-buffer)) + +(defun cider-cljs-pending-p (repl-buffer) + "Returns non nil when REPL-BUFFER is currently a pending cljs repl." + (buffer-local-value 'cider-repl-cljs-upgrade-pending repl-buffer)) + +(defun cider-repl-type-for-buffer (&optional buffer) + "Return the matching connection type (clj or cljs) for BUFFER. +BUFFER defaults to the `current-buffer'. In cljc buffers return +multi. This function infers connection type based on the major mode. +For the REPL type use the function `cider-repl-type'." + (with-current-buffer (or buffer (current-buffer)) + (cond + ((cider-clojurescript-major-mode-p) 'cljs) + ((cider-clojurec-major-mode-p) cider-clojurec-eval-destination) + ((cider-clojure-major-mode-p) 'clj) + (cider-repl-type)))) + +(defun cider-set-repl-type (&optional type) + "Set REPL TYPE to clj or cljs. +Assume that the current buffer is a REPL." + (interactive) + (let ((type (cider-maybe-intern (or type (completing-read + (format "Set REPL type (currently `%s') to: " + cider-repl-type) + '(clj cljs)))))) + (when (or (not (equal cider-repl-type type)) + (null mode-name)) + (setq cider-repl-type type) + (setq mode-name (format "REPL[%s]" type)) + (let ((params (cider--gather-connect-params))) + ;; We need to set current name to something else temporarily to avoid + ;; false name duplication in `nrepl-repl-buffer-name`. + (rename-buffer (generate-new-buffer-name "*dummy-cider-repl-buffer*")) + (rename-buffer (nrepl-repl-buffer-name params)) + (when (and nrepl-log-messages nrepl-messages-buffer) + (with-current-buffer nrepl-messages-buffer + (rename-buffer (nrepl-messages-buffer-name params)))))))) + +(defun cider--choose-reusable-repl-buffer (params) + "Find connection-less REPL buffer and ask the user for confirmation. +Return nil if no such buffers exists or the user has chosen not to reuse +the buffer. If multiple dead REPLs exist, ask the user to choose one. +PARAMS is a plist as received by `cider-repl-create'." + (when-let* ((repls (seq-filter (lambda (b) + (with-current-buffer b + (and (derived-mode-p 'cider-repl-mode) + (not (process-live-p (get-buffer-process b)))))) + (buffer-list)))) + (let* ((proj-dir (plist-get params :project-dir)) + (host (plist-get params :host)) + (port (plist-get params :port)) + (type (plist-get params :repl-type)) + (scored-repls + (mapcar (lambda (b) + (let ((bparams (ignore-errors (cider--gather-connect-params nil b)))) + (when (eq type (plist-get bparams :repl-type)) + (cons b (+ + (if (equal proj-dir (plist-get bparams :project-dir)) 8 0) + (if (equal host (plist-get bparams :host)) 4 0) + (if (equal port (plist-get bparams :port)) 2 0)))))) + repls)) + (sorted-repls (mapcar #'car (seq-sort-by #'cdr #'> (delq nil scored-repls))))) + (cond ((null sorted-repls) nil) + ((and (= 1 (length sorted-repls)) + (eq cider-reuse-dead-repls 'prompt)) + (if (y-or-n-p (format "A dead REPL %s exists. Reuse buffer? " (car sorted-repls))) + (car sorted-repls) + (and (y-or-n-p "Kill dead REPL buffer?") + (kill-buffer (car sorted-repls)) + nil))) + ((and (< 1 (length sorted-repls)) + (memq cider-reuse-dead-repls '(prompt auto))) + (if (y-or-n-p "Dead REPL buffers exist. Select one to reuse? ") + (get-buffer (completing-read "REPL buffer to reuse: " (mapcar #'buffer-name sorted-repls) + nil t nil nil (car sorted-repls))) + (and (y-or-n-p "Kill all dead REPL buffers?") + (mapc #'kill-buffer sorted-repls) + nil))) + (cider-reuse-dead-repls ;; fallthrough for 'auto / 'any / other non-nil values + (car sorted-repls)))))) + +(declare-function cider-default-err-handler "cider-eval") +(declare-function cider-repl-mode "cider-repl") +(declare-function cider-repl--state-handler "cider-repl") +(declare-function cider-repl-reset-markers "cider-repl") +(defvar-local cider-session-name nil) +(defvar-local cider-repl-init-function nil) +(defvar-local cider-launch-params nil) +(defun cider-repl-create (params) + "Create new repl buffer. +PARAMS is a plist which contains :repl-type, :host, :port, :project-dir, +:repl-init-function and :session-name. When non-nil, :repl-init-function +must be a function with no arguments which is called after repl creation +function with the repl buffer set as current." + ;; Connection might not have been set as yet. Please don't send requests in + ;; this function, but use cider--connected-handler instead. + (let ((buffer (or (plist-get params :repl-buffer) + (and cider-reuse-dead-repls + (cider--choose-reusable-repl-buffer params)) + (get-buffer-create (generate-new-buffer-name "*cider-uninitialized-repl*")))) + (ses-name (or (plist-get params :session-name) + (cider-make-session-name params)))) + (with-current-buffer buffer + (setq-local sesman-system 'CIDER) + (setq-local default-directory (or (plist-get params :project-dir) default-directory)) + ;; creates a new session if session with ses-name doesn't already exist + (sesman-add-object 'CIDER ses-name buffer 'allow-new) + (unless (derived-mode-p 'cider-repl-mode) + (cider-repl-mode)) + (setq nrepl-err-handler #'cider-default-err-handler + ;; used as a new-repl marker in cider-set-repl-type + mode-name nil + cider-session-name ses-name + nrepl-project-dir (plist-get params :project-dir) + ;; Cljs repls are pending until they are upgraded. See cider-repl--state-handler + cider-repl-type (plist-get params :repl-type) + cider-repl-cljs-upgrade-pending (plist-get params :cider-repl-cljs-upgrade-pending) + ;; ran at the end of cider--connected-handler + cider-repl-init-function (plist-get params :repl-init-function) + cider-launch-params params) + (when-let ((type (plist-get params :cljs-repl-type))) + (setq cider-cljs-repl-type type)) + (cider-repl-reset-markers) + (add-hook 'nrepl-response-handler-functions #'cider-repl--state-handler nil 'local) + (add-hook 'nrepl-connected-hook #'cider--connected-handler nil 'local) + (add-hook 'nrepl-disconnected-hook #'cider--disconnected-handler nil 'local) + (current-buffer)))) + + +;;; Current/other REPLs + +(defun cider--no-repls-user-error (type) + "Throw \"No REPL\" user error customized for TYPE." + (let ((type (cond + ((or (eq type 'multi) (eq type 'any)) + "clj or cljs") + ((listp type) + (mapconcat #'identity type " or ")) + (type)))) + (user-error "No %s REPLs in current session \"%s\"" + type (car (sesman-current-session 'CIDER))))) + +(defun cider-current-repl (&optional type ensure) + "Get the most recent REPL of TYPE from the current session. +TYPE is either clj, cljs, multi or any. +When nil, infer the type from the current buffer. +If ENSURE is non-nil, throw an error if either there is +no linked session or there is no REPL of TYPE within the current session." + (let ((type (cider-maybe-intern type))) + (if (and (derived-mode-p 'cider-repl-mode) + (or (null type) + (eq 'any type) + (eq cider-repl-type type))) + ;; shortcut when in REPL buffer + (current-buffer) + (let* ((type (or type (cider-repl-type-for-buffer))) + (repls (cider-repls type ensure)) + (repl (if (<= (length repls) 1) + (car repls) + ;; pick the most recent one + (seq-find (lambda (b) + (member b repls)) + (buffer-list))))) + (if (and ensure (null repl)) + (cider--no-repls-user-error type) + repl))))) + +(defun cider--match-repl-type (type buffer) + "Return non-nil if TYPE matches BUFFER's REPL type." + (let ((buffer-repl-type (cider-repl-type buffer))) + (cond ((null buffer-repl-type) nil) + ((or (null type) (eq type 'multi) (eq type 'any)) t) + ((listp type) (member buffer-repl-type type)) + (t + (or (string= type buffer-repl-type) + (let ((capabilities + (buffer-local-value 'cider-connection-capabilities buffer))) + (cond ((listp type) + (cl-some (lambda (it) (member it capabilities)) type)) + (t (member type capabilities))))))))) + +(defun cider--get-host-from-session (session) + "Returns the host associated with SESSION." + (plist-get (cider--gather-session-params session) + :host)) + +(defun cider--make-sessions-list-with-hosts (sessions) + "Makes a list of SESSIONS and their hosts. +Returns a list of the form ((session1 host1) (session2 host2) ...)." + (mapcar (lambda (session) + (list session (cider--get-host-from-session session))) + sessions)) + +(defun cider--get-sessions-with-same-host (session sessions) + "Returns a list of SESSIONS with the same host as SESSION." + (mapcar #'car + (seq-filter (lambda (x) + (string-equal (cadr x) + (cider--get-host-from-session session))) + (cider--make-sessions-list-with-hosts sessions)))) + +(defun cider--extract-connections (sessions) + "Returns a flattened list of all session buffers in SESSIONS." + (cl-reduce (lambda (x y) + (append x (cdr y))) + sessions + :initial-value '())) + +(defun cider-repls (&optional type ensure) + "Return cider REPLs of TYPE from the current session. +If TYPE is nil or multi, return all REPLs. If TYPE is a list of types, +return only REPLs of type contained in the list. If ENSURE is non-nil, +throw an error if no linked session exists." + (let ((type (cond + ((listp type) + (mapcar #'cider-maybe-intern type)) + ((cider-maybe-intern type)))) + (repls (pcase cider-merge-sessions + ('host + (if ensure + (or (cider--extract-connections (cider--get-sessions-with-same-host + (sesman-current-session 'CIDER) + (sesman-current-sessions 'CIDER))) + (user-error "No linked %s sessions" 'CIDER)) + (cider--extract-connections (cider--get-sessions-with-same-host + (sesman-current-session 'CIDER) + (sesman-current-sessions 'CIDER))))) + ('project + (if ensure + (or (cider--extract-connections (sesman-current-sessions 'CIDER)) + (user-error "No linked %s sessions" 'CIDER)) + (cider--extract-connections (sesman-current-sessions 'CIDER)))) + (_ (cdr (if ensure + (sesman-ensure-session 'CIDER) + (sesman-current-session 'CIDER))))))) + (or (seq-filter (lambda (b) + (unless + (cider-cljs-pending-p b) + (cider--match-repl-type type b))) + repls) + (when ensure + (cider--no-repls-user-error type))))) + +(defun cider-map-repls (which function) + "Call FUNCTION once for each appropriate REPL as indicated by WHICH. +The function is called with one argument, the REPL buffer. The appropriate +connections are found by inspecting the current buffer. WHICH is one of +the following keywords: + :auto - Act on the connections whose type matches the current buffer. In + `cljc' files, mapping happens over both types of REPLs. + :clj (:cljs) - Map over clj (cljs)) REPLs only. + :clj-strict (:cljs-strict) - Map over clj (cljs) REPLs but signal a + `user-error' in `clojurescript-mode' (`clojure-mode'). Use this for + commands only supported in Clojure (ClojureScript). +Error is signaled if no REPL buffers of specified type exist in current +session." + (declare (indent 1)) + (let ((cur-type (cider-repl-type-for-buffer))) + (cl-case which + (:clj-strict (when (eq cur-type 'cljs) + (user-error "Clojure-only operation requested in a ClojureScript buffer"))) + (:cljs-strict (when (eq cur-type 'clj) + (user-error "ClojureScript-only operation requested in a Clojure buffer")))) + (let* ((type (cl-case which + ((:clj :clj-strict) 'clj) + ((:cljs :cljs-strict) 'cljs) + (:auto (if (eq cur-type 'multi) + '(clj cljs) + cur-type)))) + (ensure (cl-case which + (:auto nil) + (t 'ensure))) + (repls (cider-repls type ensure))) + (mapcar function repls)))) + +;; REPLs double as connections in CIDER, so it's useful to be able to refer to +;; them as connections in certain contexts. +(defalias 'cider-current-connection #'cider-current-repl) +(defalias 'cider-connections #'cider-repls) +(defalias 'cider-map-connections #'cider-map-repls) +(defalias 'cider-connection-type-for-buffer #'cider-repl-type-for-buffer) + +;; Deprecated after #2324 (introduction of sesman) + +(define-obsolete-function-alias 'cider-current-repl-buffer #'cider-current-repl "0.18") +(define-obsolete-function-alias 'cider-repl-buffers #'cider-repls "0.18") +(define-obsolete-function-alias 'cider-current-session #'cider-nrepl-eval-session "0.18") +(define-obsolete-function-alias 'cider-current-tooling-session #'cider-nrepl-tooling-session "0.18") +(define-obsolete-function-alias 'nrepl-connection-buffer-name #'nrepl-repl-buffer-name "0.18") + +(provide 'cider-connection) + +;;; cider-connection.el ends here diff --git a/elpa/cider-20241203.1607/cider-debug.el b/elpa/cider-20241203.1607/cider-debug.el new file mode 100644 index 00000000..5b9a69b3 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-debug.el @@ -0,0 +1,801 @@ +;;; cider-debug.el --- CIDER interaction with the cider.debug nREPL middleware -*- lexical-binding: t; -*- + +;; Copyright © 2015-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors + +;; Author: Artur Malabarba + +;; 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 . + +;;; Commentary: + +;; Instrument code with `cider-debug-defun-at-point', and when the code is +;; executed cider-debug will kick in. See this function's doc for more +;; information. + +;;; Code: + +(require 'map) +(require 'seq) +(require 'subr-x) + +(require 'spinner) + +(require 'cider-browse-ns) +(require 'cider-client) +(require 'cider-eval) +(require 'cider-inspector) +(require 'cider-util) +(require 'cider-common) +(require 'nrepl-client) ; `nrepl--mark-id-completed' +(require 'nrepl-dict) + + +;;; Customization +(defgroup cider-debug nil + "Presentation and behavior of the cider debugger." + :prefix "cider-debug-" + :group 'cider + :package-version '(cider . "0.10.0")) + +(defface cider-debug-code-overlay-face + '((((class color) (background light)) :background "grey80") + (((class color) (background dark)) :background "grey30")) + "Face used to mark code being debugged." + :package-version '(cider . "0.9.1")) + +(defface cider-debug-prompt-face + '((t :underline t :inherit font-lock-builtin-face)) + "Face used to highlight keys in the debug prompt." + :package-version '(cider . "0.10.0")) + +(defface cider-enlightened-face + '((((class color) (background light)) :inherit cider-result-overlay-face + :box (:color "darkorange" :line-width -1)) + (((class color) (background dark)) :inherit cider-result-overlay-face + ;; "#dd0" is a dimmer yellow. + :box (:color "#990" :line-width -1))) + "Face used to mark enlightened sexps and their return values." + :package-version '(cider . "0.11.0")) + +(defface cider-enlightened-local-face + '((((class color) (background light)) :weight bold :foreground "darkorange") + (((class color) (background dark)) :weight bold :foreground "yellow")) + "Face used to mark enlightened locals (not their values)." + :package-version '(cider . "0.11.0")) + +(defcustom cider-debug-prompt 'overlay + "If and where to show the keys while debugging. +If `minibuffer', show it in the minibuffer along with the return value. +If `overlay', show it in an overlay above the current function. +If t, do both. +If nil, don't list available keys at all." + :type '(choice (const :tag "Show in minibuffer" minibuffer) + (const :tag "Show above function" overlay) + (const :tag "Show in both places" t) + (const :tag "Don't list keys" nil)) + :package-version '(cider . "0.10.0")) + +(defcustom cider-debug-use-overlays t + "Whether to highlight debugging information with overlays. +Takes the same possible values as `cider-use-overlays', but only applies to +values displayed during debugging sessions. +To control the overlay that lists possible keys above the current function, +configure `cider-debug-prompt' instead." + :type '(choice (const :tag "End of line" t) + (const :tag "Bottom of screen" nil) + (const :tag "Both" both)) + :package-version '(cider . "0.9.1")) + +(make-obsolete 'cider-debug-print-length 'cider-debug-print-options "0.20") +(make-obsolete 'cider-debug-print-level 'cider-debug-print-options "0.20") +(make-obsolete-variable 'cider-debug-print-options 'cider-print-options "0.21") + + +;;; Implementation +(declare-function cider-browse-ns--combined-vars-with-meta "cider-browse-ns") + +(defun cider-browse-instrumented-defs () + "List all instrumented definitions." + (interactive) + (if-let* ((all (thread-first (cider-nrepl-send-sync-request '("op" "debug-instrumented-defs")) + (nrepl-dict-get "list")))) + (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t) + (let ((inhibit-read-only t)) + (dolist (list all) + (let* ((ns (car list)) + (ns-vars-with-meta (cider-browse-ns--combined-vars-with-meta ns)) + (instrumented-meta (nrepl-dict-filter (lambda (k _) + (member k list)) + ns-vars-with-meta))) + (cider-browse-ns--list (current-buffer) ns + instrumented-meta + ns))))) + (message "No currently instrumented definitions"))) + +(defun cider--debug-response-handler (response) + "Handles RESPONSE from the cider.debug middleware." + (nrepl-dbind-response response (status id causes caught-msg) + (when (member "enlighten" status) + (cider--handle-enlighten response)) + (when (or (member "eval-error" status) + (member "stack" status)) + ;; TODO: Make the error buffer a bit friendlier when we're just printing + ;; the stack. + (if cider-show-error-buffer + (cider--render-stacktrace-causes causes) + (cider--debug-display-result-overlay nil caught-msg))) + (when (member "need-debug-input" status) + (cider--handle-debug response)) + (when (member "done" status) + (nrepl--mark-id-completed id)))) + +(defun cider--debug-init-connection () + "Initialize a connection with the cider.debug middleware." + (cider-nrepl-send-request + (thread-last + (map-merge 'list + '(("op" "init-debugger")) + (cider--nrepl-print-request-map fill-column)) + (seq-mapcat #'identity)) + #'cider--debug-response-handler)) + + +;;; Debugging overlays +(defconst cider--fringe-arrow-string + #("." 0 1 (display (left-fringe right-triangle))) + "Used as an overlay's before-string prop to place a fringe arrow.") + +(defun cider--debug-display-result-overlay (value caught) + "Place an overlay at point displaying VALUE. +When CAUGHT is non-nil, display it as an error message overlay." + (when cider-debug-use-overlays + ;; This is cosmetic, let's ensure it doesn't break the session no matter what. + (ignore-errors + ;; Result + (cider--make-result-overlay (or caught (cider-font-lock-as-clojure value)) + :where (point-marker) + :type 'debug-result + :prepend-face (if caught 'cider-error-overlay-face + 'cider-result-overlay-face) + 'before-string cider--fringe-arrow-string) + ;; Code + (cider--make-overlay (save-excursion (clojure-backward-logical-sexp 1) (point)) + (point) 'debug-code + 'face 'cider-debug-code-overlay-face + ;; Higher priority than `show-paren'. + 'priority 2000)))) + + +;;; Minor mode +(defvar-local cider--debug-mode-response nil + "Response that triggered current debug session. +Set by `cider--turn-on-debug-mode'.") + +(defcustom cider-debug-display-locals nil + "If non-nil, local variables are displayed while debugging. +Can be toggled at any time with `\\[cider-debug-toggle-locals]'." + :type 'boolean + :package-version '(cider . "0.10.0")) + +(defcustom cider-debug-prompt-commands + '((?c "continue" "continue") + (?C "continue-all" nil) + (?n "next" "next") + (?i "in" "in") + (?o "out" "out") + (?O "force-out" nil) + (?h "here" "here") + (?e "eval" "eval") + (?p "inspect" "inspect") + (?P "inspect-prompt" nil) + (?l "locals" "locals") + (?j "inject" "inject") + (?s "stacktrace" "stacktrace") + (?t "trace" "trace") + (?q "quit" "quit")) + "A list of debugger command specs. + +Specs are in the format (KEY COMMAND-NAME DISPLAY-NAME?) where KEY is a +character which is mapped to the command COMMAND-NAME is a valid debug +command to be passed to the cider-nrepl middleware DISPLAY-NAME is the +string displayed in the debugger overlay + +If DISPLAY-NAME is nil, that command is hidden from the overlay but still +callable. The rest of the commands are displayed in the same order as this +list." + :type '(alist :key-type character + :value-type (list + (string :tag "command name") + (choice (string :tag "display name") nil))) + :package-version '(cider . "0.24.0")) + +(defun cider--debug-format-locals-list (locals) + "Return a string description of list LOCALS. +Each element of LOCALS should be a list of at least two elements." + (if locals + (let ((left-col-width + ;; To right-indent the variable names. + (apply #'max (mapcar (lambda (l) (string-width (car l))) locals)))) + ;; A format string to build a format string. :-P + (mapconcat (lambda (l) (format (format " %%%ds: %%s\n" left-col-width) + (propertize (car l) 'face 'font-lock-variable-name-face) + (cider-font-lock-as-clojure (cadr l)))) + locals "")) + "")) + +(defun cider--debug-propertize-prompt-commands () + "In-place format the command display names for the `cider-debug-prompt' overlay." + (mapc (lambda (spec) + (cl-destructuring-bind (char _cmd disp-name) spec + (when-let* ((pos (cl-position char disp-name))) + (put-text-property pos (1+ pos) 'face 'cider-debug-prompt-face disp-name)))) + cider-debug-prompt-commands)) + +(defun cider--debug-prompt (commands) + "Return prompt to display for COMMANDS." + ;; Force `default' face, otherwise the overlay "inherits" the face of the text + ;; after it. + (format (propertize "%s\n" 'face 'default) + (cl-reduce + (lambda (prompt spec) + (cl-destructuring-bind (_char cmd disp) spec + (if (and disp (cl-find cmd commands :test 'string=)) + (concat prompt " " disp) + prompt))) + cider-debug-prompt-commands + :initial-value ""))) + +(defvar-local cider--debug-prompt-overlay nil) + +(defun cider--debug-mode-redisplay () + "Display the input prompt to the user." + (nrepl-dbind-response cider--debug-mode-response (debug-value input-type locals) + ;; input-type is an unsorted collection of command names, + ;; as sent by `cider.nrepl.middleware.debug/read-debug-input` + (when (or (eq cider-debug-prompt t) + (eq cider-debug-prompt 'overlay)) + (if (overlayp cider--debug-prompt-overlay) + (overlay-put cider--debug-prompt-overlay + 'before-string (cider--debug-prompt input-type)) + (setq cider--debug-prompt-overlay + (cider--make-overlay + (max (car (cider-defun-at-point 'bounds)) + (window-start)) + nil 'debug-prompt + 'before-string (cider--debug-prompt input-type))))) + (let* ((value (concat " " cider-eval-result-prefix + (cider-font-lock-as-clojure + (or debug-value "#unknown#")))) + (to-display + (concat (when cider-debug-display-locals + (cider--debug-format-locals-list locals)) + (when (or (eq cider-debug-prompt t) + (eq cider-debug-prompt 'minibuffer)) + (cider--debug-prompt input-type)) + (when (or (not cider-debug-use-overlays) + (eq cider-debug-use-overlays 'both)) + value)))) + (if (> (string-width to-display) 0) + (message "%s" to-display) + ;; If there's nothing to display in the minibuffer. Just send the value + ;; to the Messages buffer. + (message "%s" value) + (message nil))))) + +(defun cider-debug-toggle-locals () + "Toggle display of local variables." + (interactive) + (setq cider-debug-display-locals (not cider-debug-display-locals)) + (cider--debug-mode-redisplay)) + +(defun cider--debug-lexical-eval (key form &optional callback _point) + "Eval FORM in the lexical context of debug session given by KEY. +Do nothing if CALLBACK is provided. +Designed to be used as `cider-interactive-eval-override' and called instead +of `cider-interactive-eval' in debug sessions." + ;; The debugger uses its own callback, so if the caller is passing a callback + ;; we return nil and let `cider-interactive-eval' do its thing. + (unless callback + (cider-debug-mode-send-reply (format "{:response :eval, :code %s}" form) + key) + t)) + +(defvar cider--debug-mode-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + (tool-bar-add-item "right-arrow" #'cider-debug-mode-send-reply :next :label "Next step") + (tool-bar-add-item "next-node" #'cider-debug-mode-send-reply :continue :label "Continue") + (tool-bar-add-item "jump-to" #'cider-debug-mode-send-reply :out :label "Out of sexp") + (tool-bar-add-item "exit" #'cider-debug-mode-send-reply :quit :label "Quit") + tool-bar-map)) + +(defvar cider--debug-mode-map + (let ((map (make-sparse-keymap))) + ;; Bind the `:here` command to both h and H, because it behaves differently + ;; if invoked with an uppercase letter. + (define-key map "h" #'cider-debug-move-here) + (define-key map "H" #'cider-debug-move-here) + (define-key map "L" #'cider-debug-toggle-locals) + map) + "The active keymap during a debugging session.") + +(define-minor-mode cider--debug-mode + "Mode active during debug sessions. +In order to work properly, this mode must be activated by +`cider--turn-on-debug-mode'." + :init-value nil :lighter " DEBUG" :keymap '() + (if cider--debug-mode + (if cider--debug-mode-response + (nrepl-dbind-response cider--debug-mode-response (input-type) + ;; A debug session is an ongoing eval, but it's annoying to have the + ;; spinner spinning while you debug. + (when spinner-current (spinner-stop)) + (setq-local tool-bar-map cider--debug-mode-tool-bar-map) + (add-hook 'kill-buffer-hook #'cider--debug-quit nil 'local) + (add-hook 'before-revert-hook #'cider--debug-quit nil 'local) + (unless (consp input-type) + (error "Activated debug-mode on a message not asking for commands: %s" cider--debug-mode-response)) + ;; Integrate with eval commands. + (setq cider-interactive-eval-override + (apply-partially #'cider--debug-lexical-eval + (nrepl-dict-get cider--debug-mode-response "key"))) + ;; Map over the key->command alist and set the keymap + (mapc + (lambda (p) + (let ((char (car p))) + (unless (= char ?h) ; `here' needs a special command. + (define-key cider--debug-mode-map (string char) #'cider-debug-mode-send-reply)) + (when (= char ?o) + (define-key cider--debug-mode-map (string (upcase ?o)) #'cider-debug-mode-send-reply)))) + cider-debug-prompt-commands) + (cider--debug-propertize-prompt-commands) + ;; Show the prompt. + (cider--debug-mode-redisplay) + ;; If a sync request is ongoing, the user can't act normally to + ;; provide input, so we enter `recursive-edit'. + (when nrepl-ongoing-sync-request + (recursive-edit))) + (cider--debug-mode -1) + (if (called-interactively-p 'any) + (user-error (substitute-command-keys "Don't call this mode manually, use `\\[universal-argument] \\[cider-eval-defun-at-point]' instead")) + (error "Attempt to activate `cider--debug-mode' without setting `cider--debug-mode-response' first"))) + (setq cider-interactive-eval-override nil) + (setq cider--debug-mode-response nil) + ;; We wait a moment before clearing overlays and the read-onlyness, so that + ;; cider-nrepl has a chance to send the next message, and so that the user + ;; doesn't accidentally hit `n' between two messages (thus editing the code). + (when-let* ((proc (unless nrepl-ongoing-sync-request + (get-buffer-process (cider-current-repl))))) + (accept-process-output proc 1)) + (unless cider--debug-mode + (setq buffer-read-only nil) + (cider--debug-remove-overlays (current-buffer))) + (when nrepl-ongoing-sync-request + (ignore-errors (exit-recursive-edit))))) + +(defun cider--debug-remove-overlays (&optional buffer) + "Remove CIDER debug overlays from BUFFER if variable `cider--debug-mode' is nil." + (when (or (not buffer) (buffer-live-p buffer)) + (with-current-buffer (or buffer (current-buffer)) + (unless cider--debug-mode + (kill-local-variable 'tool-bar-map) + (remove-overlays nil nil 'category 'debug-result) + (remove-overlays nil nil 'category 'debug-code) + (setq cider--debug-prompt-overlay nil) + (remove-overlays nil nil 'category 'debug-prompt))))) + +(defun cider--debug-set-prompt (value) + "Set `cider-debug-prompt' to VALUE, then redisplay." + (setq cider-debug-prompt value) + (cider--debug-mode-redisplay)) + +(easy-menu-define cider-debug-mode-menu cider--debug-mode-map + "Menu for CIDER debug mode." + `("CIDER Debugger" + ["Next step" (cider-debug-mode-send-reply ":next") :keys "n"] + ["Continue" (cider-debug-mode-send-reply ":continue") :keys "c"] + ["Continue non-stop" (cider-debug-mode-send-reply ":continue-all") :keys "C"] + ["Move out of sexp" (cider-debug-mode-send-reply ":out") :keys "o"] + ["Forced move out of sexp" (cider-debug-mode-send-reply ":out" nil true) :keys "O"] + ["Move to current position" (cider-debug-mode-send-reply ":here") :keys "h"] + ["Quit" (cider-debug-mode-send-reply ":quit") :keys "q"] + "--" + ["Evaluate in current scope" (cider-debug-mode-send-reply ":eval") :keys "e"] + ["Inject value" (cider-debug-mode-send-reply ":inject") :keys "i"] + ["Inspect current value" (cider-debug-mode-send-reply ":inspect") :keys "p"] + ["Inspect expression" (cider-debug-mode-send-reply ":inspect-prompt") :keys "P"] + ["Inspect local variables" (cider-debug-mode-send-reply ":locals") :keys "l"] + "--" + ("Configure keys prompt" + ["Don't show keys" (cider--debug-set-prompt nil) :style toggle :selected (eq cider-debug-prompt nil)] + ["Show in minibuffer" (cider--debug-set-prompt 'minibuffer) :style toggle :selected (eq cider-debug-prompt 'minibuffer)] + ["Show above function" (cider--debug-set-prompt 'overlay) :style toggle :selected (eq cider-debug-prompt 'overlay)] + ["Show in both places" (cider--debug-set-prompt t) :style toggle :selected (eq cider-debug-prompt t)] + "--" + ["List locals" cider-debug-toggle-locals :style toggle :selected cider-debug-display-locals]) + ["Customize" (customize-group 'cider-debug)])) + +(defun cider--uppercase-command-p () + "Return non-nil if the last command was uppercase letter." + (ignore-errors + (let ((case-fold-search nil)) + (string-match "[[:upper:]]" (string last-command-event))))) + +(defun cider-debug-mode-send-reply (command &optional key force) + "Reply to the message that started current bufer's debugging session. +COMMAND is sent as the input option. KEY can be provided to reply to a +specific message. If FORCE is non-nil, send a \"force?\" argument in the +message." + (interactive (list + (if (symbolp last-command-event) + (symbol-name last-command-event) + (ignore-errors + (concat ":" (cadr (assoc last-command-event cider-debug-prompt-commands))))) + nil + (cider--uppercase-command-p))) + (when (and (string-prefix-p ":" command) force) + (setq command (format "{:response %s :force? true}" command))) + (cider-nrepl-send-unhandled-request + `("op" "debug-input" + "input" ,(or command ":quit") + "key" ,(or key (nrepl-dict-get cider--debug-mode-response "key")))) + (ignore-errors (cider--debug-mode -1))) + +(defun cider--debug-quit () + "Send a :quit reply to the debugger. Used in hooks." + (when cider--debug-mode + (cider-debug-mode-send-reply ":quit") + (message "Quitting debug session"))) + + +;;; Movement logic +(defconst cider--debug-buffer-format "*cider-debug %s*") + +(defun cider--debug-trim-code (code) + "Remove whitespace and reader macros from the start of the CODE. +Return trimmed CODE." + (replace-regexp-in-string "\\`#[a-z]+[\n\r[:blank:]]*" "" code)) + +(declare-function cider-set-buffer-ns "cider-mode") +(defun cider--initialize-debug-buffer (code ns id &optional reason) + "Create a new debugging buffer with CODE and namespace NS. +ID is the id of the message that instrumented CODE. +REASON is a keyword describing why this buffer was necessary." + (let ((buffer-name (format cider--debug-buffer-format id))) + (if-let* ((buffer (get-buffer buffer-name))) + (cider-popup-buffer-display buffer 'select) + (with-current-buffer (cider-popup-buffer buffer-name 'select + #'clojure-mode 'ancillary) + (cider-set-buffer-ns ns) + (setq buffer-undo-list nil) + (let ((inhibit-read-only t) + (buffer-undo-list t)) + (erase-buffer) + (insert (format "%s" (cider--debug-trim-code code))) + (when code + (insert "\n\n\n;; We had to create this temporary buffer because we couldn't find the original definition. That probably happened because " + reason + ".") + (fill-paragraph)) + (font-lock-ensure) + (set-buffer-modified-p nil)))) + (switch-to-buffer buffer-name) + (goto-char (point-min)))) + +(defun cider--debug-goto-keyval (key) + "Find KEY in current sexp or return nil." + (when-let* ((limit (ignore-errors (save-excursion (up-list) (point))))) + (search-forward-regexp (concat "\\_<" (regexp-quote key) "\\_>") + limit 'noerror))) + +(defun cider--debug-skip-ignored-forms () + "Skip past all forms ignored with #_ reader macro." + ;; Logic taken from `clojure--search-comment-macro-internal' + (while (looking-at (concat "[ ,\r\t\n]*" clojure--comment-macro-regexp)) + (let ((md (match-data)) + (start (match-beginning 1))) + (goto-char start) + ;; Count how many #_ we got and step by that many sexps + (clojure-forward-logical-sexp + (count-matches (rx "#_") (elt md 0) (elt md 1)))))) + +(defun cider--debug-move-point (coordinates) + "Place point on after the sexp specified by COORDINATES. +COORDINATES is a list of integers that specify how to navigate into the +sexp that is after point when this function is called. + +As an example, a COORDINATES list of '(1 0 2) means: + - enter next sexp then `forward-sexp' once, + - enter next sexp, + - enter next sexp then `forward-sexp' twice. + +In the following snippet, this takes us to the (* x 2) sexp (point is left +at the end of the given sexp). + + (letfn [(twice [x] + (* x 2))] + (twice 15)) + +In addition to numbers, a coordinate can be a string. This string names the +key of a map, and it means \"go to the value associated with this key\"." + (condition-case-unless-debug nil + ;; Navigate through sexps inside the sexp. + (let ((in-syntax-quote nil)) + (while coordinates + (while (clojure--looking-at-non-logical-sexp) + (forward-sexp)) + ;; An `@x` is read as (deref x), so we pop coordinates once to account + ;; for the extra depth, and move past the @ char. + (if (eq ?@ (char-after)) + (progn (forward-char 1) + (pop coordinates)) + (down-list) + ;; Are we entering a syntax-quote? + (when (looking-back "`\\(#{\\|[{[(]\\)" (line-beginning-position)) + ;; If we are, this affects all nested structures until the next `~', + ;; so we set this variable for all following steps in the loop. + (setq in-syntax-quote t)) + (when in-syntax-quote + ;; A `(. .) is read as (seq (concat (list .) (list .))). This pops + ;; the `seq', since the real coordinates are inside the `concat'. + (pop coordinates) + ;; Non-list seqs like `[] and `{} are read with + ;; an extra (apply vector ...), so pop it too. + (unless (eq ?\( (char-before)) + (pop coordinates))) + ;; #(...) is read as (fn* ([] ...)), so we patch that here. + (when (looking-back "#(" (line-beginning-position)) + (pop coordinates)) + (if coordinates + (let ((next (pop coordinates))) + (when in-syntax-quote + ;; We're inside the `concat' form, but we need to discard the + ;; actual `concat' symbol from the coordinate. + (setq next (1- next))) + ;; String coordinates are map keys. + (if (stringp next) + (cider--debug-goto-keyval next) + (clojure-forward-logical-sexp next) + (when in-syntax-quote + (clojure-forward-logical-sexp 1) + (forward-sexp -1) + ;; Here a syntax-quote is ending. + (let ((match (when (looking-at "~@?") + (match-string 0)))) + (when match + (setq in-syntax-quote nil)) + ;; A `~@' is read as the object itself, so we don't pop + ;; anything. + (unless (equal "~@" match) + ;; Anything else (including a `~') is read as a `list' + ;; form inside the `concat', so we need to pop the list + ;; from the coordinates. + (pop coordinates)))))) + ;; If that extra pop was the last coordinate, this represents the + ;; entire #(...), so we should move back out. + (backward-up-list))) + ;; Finally skip past all #_ forms + (cider--debug-skip-ignored-forms)) + ;; Place point at the end of instrumented sexp. + (clojure-forward-logical-sexp 1)) + ;; Avoid throwing actual errors, since this happens on every breakpoint. + (error (message "Can't find instrumented sexp, did you edit the source?")))) + +(defun cider--debug-position-for-code (code) + "Return non-nil if point is roughly before CODE. +This might move point one line above." + (or (looking-at-p (regexp-quote code)) + (let ((trimmed (regexp-quote (cider--debug-trim-code code)))) + (or (looking-at-p trimmed) + ;; If this is a fake #dbg injected by `C-u + ;; C-M-x', then the sexp we want is actually on + ;; the line above. + (progn (forward-line -1) + (looking-at-p trimmed)))))) + +(defun cider--debug-find-source-position (response &optional create-if-needed) + "Return a marker of the position after the sexp specified in RESPONSE. +This marker might be in a different buffer! If the sexp can't be +found (file that contains the code is no longer visited or has been +edited), return nil. However, if CREATE-IF-NEEDED is non-nil, a new buffer +is created in this situation and the return value is never nil. + +Follow the \"line\" and \"column\" entries in RESPONSE, and check whether +the code at point matches the \"code\" entry in RESPONSE. If it doesn't, +assume that the code in this file has been edited, and create a temp buffer +holding the original code. +Either way, navigate inside the code by following the \"coor\" entry which +is a coordinate measure in sexps." + (nrepl-dbind-response response (code file line column ns original-id coor) + (when (or code (and file line column)) + ;; This is for restoring current-buffer. + (save-excursion + (let ((out)) + ;; We prefer in-source debugging. + (when-let* ((buf (and file line column + (ignore-errors + (cider--find-buffer-for-file file))))) + ;; The logic here makes it hard to use `with-current-buffer'. + (with-current-buffer buf + ;; This is for restoring point inside buf. + (save-excursion + ;; Get to the proper line & column in the file + (forward-line (- line (line-number-at-pos))) + ;; Column numbers in the response start from 1. + ;; Convert to Emacs system which starts from 0 + ;; Inverse of `cider-column-number-at-pos'. + (move-to-column (max 0 (1- column))) + ;; Check if it worked + (when (cider--debug-position-for-code code) + ;; Find the desired sexp. + (cider--debug-move-point coor) + (setq out (point-marker)))))) + ;; But we can create a temp buffer if that fails. + (or out + (when create-if-needed + (cider--initialize-debug-buffer + code ns original-id + (if (and line column) + "you edited the code" + "your nREPL version is older than 0.2.11")) + (save-excursion + (cider--debug-move-point coor) + (point-marker))))))))) + +(defun cider--handle-debug (response) + "Handle debugging notification. +RESPONSE is a message received from the nrepl describing the input +needed. It is expected to contain at least \"key\", \"input-type\", and +\"prompt\", and possibly other entries depending on the input-type." + (nrepl-dbind-response response (debug-value key input-type prompt inspect caught-msg) + (condition-case-unless-debug e + (progn + (pcase input-type + ("expression" (cider-debug-mode-send-reply + (condition-case nil + (cider-read-from-minibuffer + (or prompt "Expression: ")) + (quit "nil")) + key)) + ((pred sequencep) + (let* ((marker (cider--debug-find-source-position response 'create-if-needed))) + (pop-to-buffer (marker-buffer marker)) + (goto-char marker)) + ;; The overlay code relies on window boundaries, but point could have been + ;; moved outside the window by some other code. Redisplay here to ensure the + ;; visible window includes point. + (redisplay) + ;; Remove overlays AFTER redisplaying! Otherwise there's a visible + ;; flicker even if we immediately recreate the overlays. + (cider--debug-remove-overlays) + (when cider-debug-use-overlays + (cider--debug-display-result-overlay debug-value caught-msg)) + (setq cider--debug-mode-response response) + (cider--debug-mode 1))) + (when inspect + (setq cider-inspector--current-repl (cider-current-repl)) + (cider-inspector--render-value inspect))) + ;; If something goes wrong, we send a "quit" or the session hangs. + (error (cider-debug-mode-send-reply ":quit" key) + (message "Error encountered while handling the debug message: %S" e))))) + +(defun cider--handle-enlighten (response) + "Handle an enlighten notification. +RESPONSE is a message received from the nrepl describing the value and +coordinates of a sexp. Create an overlay after the specified sexp +displaying its value." + (when-let* ((marker (cider--debug-find-source-position response))) + (with-current-buffer (marker-buffer marker) + (save-excursion + (goto-char marker) + (clojure-backward-logical-sexp 1) + (nrepl-dbind-response response (debug-value erase-previous) + (when erase-previous + (remove-overlays (point) marker 'category 'enlighten)) + (when debug-value + (if (memq (char-before marker) '(?\) ?\] ?})) + ;; Enlightening a sexp looks like a regular return value, except + ;; for a different border. + (cider--make-result-overlay (cider-font-lock-as-clojure debug-value) + :where (cons marker marker) + :type 'enlighten + :prepend-face 'cider-enlightened-face) + ;; Enlightening a symbol uses a more abbreviated format. The + ;; result face is the same as a regular result, but we also color + ;; the symbol with `cider-enlightened-local-face'. + (cider--make-result-overlay (cider-font-lock-as-clojure debug-value) + :format "%s" + :where (cons (point) marker) + :type 'enlighten + 'face 'cider-enlightened-local-face)))))))) + + +;;; Move here command +;; This is the inverse of `cider--debug-move-point'. However, that algorithm is +;; complicated, and trying to code its inverse would probably be insane. +;; Instead, we find the coordinate by trial and error. +(defun cider--debug-find-coordinates-for-point (target &optional list-so-far) + "Return the coordinates list for reaching TARGET. +Assumes that the next thing after point is a logical Clojure sexp and that +TARGET is inside it. The returned list is suitable for use in +`cider--debug-move-point'. LIST-SO-FAR is for internal use." + (when (looking-at (rx (or "(" "[" "#{" "{"))) + (let ((starting-point (point))) + (unwind-protect + (let ((x 0)) + ;; Keep incrementing the last coordinate until we've moved + ;; past TARGET. + (while (condition-case nil + (progn (goto-char starting-point) + (cider--debug-move-point (append list-so-far (list x))) + (< (point) target)) + ;; Not a valid coordinate. Move back a step and stop here. + (scan-error (setq x (1- x)) + nil)) + (setq x (1+ x))) + (setq list-so-far (append list-so-far (list x))) + ;; We have moved past TARGET, now determine whether we should + ;; stop, or if target is deeper inside the previous sexp. + (if (or (= target (point)) + (progn (forward-sexp -1) + (<= target (point)))) + list-so-far + (goto-char starting-point) + (cider--debug-find-coordinates-for-point target list-so-far))) + ;; `unwind-protect' clause. + (goto-char starting-point))))) + +(defun cider-debug-move-here (&optional force) + "Skip any breakpoints up to point. +The boolean value of FORCE will be sent in the reply." + (interactive (list (cider--uppercase-command-p))) + (unless cider--debug-mode + (user-error "`cider-debug-move-here' only makes sense during a debug session")) + (let ((here (point))) + (nrepl-dbind-response cider--debug-mode-response (line column) + (if (and line column (buffer-file-name)) + (progn ;; Get to the proper line & column in the file + (forward-line (1- (- line (line-number-at-pos)))) + (move-to-column column)) + (beginning-of-defun-raw)) + ;; Is HERE inside the sexp being debugged? + (when (or (< here (point)) + (save-excursion + (clojure-forward-logical-sexp 1) + (> here (point)))) + (user-error "Point is outside the sexp being debugged")) + ;; Move forward until start of sexp. + (comment-normalize-vars t) + (comment-forward (point-max)) + ;; Find the coordinate and send it. + (cider-debug-mode-send-reply + (format "{:response :here, :coord %s :force? %s}" + (cider--debug-find-coordinates-for-point here) + (if force "true" "false")))))) + + +;;; User commands +;;;###autoload +(defun cider-debug-defun-at-point () + "Instrument the \"top-level\" expression at point. +If it is a defn, dispatch the instrumented definition. Otherwise, +immediately evaluate the instrumented expression. + +While debugged code is being evaluated, the user is taken through the +source code and displayed the value of various expressions. At each step, +a number of keys will be prompted to the user." + (interactive) + (cider-eval-defun-at-point 'debug-it)) + +(provide 'cider-debug) +;;; cider-debug.el ends here diff --git a/elpa/cider-20241203.1607/cider-doc.el b/elpa/cider-20241203.1607/cider-doc.el new file mode 100644 index 00000000..addfdeb8 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-doc.el @@ -0,0 +1,583 @@ +;;; cider-doc.el --- CIDER documentation functionality -*- lexical-binding: t -*- + +;; Copyright © 2014-2024 Bozhidar Batsov, Jeff Valk and CIDER contributors + +;; Author: Jeff Valk + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Mode for formatting and presenting documentation + +;;; Code: + +(require 'cider-common) +(require 'cider-docstring) +(require 'subr-x) +(require 'cider-util) +(require 'cider-popup) +(require 'cider-client) +(require 'cider-clojuredocs) +(require 'nrepl-dict) +(require 'button) +(require 'easymenu) +(require 'cider-browse-spec) + +;; we defer loading those, as org-table is a big library +(declare-function org-table-map-tables "org-table") +(declare-function org-table-align "org-table") +(declare-function org-table-begin "org-table") +(declare-function org-table-end "org-table") + + +;;; Variables + +(defgroup cider-doc nil + "Documentation for CIDER." + :prefix "cider-doc-" + :group 'cider) + +(defcustom cider-doc-auto-select-buffer t + "Controls whether to auto-select the doc popup buffer." + :type 'boolean + :group 'cider-doc + :package-version '(cider . "0.15.0")) + +(declare-function cider-apropos "cider-apropos") +(declare-function cider-apropos-select "cider-apropos") +(declare-function cider-apropos-documentation "cider-apropos") +(declare-function cider-apropos-documentation-select "cider-apropos") + +(defvar cider-doc-map + (let (cider-doc-map) + (define-prefix-command 'cider-doc-map) + (define-key cider-doc-map (kbd "a") #'cider-apropos) + (define-key cider-doc-map (kbd "C-a") #'cider-apropos) + (define-key cider-doc-map (kbd "s") #'cider-apropos-select) + (define-key cider-doc-map (kbd "C-s") #'cider-apropos-select) + (define-key cider-doc-map (kbd "f") #'cider-apropos-documentation) + (define-key cider-doc-map (kbd "C-f") #'cider-apropos-documentation) + (define-key cider-doc-map (kbd "e") #'cider-apropos-documentation-select) + (define-key cider-doc-map (kbd "C-e") #'cider-apropos-documentation-select) + (define-key cider-doc-map (kbd "d") #'cider-doc) + (define-key cider-doc-map (kbd "C-d") #'cider-doc) + (define-key cider-doc-map (kbd "c") #'cider-clojuredocs) + (define-key cider-doc-map (kbd "C-c") #'cider-clojuredocs) + (define-key cider-doc-map (kbd "w") #'cider-clojuredocs-web) + (define-key cider-doc-map (kbd "C-w") #'cider-clojuredocs-web) + (define-key cider-doc-map (kbd "j") #'cider-javadoc) + (define-key cider-doc-map (kbd "C-j") #'cider-javadoc) + cider-doc-map) + "CIDER documentation keymap.") + +(defconst cider-doc-menu + '("Documentation" + ["CiderDoc" cider-doc] + ["JavaDoc in browser" cider-javadoc] + "--" + ["Clojuredocs" cider-clojuredocs] + ["Clojuredocs in browser" cider-clojuredocs-web] + ["Refresh ClojureDocs cache" cider-clojuredocs-refresh-cache] + "--" + ["Search symbols" cider-apropos] + ["Search symbols & select" cider-apropos-select] + ["Search documentation" cider-apropos-documentation] + ["Search documentation & select" cider-apropos-documentation-select] + "--" + ["Configure Doc buffer" (customize-group 'cider-docview-mode)]) + "CIDER documentation submenu.") + + +;;; cider-docview-mode + +(defgroup cider-docview-mode nil + "Formatting/fontifying documentation viewer." + :prefix "cider-docview-" + :group 'cider) + +(defcustom cider-docview-fill-column fill-column + "Fill column for docstrings in doc buffer." + :type 'list + :group 'cider-docview-mode + :package-version '(cider . "0.7.0")) + + +;; Faces + +(defface cider-docview-emphasis-face + '((t (:inherit default :underline t))) + "Face for emphasized text." + :group 'cider-docview-mode + :package-version '(cider . "0.7.0")) + +(defface cider-docview-strong-face + '((t (:inherit default :underline t :weight bold))) + "Face for strongly emphasized text." + :group 'cider-docview-mode + :package-version '(cider . "0.7.0")) + +(defface cider-docview-literal-face + '((t (:inherit font-lock-string-face))) + "Face for literal text." + :group 'cider-docview-mode + :package-version '(cider . "0.7.0")) + +(defface cider-docview-table-border-face + '((t (:inherit shadow))) + "Face for table borders." + :group 'cider-docview-mode + :package-version '(cider . "0.7.0")) + + +;; Colors & Theme Support + +(defvar cider-docview-code-background-color + (cider-scale-background-color) + "Background color for code blocks.") + +(advice-add 'enable-theme :after #'cider--docview-adapt-to-theme) +(advice-add 'disable-theme :after #'cider--docview-adapt-to-theme) +(defun cider--docview-adapt-to-theme (&rest _) + "When theme is changed, update `cider-docview-code-background-color'." + (setq cider-docview-code-background-color (cider-scale-background-color))) + +;; Mode & key bindings + +(defvar cider-docview-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "q" #'cider-popup-buffer-quit-function) + (define-key map "g" #'cider-docview-clojuredocs) + (define-key map "G" #'cider-docview-clojuredocs-web) + (define-key map "j" #'cider-docview-javadoc) + (define-key map "s" #'cider-docview-source) + (define-key map (kbd "") #'backward-button) + (define-key map (kbd "TAB") #'forward-button) + (easy-menu-define cider-docview-mode-menu map + "Menu for CIDER's doc mode" + `("CiderDoc" + ["Look up in Clojuredocs" cider-docview-clojuredocs] + ["Look up in Clojuredocs (browser)" cider-docview-clojuredocs-web] + ["JavaDoc in browser" cider-docview-javadoc] + ["Jump to source" cider-docview-source] + "--" + ["Quit" cider-popup-buffer-quit-function] + )) + map)) + +(defvar cider-docview-symbol) +(defvar cider-docview-javadoc-url) +(defvar cider-docview-file) +(defvar cider-docview-line) + +(define-derived-mode cider-docview-mode help-mode "Doc" + "Major mode for displaying CIDER documentation. + +\\{cider-docview-mode-map}" + (setq buffer-read-only t) + (setq-local sesman-system 'CIDER) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t)) + (setq-local electric-indent-chars nil) + (setq-local cider-docview-symbol nil) + (setq-local cider-docview-javadoc-url nil) + (setq-local cider-docview-file nil) + (setq-local cider-docview-line nil)) + + +;;; Interactive functions + +(defun cider-docview-javadoc () + "Open the Javadoc for the current class, if available." + (interactive) + (if cider-docview-javadoc-url + (browse-url cider-docview-javadoc-url) + (error "No Javadoc available for %s" cider-docview-symbol))) + +(defun cider-javadoc-handler (symbol-name) + "Invoke the nREPL \"info\" op on SYMBOL-NAME if available." + (when symbol-name + (let* ((info (cider-var-info symbol-name)) + (url (nrepl-dict-get info "javadoc"))) + (if url + (browse-url url) + (user-error "No Javadoc available for %s" symbol-name))))) + +(defun cider-javadoc (arg) + "Open Javadoc documentation in a popup buffer. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates." + (interactive "P") + (cider-ensure-connected) + (cider-ensure-op-supported "info") + (funcall (cider-prompt-for-symbol-function arg) + "Javadoc for" + #'cider-javadoc-handler)) + +(defun cider-docview-source () + "Open the source for the current symbol, if available." + (interactive) + (if cider-docview-file + (if-let* ((buffer (and (not (cider--tooling-file-p cider-docview-file)) + (cider-find-file cider-docview-file)))) + (cider-jump-to buffer (if cider-docview-line + (cons cider-docview-line nil) + cider-docview-symbol) + nil) + (user-error + (substitute-command-keys + "Can't find the source because it wasn't defined with `cider-eval-buffer'"))) + (error "No source location for %s" cider-docview-symbol))) + +(defvar cider-buffer-ns) + +(declare-function cider-clojuredocs-lookup "cider-clojuredocs") + +(defun cider-docview-clojuredocs () + "Return the clojuredocs documentation for `cider-docview-symbol'." + (interactive) + (if cider-buffer-ns + (cider-clojuredocs-lookup cider-docview-symbol) + (error "%s cannot be looked up on ClojureDocs" cider-docview-symbol))) + +(declare-function cider-clojuredocs-web-lookup "cider-clojuredocs") + +(defun cider-docview-clojuredocs-web () + "Open the clojuredocs documentation for `cider-docview-symbol' in a web browser." + (interactive) + (if cider-buffer-ns + (cider-clojuredocs-web-lookup cider-docview-symbol) + (error "%s cannot be looked up on ClojureDocs" cider-docview-symbol))) + +(defconst cider-doc-buffer "*cider-doc*") + +(defun cider-create-doc-buffer (symbol &optional compact) + "Populates *cider-doc* with the documentation for SYMBOL, +favoring a COMPACT format if specified." + (when-let* ((info (cider-var-info symbol))) + (cider-docview-render (cider-make-popup-buffer cider-doc-buffer nil 'ancillary) symbol info compact))) + +(defun cider-create-compact-doc-buffer (symbol) + "Populates *cider-doc* with the documentation for SYMBOL. + +Favors a compact rendering of docstrings" + (cider-create-doc-buffer symbol :compact)) + +(defun cider-doc-lookup (symbol) + "Look up documentation for SYMBOL." + (if-let* ((buffer (cider-create-doc-buffer symbol))) + (cider-popup-buffer-display buffer cider-doc-auto-select-buffer) + (user-error "Symbol %s not resolved" symbol))) + +(defun cider-doc (&optional arg) + "Open Clojure documentation in a popup buffer. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates." + (interactive "P") + (cider-ensure-connected) + (funcall (cider-prompt-for-symbol-function arg) + "Doc for" + #'cider-doc-lookup)) + + +;;; Font Lock and Formatting + +(defun cider-docview-fontify-code-blocks (buffer mode) + "Font lock BUFFER code blocks using MODE and remove markdown characters. +This processes the triple backtick GFM markdown extension. An overlay is used +to shade the background. Blocks are marked to be ignored by other fonification +and line wrap." + (with-current-buffer buffer + (save-excursion + (while (search-forward-regexp "```\n" nil t) + (replace-match "") + (let ((beg (point)) + (bg `(:background ,cider-docview-code-background-color))) + (when (search-forward-regexp "```\n" nil t) + (replace-match "") + (cider-font-lock-region-as mode beg (point)) + (overlay-put (make-overlay beg (point)) 'font-lock-face bg) + (put-text-property beg (point) 'block 'code))))))) + +(defun cider-docview-fontify-literals (buffer) + "Font lock BUFFER literal text and remove backtick markdown characters. +Preformatted code text blocks are ignored." + (with-current-buffer buffer + (save-excursion + (while (search-forward "`" nil t) + (if (eq (get-text-property (point) 'block) 'code) + (forward-char) + (progn + (replace-match "") + (let ((beg (point))) + (when (search-forward "`" (line-end-position) t) + (replace-match "") + (put-text-property beg (point) 'font-lock-face 'cider-docview-literal-face))))))))) + +(defun cider-docview-fontify-emphasis (buffer) + "Font lock BUFFER emphasized text and remove markdown characters. +One '*' represents emphasis, multiple '**'s represent strong emphasis. +Preformatted code text blocks are ignored." + (with-current-buffer buffer + (save-excursion + (while (search-forward-regexp "\\(*+\\)\\(\\w\\)" nil t) + (if (eq (get-text-property (point) 'block) 'code) + (forward-char) + (progn + (replace-match "\\2") + (let ((beg (1- (point))) + (face (if (> (length (match-string 1)) 1) + 'cider-docview-strong-face + 'cider-docview-emphasis-face))) + (when (search-forward-regexp "\\(\\w\\)\\*+" (line-end-position) t) + (replace-match "\\1") + (put-text-property beg (point) 'font-lock-face face))))))))) + +(defun cider-docview-format-tables (buffer) + "Align BUFFER tables and dim borders. +This processes the GFM table markdown extension using `org-table'. +Tables are marked to be ignored by line wrap." + (require 'org-table) + (with-current-buffer buffer + (save-excursion + (let ((border 'cider-docview-table-border-face)) + (org-table-map-tables + (lambda () + (org-table-align) + (goto-char (org-table-begin)) + (while (search-forward-regexp "[+|-]" (org-table-end) t) + (put-text-property (match-beginning 0) (match-end 0) 'font-lock-face border)) + (put-text-property (org-table-begin) (org-table-end) 'block 'table))))))) + +(defun cider-docview-wrap-text (buffer) + "For text in BUFFER not propertized as 'block', apply line wrap." + (with-current-buffer buffer + (save-excursion + (while (not (eobp)) + (unless (get-text-property (point) 'block) + (fill-region (point) (line-end-position))) + (forward-line))))) + + +;;; Rendering + +(defun cider-docview-render-java-doc (buffer text) + "Emit into BUFFER formatted doc TEXT for a Java class or member." + (with-current-buffer buffer + (let ((beg (point))) + (insert text) + (save-excursion + (goto-char beg) + (cider-docview-fontify-code-blocks buffer 'java-mode) ; left alone hereafter + (cider-docview-fontify-literals buffer) + (cider-docview-fontify-emphasis buffer) + (cider-docview-format-tables buffer) ; may contain literals, emphasis + (cider-docview-wrap-text buffer))))) ; ignores code, table blocks + +(defun cider--abbreviate-file-protocol (file-with-protocol) + "Abbreviate the file-path in `file:/path/to/file' of FILE-WITH-PROTOCOL. + +Same for `jar:file:...!/' segments." + (let ((result (if (string-match "^\\(jar\\|zip\\):\\(file:.+\\)!/\\(.+\\)" file-with-protocol) + (match-string 3 file-with-protocol) + file-with-protocol))) + (if (string-match "\\`file:\\(.*\\)" result) + (let ((file (match-string 1 result)) + (proj-dir (clojure-project-dir))) + (if (and proj-dir + (file-in-directory-p file proj-dir)) + (file-relative-name file proj-dir) + file)) + result))) + +(defun cider-docview-render-info (buffer info &optional compact for-tooltip) + "Emit into BUFFER formatted INFO for the Clojure or Java symbol, +in a COMPACT format is specified, FOR-TOOLTIP if specified." + (let* ((ns (nrepl-dict-get info "ns")) + (name (nrepl-dict-get info "name")) + (added (nrepl-dict-get info "added")) + (depr (nrepl-dict-get info "deprecated")) + (macro (nrepl-dict-get info "macro")) + (special (nrepl-dict-get info "special-form")) + (builtin (nrepl-dict-get info "built-in")) ;; babashka specific + (forms (when-let* ((str (nrepl-dict-get info "forms-str"))) + (split-string str "\n"))) + (args (or (nrepl-dict-get info "annotated-arglists") + (when-let* ((str (nrepl-dict-get info "arglists-str"))) + (split-string str "\n")))) + (rendered-fragments (cider--render-docstring (list "doc-fragments" (unless compact + (nrepl-dict-get info "doc-fragments")) + "doc-block-tags-fragments" (nrepl-dict-get info "doc-block-tags-fragments") + "doc-first-sentence-fragments" (nrepl-dict-get info "doc-first-sentence-fragments")))) + (fetched-doc (nrepl-dict-get info "doc")) + (doc (or rendered-fragments + (if compact + (cider-docstring--trim + (cider-docstring--format fetched-doc)) + fetched-doc) + (unless compact + "Not documented."))) + (url (nrepl-dict-get info "url")) + (class (nrepl-dict-get info "class")) + (member (nrepl-dict-get info "member")) + (javadoc (nrepl-dict-get info "javadoc")) + (super (nrepl-dict-get info "super")) + (ifaces (nrepl-dict-get info "interfaces")) + (spec (nrepl-dict-get info "spec")) + (clj-name (if ns (concat ns "/" name) name)) + (java-name (if member (concat class "/" member) class)) + (see-also (nrepl-dict-get info "see-also"))) + (cider--help-setup-xref (list #'cider-doc-lookup (format "%s/%s" ns name)) nil buffer) + (with-current-buffer buffer + (cl-flet ((emit (text &optional face sep) + (insert (if face + (propertize text 'font-lock-face face) + text) + (or sep "\n")))) + (emit (if class java-name clj-name) 'font-lock-function-name-face) + (when super + (emit (concat "Extends: " (cider-font-lock-as 'java-mode super)))) + (when ifaces + (emit (concat "Implements: " (cider-font-lock-as 'java-mode (car ifaces)))) + ;; choose a separator that will produce correct alignment on monospace and regular fonts: + (let ((sep (if for-tooltip + " " + " "))) + (dolist (iface (cdr ifaces)) + (emit (concat sep (cider-font-lock-as 'java-mode iface)))))) + (when (or super ifaces) + (insert "\n")) + (when-let* ((forms (or forms args)) + (forms (delq nil (mapcar (lambda (f) + (unless (equal f "nil") + f)) + forms)))) + (dolist (form forms) + (emit (cider-font-lock-as-clojure form) + nil)) + (when compact + ;; Compensate for the newlines not `emit`ted in the previous call: + (insert "\n"))) + (when special + (emit "Special Form" 'font-lock-keyword-face)) + (when macro + (emit "Macro" 'font-lock-variable-name-face)) + (when builtin + (emit "Built-in" 'font-lock-keyword-face)) + (when added + (emit (concat "Added in " added) 'font-lock-comment-face)) + (when depr + (emit (concat "Deprecated in " depr) 'font-lock-keyword-face)) + (if (and doc class (not rendered-fragments)) + (cider-docview-render-java-doc (current-buffer) doc) + (when doc + (emit (if rendered-fragments + doc + (concat " " doc))))) + (when url + (insert "\n Please see ") + (insert-text-button url + 'url url + 'follow-link t + 'action (lambda (x) + (browse-url (button-get x 'url)))) + (insert "\n")) + (when (and (not compact) javadoc) + (insert "\n\nFor additional documentation, see the ") + (insert-text-button "Javadoc" + 'url javadoc + 'follow-link t + 'action (lambda (x) + (browse-url (button-get x 'url)))) + (insert ".\n")) + (insert "\n") + (when spec + (emit "Spec:" 'font-lock-function-name-face) + (insert (cider-browse-spec--pprint-indented spec)) + (insert "\n\n") + (insert-text-button "Browse spec" + 'follow-link t + 'action (lambda (_) + (cider-browse-spec (format "%s/%s" ns name)))) + (insert "\n\n")) + (unless compact + (if (and cider-docview-file (not (string= cider-docview-file ""))) + (progn + (insert (propertize (if class java-name clj-name) + 'font-lock-face 'font-lock-function-name-face) + " is defined in ") + (insert-text-button (cider--abbreviate-file-protocol cider-docview-file) + 'follow-link t + 'action (lambda (_x) + (cider-docview-source))) + (insert ".")) + (insert "Definition location unavailable."))) + (when (and (not compact) + see-also) + (insert "\n\n Also see: ") + (mapc (lambda (ns-sym) + (let* ((ns-sym-split (split-string ns-sym "/")) + (see-also-ns (car ns-sym-split)) + (see-also-sym (cadr ns-sym-split)) + ;; if the var belongs to the same namespace, + ;; we omit the namespace to save some screen space + (symbol (if (equal ns see-also-ns) see-also-sym ns-sym))) + (insert-text-button symbol + 'type 'help-xref + 'help-function (apply-partially #'cider-doc-lookup symbol))) + (insert " ")) + see-also)) + (unless compact + (cider--doc-make-xrefs)) + (let ((beg (point-min)) + (end (point-max))) + (nrepl-dict-map (lambda (k v) + (put-text-property beg end k v)) + info))) + (current-buffer)))) + +(declare-function cider-set-buffer-ns "cider-mode") +(defun cider-docview-render (buffer symbol info &optional compact for-tooltip) + "Emit into BUFFER formatted documentation for SYMBOL's INFO, +favoring a COMPACT format if specified, FOR-TOOLTIP if specified." + (with-current-buffer buffer + (let ((javadoc (nrepl-dict-get info "javadoc")) + (file (nrepl-dict-get info "file")) + (line (nrepl-dict-get info "line")) + (ns (nrepl-dict-get info "ns")) + (inhibit-read-only t)) + (cider-docview-mode) + + (cider-set-buffer-ns ns) + (setq-local cider-docview-symbol symbol) + (setq-local cider-docview-javadoc-url javadoc) + (setq-local cider-docview-file file) + (setq-local cider-docview-line line) + + (remove-overlays) + (cider-docview-render-info buffer info compact for-tooltip) + + (goto-char (point-min)) + (current-buffer)))) + + +(provide 'cider-doc) + +;;; cider-doc.el ends here diff --git a/elpa/cider-20241203.1607/cider-docstring.el b/elpa/cider-20241203.1607/cider-docstring.el new file mode 100644 index 00000000..2ff46e1e --- /dev/null +++ b/elpa/cider-20241203.1607/cider-docstring.el @@ -0,0 +1,163 @@ +;;; cider-docstring.el --- Docstring rendering -*- lexical-binding: t -*- + +;; Copyright © 2013-2024 Bozhidar Batsov and CIDER contributors +;; +;; Author: Bozhidar Batsov + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Utilities for rendering a docstring into a shorter, especially-formatted string +;; that will look nice in UIs. + +;;; Code: + +(require 'cl-lib) +(require 'seq) +(require 'shr) +(require 'subr-x) + +(defsubst cider--render-pre* (dom) + "Render DOM nodes, formatting them them as Java if they are strings." + (dolist (sub (dom-children dom)) + (if (stringp sub) + (shr-insert (cider-font-lock-as 'java-mode sub)) + (shr-descend sub)))) + +(defun cider--render-pre (dom) + "Render DOM nodes without folding, a monospaced font, and Java syntax coloring." + (let ((shr-folding-mode 'none) + (shr-current-font 'default)) + (cider--render-pre* dom))) + +(defun cider--string-rstrip-newlines (str) + "Remove newlines at the end of STR." + (if (string-match "\\([\n\r]+\\)$" str) + (replace-match "" nil nil str) + str)) + +(defun cider--html-to-propertized-string (html-string) + "Convert an HTML-STRING into a propertized string using SHR." + (with-temp-buffer + (insert html-string) + (cider--string-rstrip-newlines ;; shr-insert-document adds a final newline. Plain text fragments are responsible for separating fragments if needed.. + (let ((dom (libxml-parse-html-region (point-min) (point-max)))) + (erase-buffer) + (shr-insert-document dom) + (buffer-string))))) + +(defun cider--fragments-to-s (fragments) + "Convert FRAGMENTS into a concatenated string representation. +If a given fragment is of html type, it's converted to a propertized string; +otherwise, it's included as-is." + (when (and fragments + (> (length fragments) + 0)) + (string-trim (cl-reduce (lambda (new-s fragment) + (let* ((html? (equal "html" (nrepl-dict-get fragment "type"))) + (v (nrepl-dict-get fragment "content"))) + (concat new-s (if html? + (let ((shr-use-fonts nil) + (shr-external-rendering-functions '((pre . cider--render-pre)))) + (cider--html-to-propertized-string v)) + v)))) + fragments + :initial-value "")))) + +(defcustom cider-docstring-max-lines 20 + "The maximum number of docstring lines that will be rendered in a UI widget (or the echo area). + +Note that `cider-docstring' will trim thing smartly, for Java doc comments: +* First, the whole doc comment will be attempted to be rendered. +* If that exceeds `cider-docstring-max-lines', + we will use only the first sentence and the block tags + (that is, the params/throws/returns info). +* If that exceeds `cider-docstring-max-lines', we will use only the block tags. +* If that exceeds `cider-docstring-max-lines', we will use only the first sentence." + :type 'integer + :group 'cider + :package-version '(cider . "1.8.0")) + +(defun cider--attempt-invalid? (attempt) + "Check if ATTEMPT is either nil or exceeds `cider-docstring-max-lines' in line count." + (or (not attempt) + (and attempt + (> (length (split-string attempt "\n")) + cider-docstring-max-lines)))) + +(defun cider--render-docstring-first-sentence (eldoc-info) + "Render the first sentence of the docstring extracted from ELDOC-INFO." + (when-let ((first-sentence-fragments (lax-plist-get eldoc-info "doc-first-sentence-fragments"))) + (cider--fragments-to-s first-sentence-fragments))) + +(defun cider--render-docstring (eldoc-info) + "Renders the docstring from ELDOC-INFO based on its length and content. +Prioritize rendering as much as possible while staying within `cider-docstring-max-lines'." + (let* ((first-sentence-fragments (lax-plist-get eldoc-info "doc-first-sentence-fragments")) + (body-fragments (lax-plist-get eldoc-info "doc-fragments")) + (block-tags-fragments (lax-plist-get eldoc-info "doc-block-tags-fragments")) + (block-tags-fragments-rendered (cider--fragments-to-s block-tags-fragments)) + (first-sentence-fragments-rendered) ;; mutable, for performance + (first-attempt (when body-fragments + (concat (cider--fragments-to-s body-fragments) + (when block-tags-fragments + "\n\n") + block-tags-fragments-rendered))) + (first-attempt-invalid? (cider--attempt-invalid? first-attempt)) + (second-attempt (when (and first-sentence-fragments + first-attempt-invalid?) + (setq first-sentence-fragments-rendered (cider--fragments-to-s first-sentence-fragments)) + (concat first-sentence-fragments-rendered + (when block-tags-fragments-rendered + "\n\n") + block-tags-fragments-rendered))) + (second-attempt-invalid? (cider--attempt-invalid? second-attempt)) + (third-attempt (when (and block-tags-fragments-rendered + first-attempt-invalid? + second-attempt-invalid?) + block-tags-fragments-rendered)) + (third-attempt-invalid? (cider--attempt-invalid? third-attempt)) + (last-attempt (when (and first-sentence-fragments-rendered + first-attempt-invalid? + second-attempt-invalid? + third-attempt-invalid?) + first-sentence-fragments-rendered))) + (or last-attempt ;; the last attempt has to go first - it takes priority over an attempt deemed invalid. + third-attempt + second-attempt + first-attempt))) + +(cl-defun cider-docstring--trim (string &optional (max-lines cider-docstring-max-lines)) + "Return MAX-LINES of STRING, adding \"...\" if trimming was necessary." + (when string + (let* ((lines (split-string string "\n")) + (string (string-join (seq-take lines max-lines) "\n"))) + (concat string (when (> (length lines) max-lines) "..."))))) + +(defun cider-docstring--format (string) + "Return a nicely formatted STRING to be displayed to the user. + +We need to format the docstring before displaying it to the user +because it is obtained from the source code. For example, this means +that it usually has two spaces before each line used for indentation +\(see https://guide.clojure.style/#docstring-indentation). While displaying +the docstring to the user, we usually want to control indentation and +other aspects of the presentation, so we format it before displaying." + (replace-regexp-in-string "\n " "\n" string)) + +(provide 'cider-docstring) +;;; cider-docstring.el ends here diff --git a/elpa/cider-20241203.1607/cider-eldoc.el b/elpa/cider-20241203.1607/cider-eldoc.el new file mode 100644 index 00000000..1137046b --- /dev/null +++ b/elpa/cider-20241203.1607/cider-eldoc.el @@ -0,0 +1,525 @@ +;;; cider-eldoc.el --- eldoc support for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2012-2024 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; 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 . + +;; 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 'cider-completion-context) +(require 'cider-docstring) +(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 + "Max 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 (or (cider--render-docstring-first-sentence eldoc-info) + (cider--render-docstring eldoc-info) + (when-let (docstring (lax-plist-get eldoc-info "docstring")) + (cider-docstring--trim + (cider-docstring--format docstring))))) + ;; if it's a single class (and not multiple class candidates), that's it + (maybe-class (car (lax-plist-get eldoc-info "class"))) + (formatted-var (or (when maybe-class + (cider-propertize maybe-class '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-eldoc-format-special-form (thing pos eldoc-info) + "Return the formatted eldoc string for a special-form. +THING is the special form's name. POS is the argument index of the +special-form's arglists. ELDOC-INFO is a p-list containing the eldoc +information." + (let* ((ns (lax-plist-get eldoc-info "ns")) + (special-form-symbol (lax-plist-get eldoc-info "symbol")) + (arglists (mapcar (lambda (arglist) + (if (equal (car arglist) special-form-symbol) + (cdr arglist) + arglist)) + (lax-plist-get eldoc-info "arglists")))) + (format "%s: %s" + (cider-eldoc-format-thing ns special-form-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))) + (clojure-backward-logical-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." + (or (pcase (lax-plist-get eldoc-info "type") + ("function" 'fn) + ("special-form" 'special-form) + ("macro" 'macro) + ("method" 'method) + ("variable" 'var)) + 'fn)) + +(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-point' 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 (as string). +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 nil nil (cider-completion-get-context t)))) + (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 + "class" class + "symbol" name-or-member + "arglists" arglists + "docstring" docstring + "doc-fragments" (nrepl-dict-get eldoc-info "doc-fragments") + "doc-first-sentence-fragments" (nrepl-dict-get eldoc-info + "doc-first-sentence-fragments") + "doc-block-tags-fragments" (nrepl-dict-get eldoc-info + "doc-block-tags-fragments") + "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 + (cond + ((eq (cider-eldoc-thing-type eldoc-info) 'var) + (cider-eldoc-format-variable thing eldoc-info)) + ((eq (cider-eldoc-thing-type eldoc-info) 'special-form) + (cider-eldoc-format-special-form thing pos eldoc-info)) + (t (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 diff --git a/elpa/cider-20241203.1607/cider-eval.el b/elpa/cider-20241203.1607/cider-eval.el new file mode 100644 index 00000000..e5a68c46 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-eval.el @@ -0,0 +1,1689 @@ +;;; cider-eval.el --- Interactive evaluation (compilation) functionality -*- lexical-binding: t -*- + +;; Copyright © 2012-2024 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell +;; Arne Brasseur + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; This file contains CIDER's interactive evaluation (compilation) functionality. +;; Although Clojure doesn't really have the concept of evaluation (only +;; compilation), we're using everywhere in the code the term evaluation for +;; brevity (and to be in line with the naming employed by other similar modes). +;; +;; This files also contains all the logic related to displaying errors and +;; evaluation warnings. +;; +;; Pretty much all of the commands here are meant to be used mostly from +;; `cider-mode', but some of them might make sense in other contexts as well. + +;;; Code: + +(require 'ansi-color) +(require 'cl-lib) +(require 'compile) +(require 'map) +(require 'seq) +(require 'subr-x) + +(require 'clojure-mode) + +(require 'cider-client) +(require 'cider-common) +(require 'cider-jar) +(require 'cider-overlays) +(require 'cider-popup) +(require 'cider-repl) +(require 'cider-stacktrace) +(require 'cider-util) + +(defconst cider-read-eval-buffer "*cider-read-eval*") +(defconst cider-result-buffer "*cider-result*") + +(defcustom cider-show-error-buffer t + "Control the popup behavior of cider stacktraces. +The following values are possible t or 'always, 'except-in-repl, +'only-in-repl. Any other value, including nil, will cause the stacktrace +not to be automatically shown. + +Irrespective of the value of this variable, the `cider-error-buffer' is +always generated in the background. Use `cider-selector' to +navigate to this buffer. + +Please note, if the error phase belongs to +one of the `cider-clojure-compilation-error-phases', +then no stacktrace showing will happen. +That defcustom takes precedence over this one. + +See its doc for understanding its rationale. You can also customize it to nil +in order to void its effect." + :type '(choice (const :tag "always" t) + (const except-in-repl) + (const only-in-repl) + (const :tag "never" nil)) + :group 'cider) + +(defcustom cider-auto-jump-to-error t + "Control the cursor jump behavior in compilation error buffer. +When non-nil automatically jump to error location during interactive +compilation. When set to 'errors-only, don't jump to warnings. +When set to nil, don't jump at all." + :type '(choice (const :tag "always" t) + (const errors-only) + (const :tag "never" nil)) + :group 'cider + :package-version '(cider . "0.7.0")) + +(defcustom cider-auto-select-error-buffer t + "Controls whether to auto-select the error popup buffer." + :type 'boolean + :group 'cider) + +(defcustom cider-auto-track-ns-form-changes t + "Controls whether to auto-evaluate a source buffer's ns form when changed. +When non-nil CIDER will check for ns form changes before each eval command. +When nil the users are expected to take care of the re-evaluating updated +ns forms manually themselves." + :type 'boolean + :group 'cider + :package-version '(cider . "0.15.0")) + +(defcustom cider-auto-inspect-after-eval t + "Controls whether to auto-update the inspector buffer after eval. +Only applies when the *cider-inspect* buffer is currently visible." + :type 'boolean + :group 'cider + :package-version '(cider . "0.25.0")) + +(defcustom cider-save-file-on-load 'prompt + "Controls whether to prompt to save the file when loading a buffer. +If nil, files are not saved. +If 'prompt, the user is prompted to save the file if it's been modified. +If t, save the file without confirmation." + :type '(choice (const prompt :tag "Prompt to save the file if it's been modified") + (const nil :tag "Don't save the file") + (const t :tag "Save the file without confirmation")) + :group 'cider + :package-version '(cider . "0.6.0")) + +(defcustom cider-file-loaded-hook nil + "List of functions to call when a load file has completed." + :type 'hook + :group 'cider + :package-version '(cider . "0.1.7")) + +(defconst cider-output-buffer "*cider-out*") + +(defcustom cider-interactive-eval-output-destination 'repl-buffer + "The destination for stdout and stderr produced from interactive evaluation." + :type '(choice (const output-buffer) + (const repl-buffer)) + :group 'cider + :package-version '(cider . "0.7.0")) + +(defface cider-error-highlight-face + '((((supports :underline (:style wave))) + (:underline (:style wave :color "red") :inherit unspecified)) + (t (:inherit font-lock-warning-face :underline t))) + "Face used to highlight compilation errors in Clojure buffers." + :group 'cider) + +(defface cider-warning-highlight-face + '((((supports :underline (:style wave))) + (:underline (:style wave :color "yellow") :inherit unspecified)) + (t (:inherit font-lock-warning-face :underline (:color "yellow")))) + "Face used to highlight compilation warnings in Clojure buffers." + :group 'cider) + +(defcustom cider-comment-prefix ";; => " + "The prefix to insert before the first line of commented output." + :type 'string + :group 'cider + :package-version '(cider . "0.16.0")) + +(defcustom cider-comment-continued-prefix ";; " + "The prefix to use on the second and subsequent lines of commented output." + :type 'string + :group 'cider + :package-version '(cider . "0.16.0")) + +(defcustom cider-comment-postfix "" + "The postfix to be appended after the final line of commented output." + :type 'string + :group 'cider + :package-version '(cider . "0.16.0")) + +(defcustom cider-eval-register ?e + "The text register assigned to the most recent evaluation result. +When non-nil, the return value of all CIDER eval commands are +automatically written into this register." + :type '(choice character + (const nil)) + :group 'cider + :package-version '(cider . "1.4.0")) + + +;;; Utilities + +(defun cider--clear-compilation-highlights () + "Remove compilation highlights." + (remove-overlays (point-min) (point-max) 'cider-note-p t)) + +(defun cider-clear-compilation-highlights (&optional arg) + "Remove compilation highlights. +When invoked with a prefix ARG the command doesn't prompt for confirmation." + (interactive "P") + (when (or arg (y-or-n-p "Are you sure you want to clear the compilation highlights? ")) + (cider--clear-compilation-highlights))) + +(defun cider--quit-error-window () + "Buries the `cider-error-buffer' and quits its containing window." + (when-let* ((error-win (get-buffer-window cider-error-buffer))) + (save-excursion + (quit-window nil error-win)))) + + +;;; Dealing with compilation (evaluation) errors and warnings +(defun cider-find-property (property &optional backward) + "Find the next text region which has the specified PROPERTY. +If BACKWARD is t, then search backward. +Returns the position at which PROPERTY was found, or nil if not found." + (let ((p (if backward + (previous-single-char-property-change (point) property) + (next-single-char-property-change (point) property)))) + (when (and (not (= p (point-min))) (not (= p (point-max)))) + p))) + +(defun cider-jump-to-compilation-error (&optional _arg _reset) + "Jump to the line causing the current compilation error. +_ARG and _RESET are ignored, as there is only ever one compilation error. +They exist for compatibility with `next-error'." + (interactive) + (cl-labels ((goto-next-note-boundary + () + (let ((p (or (cider-find-property 'cider-note-p) + (cider-find-property 'cider-note-p t)))) + (when p + (goto-char p) + (message "%s" (get-char-property p 'cider-note)))))) + ;; if we're already on a compilation error, first jump to the end of + ;; it, so that we find the next error. + (when (get-char-property (point) 'cider-note-p) + (goto-next-note-boundary)) + (goto-next-note-boundary))) + +(defun cider--show-error-buffer-p () + "Return non-nil if the error buffer must be shown on error. +Takes into account both the value of `cider-show-error-buffer' and the +currently selected buffer." + (let* ((selected-buffer (window-buffer (selected-window))) + (replp (with-current-buffer selected-buffer (derived-mode-p 'cider-repl-mode)))) + (memq cider-show-error-buffer + (if replp + '(t always only-in-repl) + '(t always except-in-repl))))) + +(defun cider-new-error-buffer (&optional mode error-types) + "Return an empty error buffer using MODE. + +When deciding whether to display the buffer, takes into account not only +the value of `cider-show-error-buffer' and the currently selected buffer +but also the ERROR-TYPES of the error, which is checked against the +`cider-stacktrace-suppressed-errors' set. + +When deciding whether to select the buffer, takes into account the value of +`cider-auto-select-error-buffer'." + (if (and (cider--show-error-buffer-p) + (not (cider-stacktrace-some-suppressed-errors-p error-types))) + (cider-popup-buffer cider-error-buffer cider-auto-select-error-buffer mode 'ancillary) + (cider-make-popup-buffer cider-error-buffer mode 'ancillary))) + +(defun cider-emit-into-color-buffer (buffer value) + "Emit into color BUFFER the provided VALUE." + (with-current-buffer buffer + (let ((inhibit-read-only t) + (buffer-undo-list t)) + (goto-char (point-max)) + (insert (format "%s" value)) + (ansi-color-apply-on-region (point-min) (point-max))) + (goto-char (point-min)))) + +(defun cider--handle-err-eval-response (response) + "Render eval RESPONSE into a new error buffer. + +Uses the value of the `out' slot in RESPONSE." + (nrepl-dbind-response response (out) + (when out + (let ((error-buffer (cider-new-error-buffer))) + (cider-emit-into-color-buffer error-buffer out) + (with-current-buffer error-buffer + (compilation-minor-mode +1)))))) + +(defun cider-default-err-eval-handler () + "Display the last exception without middleware support." + (cider--handle-err-eval-response + (cider-nrepl-sync-request:eval + "(clojure.stacktrace/print-cause-trace *e)"))) + +(defun cider-default-err-eval-print-handler () + "Display the last exception without middleware support. +When clojure.stracktrace is not present." + (cider--handle-err-eval-response + (cider-nrepl-sync-request:eval + "(println (ex-data *e))"))) + +(defun cider--render-stacktrace-causes (causes &optional error-types) + "If CAUSES is non-nil, render its contents into a new error buffer. +Optional argument ERROR-TYPES contains a list which should determine the +op/situation that originated this error." + (when causes + (let ((error-buffer (cider-new-error-buffer #'cider-stacktrace-mode error-types))) + (cider-stacktrace-render error-buffer (reverse causes) error-types)))) + +(defconst cider-clojure-compilation-error-phases-default-value + '("read-source" + "macro-syntax-check" + "macroexpansion" + "compile-syntax-check" + "compilation" + ;; "execution" is certainly not to be included here. + ;; "read-eval-result" and "print-eval-result" are not to be included here, + ;; because they mean that the code has been successfully executed. + )) + +(defcustom cider-clojure-compilation-error-phases cider-clojure-compilation-error-phases-default-value + "Error phases which will not cause the `*cider-error*' buffer to pop up. + +The default value results in no stacktrace being shown for compile-time errors. + +Note that `*cider-error*' pop behavior is otherwise controlled +by the `cider-show-error-buffer' defcustom. + +`cider-clojure-compilation-error-phases' takes precedence. +If you wish phases to be ignored, set this variable to nil instead. + +You can learn more about Clojure's error phases at: +https://clojure.org/reference/repl_and_main#_at_repl" + :type 'list + :group 'cider + :package-version '(cider . "0.18.0")) + +(defun cider-clojure-compilation-error-phases () + "Get the normalized value of the `cider-clojure-compilation-error-phases' var." + (if (equal t cider-clojure-compilation-error-phases) + cider-clojure-compilation-error-phases-default-value + cider-clojure-compilation-error-phases)) + +(defun cider--handle-stacktrace-response (response causes ex-phase) + "Handle stacktrace RESPONSE, aggregate the result into CAUSES, honor EX-PHASE. +If RESPONSE contains a cause, cons it onto CAUSES and return that. If +RESPONSE is the final message (i.e. it contains a status), render CAUSES +into a new error buffer." + (nrepl-dbind-response response (class msg status type) + (cond ((and (member "notification" status) causes) + (nrepl-notify msg type)) + (class (cons response causes)) + (status + (unless (member ex-phase (cider-clojure-compilation-error-phases)) + (cider--render-stacktrace-causes causes)))))) + +(defun cider-default-err-op-handler () + "Display the last exception, with middleware support." + ;; Causes are returned as a series of messages, which we aggregate in `causes' + (let (causes ex-phase) + (cider-nrepl-send-request + (thread-last + (map-merge 'list + '(("op" "analyze-last-stacktrace")) + (cider--nrepl-print-request-map fill-column)) + (seq-mapcat #'identity)) + (lambda (response) + (nrepl-dbind-response response (phase) + (when phase + (setq ex-phase phase))) + ;; While the return value of `cider--handle-stacktrace-response' is not + ;; meaningful for the last message, we do not need the value of `causes' + ;; after it has been handled, so it's fine to set it unconditionally here + (setq causes (cider--handle-stacktrace-response response causes ex-phase)))))) + +(defun cider-default-err-handler () + "This function determines how the error buffer is shown. +It delegates the actual error content to the eval or op handler." + (cond ((cider-nrepl-op-supported-p "analyze-last-stacktrace") + (cider-default-err-op-handler)) + ((cider-library-present-p "clojure.stacktrace") + (cider-default-err-eval-handler)) + (t (cider-default-err-eval-print-handler)))) + +;; Reference: +;; https://github.com/clojure/clojure/blob/clojure-1.10.0/src/clj/clojure/main.clj#L251 +;; See `cider-compilation-regexp' for interpretation of match groups. +(defconst cider--clojure-1.10-location + '(sequence + "at " (minimal-match (zero-or-more anything)) ;; the fully-qualified name of the function that triggered the error + "(" + (group-n 2 (minimal-match (zero-or-more anything))) ; source file + ":" (group-n 3 (one-or-more (any "-" digit))) ; line number, may be negative (#3687) + (optional + ":" (group-n 4 (one-or-more (any "-" digit)))) ; column number + ").")) + +(defconst cider--clojure-1.10-error + `(sequence + (or "Syntax error reading source " ; phase = :read-source + (sequence + (or "Syntax error " "Unexpected error ") + (minimal-match (zero-or-more anything)) ; optional class, eg. (ClassCastException) + (or "macroexpanding " ; phase = :macro-syntax-check / :macroexpansion + "compiling ") ; phase = :compile-syntax-check / :compilation + (minimal-match (zero-or-more anything)))) ; optional symbol, eg. foo/bar + ,cider--clojure-1.10-location) + "Regexp matching error messages triggered in compilation / read / print phases.") + +(defconst cider--clojure-warning + `(sequence + (minimal-match (zero-or-more anything)) + (group-n 1 "warning") + ", " (group-n 2 (minimal-match (zero-or-more anything))) + ":" (group-n 3 (one-or-more (any "-" digit))) + (optional + ":" (group-n 4 (one-or-more (any "-" digit)))) + " - ") + "Regexp matching various non-error messages, e.g. reflection warnings.") + +;; Please keep this in sync with `cider-clojure-compilation-error-regexp', +;; which is a subset of these regexes. +(defconst cider-clojure-compilation-regexp + (rx-to-string + `(seq bol (or ,cider--clojure-warning + ,cider--clojure-1.10-error)) + 'nogroup) + "A few example values that will match: +\"Reflection warning, /tmp/foo/src/foo/core.clj:14:1 - \" +\"Syntax error compiling at (src/workspace_service.clj:227:3).\" +\"Unexpected error (ClassCastException) macroexpanding defmulti at (src/haystack/parser.cljc:21:1).\"") + +(defconst cider-clojure-compilation-error-regexp + (rx-to-string + `(seq bol ,cider--clojure-1.10-error) + 'nogroup) + "Like `cider-clojure-compilation-regexp', +but excluding warnings such as reflection warnings. + +A few example values that will match: +\"Syntax error compiling at (src/workspace_service.clj:227:3).\" +\"Unexpected error (ClassCastException) macroexpanding defmulti at (src/haystack/parser.cljc:21:1).\"") + +(defconst cider--clojure-execution-error + `(sequence + (or "Error reading eval result " ; phase = :read-eval-result + "Error printing return value " ; phase = :print-eval-result + "Execution error ") ; phase = :execution + (minimal-match (zero-or-more anything)) ; optional class, eg. (ArithmeticException) + ,cider--clojure-1.10-location)) + +(defconst cider--clojure-spec-execution-error + `(sequence + "Execution error - invalid arguments to " + (minimal-match (one-or-more anything)) + " " + ,cider--clojure-1.10-location)) + +(defconst cider-clojure-runtime-error-regexp + (rx-to-string + `(seq bol (or ,cider--clojure-execution-error + ,cider--clojure-spec-execution-error)) + 'nogroup) + "Matches runtime errors, as oppsed to compile-time/macroexpansion-time errors. + +A few example values that will match: + +\"Execution error (ArithmeticException) at foo/foo (src/haystack/parser.cljc:4).\" +\"Execution error - invalid arguments to foo/bar at (src/haystack/parser.cljc:4).\"") + +(defconst cider-module-info-regexp + (rx " (" + (minimal-match (one-or-more anything)) + " is in" + (minimal-match (one-or-more anything)) ;; module or unnamed module + " of loader " + (minimal-match (one-or-more anything)) + "; " + (minimal-match (one-or-more anything)) + " is in " + (minimal-match (one-or-more anything)) ;; module or unnamed module + " of loader " + (minimal-match (one-or-more anything)) + ")")) + +(defvar cider-compilation-regexp + (list cider-clojure-compilation-regexp + 2 ; FILE + 3 ; LINE + 4 ; COLUMN + '(1)) ; TYPE = (WARNING . INFO) + "Specifications for matching errors and warnings in Clojure stacktraces. +See `compilation-error-regexp-alist' for help on their format.") + +(add-to-list 'compilation-error-regexp-alist-alist + (cons 'cider cider-compilation-regexp)) +(add-to-list 'compilation-error-regexp-alist 'cider) + +(defun cider-extract-error-info (regexp message) + "Extract error information with REGEXP against MESSAGE." + (let ((file (nth 1 regexp)) + (line (nth 2 regexp)) + (col (nth 3 regexp)) + (type (nth 4 regexp)) + (pat (car regexp))) + (when (string-match pat message) + ;; special processing for type (1.2) style + (setq type (if (consp type) + (or (and (car type) (match-end (car type)) 1) + (and (cdr type) (match-end (cdr type)) 0) + 2))) + (list + (when file + (let ((val (match-string-no-properties file message))) + (unless (or (string= val "REPL") (string= val "NO_SOURCE_PATH")) val))) + (when line (string-to-number (match-string-no-properties line message))) + (when col + (let ((val (match-string-no-properties col message))) + (when (and val (not (string-blank-p val))) (string-to-number val)))) + (aref [cider-warning-highlight-face + cider-warning-highlight-face + cider-error-highlight-face] + (or type 2)) + message)))) + +(defun cider--goto-expression-start () + "Go to the beginning a list, vector, map or set outside of a string. +We do so by starting and the current position and proceeding backwards +until we find a delimiters that's not inside a string." + (if (and (looking-back "[])}]" (line-beginning-position)) + (null (nth 3 (syntax-ppss)))) + (backward-sexp) + (while (or (not (looking-at-p "[({[]")) + (nth 3 (syntax-ppss))) + (backward-char)))) + +(defun cider--find-last-error-location (message) + "Return the location (begin end buffer) from the Clojure error MESSAGE. +If location could not be found, return nil." + (save-excursion + (let ((info (cider-extract-error-info cider-compilation-regexp message))) + (when info + (let ((file (nth 0 info)) + (line (nth 1 info)) + (col (nth 2 info))) + (unless (or (not (stringp file)) + (cider--tooling-file-p file)) + (when-let* ((buffer (cider-find-file file))) + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- line)) + (move-to-column (or col 0)) + ;; if this condition is false, it means that `col` was a spuriously large value, + ;; therefore the whole calculation should be discarded: + (when (or (not col) ;; if there's no col info, we cannot judge if it's spurious/not + ;; (current-column) never goes past the last column in the actual line, + ;; so if it's <, then the message had spurious info: + (>= (1+ (current-column)) + col)) + (let ((begin (progn (if col (cider--goto-expression-start) (back-to-indentation)) + (point))) + (end (progn (if col (forward-list) (move-end-of-line nil)) + (point)))) + (list begin end buffer))))))))))))) + +(defun cider-handle-compilation-errors (message eval-buffer &optional no-jump) + "Highlight and jump to compilation error extracted from MESSAGE, honor NO-JUMP. +EVAL-BUFFER is the buffer that was current during user's interactive +evaluation command. Honor `cider-auto-jump-to-error'." + (when-let* ((loc (cider--find-last-error-location message)) + (overlay (make-overlay (nth 0 loc) (nth 1 loc) (nth 2 loc))) + (info (cider-extract-error-info cider-compilation-regexp message))) + (let* ((face (nth 3 info)) + (note (nth 4 info)) + (auto-jump (unless no-jump + (if (eq cider-auto-jump-to-error 'errors-only) + (not (or (eq face 'cider-warning-highlight-face) + (string-match-p "warning" note))) + cider-auto-jump-to-error)))) + (overlay-put overlay 'cider-note-p t) + (overlay-put overlay 'font-lock-face face) + (overlay-put overlay 'cider-note note) + (overlay-put overlay 'help-echo note) + (overlay-put overlay 'modification-hooks + (list (lambda (o &rest _args) (delete-overlay o)))) + (when auto-jump + (with-current-buffer eval-buffer + (push-mark) + ;; At this stage selected window commonly is *cider-error* and we need to + ;; re-select the original user window. If eval-buffer is not + ;; visible it was probably covered as a result of a small screen or user + ;; configuration (https://github.com/clojure-emacs/cider/issues/847). In + ;; that case we don't jump at all in order to avoid covering *cider-error* + ;; buffer. + (when-let* ((win (get-buffer-window eval-buffer))) + (with-selected-window win + (cider-jump-to (nth 2 loc) (car loc))))))))) + + +;;; Interactive evaluation handlers +(defun cider-insert-eval-handler (&optional buffer bounds source-buffer on-success-callback) + "Make an nREPL evaluation handler for the BUFFER, +BOUNDS representing the buffer bounds of the evaled input, +SOURCE-BUFFER the original buffer, +and ON-SUCCESS-CALLBACK an optional callback. + +The handler simply inserts the result value in BUFFER." + (let ((eval-buffer (current-buffer)) + (res "") + (failed nil) + (error-phase-requested nil)) ;; avoid requesting the phase more than once - can happen if there are errors during the phase nrepl sync request. + (nrepl-make-response-handler (or buffer eval-buffer) + ;; value handler: + (lambda (_buffer value) + (with-current-buffer buffer + (insert value)) + (when cider-eval-register + (setq res (concat res value)))) + ;; stdout handler: + (lambda (_buffer out) + (cider-repl-emit-interactive-stdout out)) + ;; stderr handler: + (lambda (_buffer err) + (setq failed t) + (when (and source-buffer + (listp bounds)) ;; if it's a list, it represents bounds, otherwise it's a string (code) and we can't display the overlay + (with-current-buffer source-buffer + (let* ((phase (if error-phase-requested + nil + (setq error-phase-requested t) + (cider--error-phase-of-last-exception buffer))) + (end (or (car-safe (cdr-safe bounds)) bounds)) + (end (when end + (copy-marker end)))) + (cider--maybe-display-error-as-overlay phase err end)))) + + (cider-handle-compilation-errors err eval-buffer)) + ;; done handler: + (lambda (_buffer) + (when cider-eval-register + (set-register cider-eval-register res)) + (when (and (not failed) + on-success-callback) + (funcall on-success-callback)))))) + +(defun cider--emit-interactive-eval-output (output repl-emit-function) + "Emit output resulting from interactive code evaluation. +The OUTPUT can be sent to either a dedicated output buffer or the current +REPL buffer. This is controlled by `cider-interactive-eval-output-destination'. +REPL-EMIT-FUNCTION emits the OUTPUT." + (pcase cider-interactive-eval-output-destination + (`output-buffer (let ((output-buffer (or (get-buffer cider-output-buffer) + (cider-popup-buffer cider-output-buffer t)))) + (cider-emit-into-popup-buffer output-buffer output) + (pop-to-buffer output-buffer))) + (`repl-buffer (funcall repl-emit-function output)) + (_ (error "Unsupported value %s for `cider-interactive-eval-output-destination'" + cider-interactive-eval-output-destination)))) + +(defun cider-emit-interactive-eval-output (output) + "Emit OUTPUT resulting from interactive code evaluation. +The output can be send to either a dedicated output buffer or the current +REPL buffer. This is controlled via +`cider-interactive-eval-output-destination'." + (cider--emit-interactive-eval-output output 'cider-repl-emit-interactive-stdout)) + +(defun cider-emit-interactive-eval-err-output (output) + "Emit err OUTPUT resulting from interactive code evaluation. +The output can be send to either a dedicated output buffer or the current +REPL buffer. This is controlled via +`cider-interactive-eval-output-destination'." + (cider--emit-interactive-eval-output output 'cider-repl-emit-interactive-stderr)) + +(defun cider--make-fringe-overlays-for-region (beg end) + "Place eval indicators on all sexps between BEG and END." + (with-current-buffer (if (markerp end) + (marker-buffer end) + (current-buffer)) + (save-excursion + (goto-char beg) + (remove-overlays beg end 'category 'cider-fringe-indicator) + (condition-case nil + (while (progn (clojure-forward-logical-sexp) + (and (<= (point) end) + (not (eobp)))) + (cider--make-fringe-overlay (point))) + (scan-error nil))))) + +(defun cider--error-phase-of-last-exception (buffer) + "Returns the :phase of the latest exception associated to BUFFER, if any." + (when (cider-clojure-compilation-error-phases) + (when-let ((conn (with-current-buffer buffer + (cider-current-repl)))) + (when (cider-nrepl-op-supported-p "analyze-last-stacktrace" conn) + (let ((nrepl-sync-request-timeout 4)) ;; ensure that this feature cannot possibly create an overly laggy UX + (when-let* ((result (nrepl-send-sync-request (thread-last (map-merge 'list + '(("op" "analyze-last-stacktrace")) + (cider--nrepl-print-request-map fill-column)) + (seq-mapcat #'identity)) + conn + 'abort-on-input ;; favor responsiveness over this feature, in case something went wrong. + ))) + (nrepl-dict-get result "phase"))))))) + +(defcustom cider-inline-error-message-function #'cider--shorten-error-message + "A function that will shorten a given error message, +as shown in overlays / the minibuffer (per `cider-use-overlays'). + +The function takes a single arg. You may want to use `identity', +for leaving the message as-is." + :type 'boolean + :group 'cider + :package-version '(cider . "1.19.0")) + +(defun cider--shorten-error-message (err) + "Removes from ERR the prefix matched by `cider-clojure-compilation-regexp', +and the suffix matched by `cider-module-info-regexp'." + (thread-last err + (replace-regexp-in-string cider-clojure-compilation-regexp + "") + (replace-regexp-in-string cider-module-info-regexp + "") + (string-trim))) + +(defun cider--maybe-display-error-as-overlay (phase err end) + "Possibly display ERR as an overlay honoring END, +depending on the PHASE." + (when (and (or + ;; if we won't show *cider-error*, because of configuration, the overlay is adequate because it compensates for the lack of info in a compact manner: + (not cider-show-error-buffer) + (not (cider-connection-has-capability-p 'jvm-compilation-errors)) + ;; if we won't show *cider-error*, because of an ignored phase, the overlay is adequate: + (and cider-show-error-buffer + (member phase (cider-clojure-compilation-error-phases)))) + ;; Only show overlays for things that do look like an exception (#3587): + ;; Note: only applicable to JVM Clojure error messages (#3687) + (if (cider-runtime-clojure-p) + (or (string-match-p cider-clojure-runtime-error-regexp err) + (string-match-p cider-clojure-compilation-error-regexp err)) + t)) + ;; Display errors as temporary overlays + (let ((cider-result-use-clojure-font-lock nil) + (trimmed-err (funcall cider-inline-error-message-function err))) + (cider--display-interactive-eval-result trimmed-err + 'error + end + 'cider-error-overlay-face)))) + +(declare-function cider-inspect-last-result "cider-inspector") +(defun cider-interactive-eval-handler (&optional buffer place) + "Make an interactive eval handler for BUFFER. +PLACE is used to display the evaluation result. +If non-nil, it can be the position where the evaluated sexp ends, +or it can be a list with (START END) of the evaluated region. +Update the cider-inspector buffer with the evaluation result +when `cider-auto-inspect-after-eval' is non-nil." + + (let* ((eval-buffer (current-buffer)) + (beg (car-safe place)) + (end (or (car-safe (cdr-safe place)) place)) + (beg (when beg (copy-marker beg))) + (end (when end (copy-marker end))) + (fringed nil) + (res "") + (error-phase-requested nil)) ;; avoid requesting the phase more than once - can happen if there are errors during the phase nrepl sync request. + (nrepl-make-response-handler (or buffer eval-buffer) + ;; value handler: + (lambda (_buffer value) + (setq res (concat res value)) + (cider--display-interactive-eval-result res 'value end)) + ;; stdout handler: + (lambda (_buffer out) + (cider-emit-interactive-eval-output out)) + ;; stderr handler: + (lambda (buffer err) + (cider-emit-interactive-eval-err-output err) + + (let ((phase (if error-phase-requested + nil + (setq error-phase-requested t) + (cider--error-phase-of-last-exception buffer)))) + + (cider--maybe-display-error-as-overlay phase err end) + + (cider-handle-compilation-errors err + eval-buffer + ;; we prevent jumping behavior on compilation errors, + ;; because lines tend to be spurious (e.g. 0:0) + ;; and because on compilation errors, normally + ;; the error is 'right there' in the current line + ;; and needs no jumping: + phase))) + ;; done handler: + (lambda (buffer) + (if beg + (unless fringed + (cider--make-fringe-overlays-for-region beg end) + (setq fringed t)) + (cider--make-fringe-overlay end)) + (when (and cider-auto-inspect-after-eval + (boundp 'cider-inspector-buffer) + (windowp (get-buffer-window cider-inspector-buffer 'visible))) + (cider-inspect-last-result) + (select-window (get-buffer-window buffer))) + (when cider-eval-register + (set-register cider-eval-register res)))))) + + +(defun cider-load-file-handler (&optional buffer done-handler) + "Make a load file handler for BUFFER. +Optional argument DONE-HANDLER lambda will be run once load is complete." + (let ((eval-buffer (current-buffer)) + (res "") + (error-phase-requested nil)) ;; avoid requesting the phase more than once - can happen if there are errors during the phase nrepl sync request. + (nrepl-make-response-handler (or buffer eval-buffer) + (lambda (buffer value) + (cider--display-interactive-eval-result value 'value) + (when cider-eval-register + (setq res (concat res value))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (cider--make-fringe-overlays-for-region (point-min) (point-max)) + (run-hooks 'cider-file-loaded-hook)))) + (lambda (_buffer value) + (cider-emit-interactive-eval-output value)) + (lambda (_buffer err) + (cider-emit-interactive-eval-err-output err) + ;; 1.- Jump to the error line: + (cider-handle-compilation-errors err eval-buffer) + (with-current-buffer eval-buffer + (let* ((phase (if error-phase-requested + nil + (setq error-phase-requested t) + (cider--error-phase-of-last-exception buffer))) + ;; 2.- Calculate the overlay position, which is the point (per the previous jump), + ;; and then end-of-line (for ensuring the overlay will be rendered properly): + (end (save-excursion + (when (equal cider-result-overlay-position 'at-eol) + (end-of-line)) + (point)))) + (cider--maybe-display-error-as-overlay phase err end)))) + (lambda (buffer) + (when cider-eval-register + (set-register cider-eval-register res)) + (when done-handler + (funcall done-handler buffer))) + (lambda () + (funcall nrepl-err-handler))))) + +(defun cider-eval-print-handler (&optional buffer) + "Make a handler for evaluating and printing result in BUFFER." + ;; NOTE: cider-eval-register behavior is not implemented here for performance reasons. + ;; See https://github.com/clojure-emacs/cider/pull/3162 + (nrepl-make-response-handler (or buffer (current-buffer)) + (lambda (buffer value) + (with-current-buffer buffer + (insert + (if (derived-mode-p 'cider-clojure-interaction-mode) + (format "\n%s\n" value) + value)))) + (lambda (_buffer out) + (cider-emit-interactive-eval-output out)) + (lambda (_buffer err) + (cider-emit-interactive-eval-err-output err)) + ())) + +(defun cider-eval-print-with-comment-handler (buffer location comment-prefix) + "Make a handler for evaluating and printing commented results in BUFFER. +LOCATION is the location marker at which to insert. COMMENT-PREFIX is the +comment prefix to use." + (let ((res "")) + (nrepl-make-response-handler buffer + (lambda (_buffer value) + (setq res (concat res value))) + (lambda (_buffer out) + (cider-emit-interactive-eval-output out)) + (lambda (_buffer err) + (cider-emit-interactive-eval-err-output err)) + (lambda (buffer) + (with-current-buffer buffer + (save-excursion + (goto-char (marker-position location)) + (insert (concat comment-prefix + res "\n")))) + (when cider-eval-register + (set-register cider-eval-register res)))))) + +(defun cider-maybe-insert-multiline-comment (result comment-prefix continued-prefix comment-postfix) + "Insert eval RESULT at current location if RESULT is not empty. +RESULT will be preceded by COMMENT-PREFIX. +CONTINUED-PREFIX is inserted for each additional line of output. +COMMENT-POSTFIX is inserted after final text output." + (unless (string= result "") + (clojure-indent-line) + (let ((lines (split-string result "[\n]+" t)) + (beg (point)) + (col (current-indentation))) + ;; only the first line gets the normal comment-prefix + (insert (concat comment-prefix (pop lines))) + (dolist (elem lines) + (insert (concat "\n" continued-prefix elem))) + (indent-rigidly beg (point) col) + (unless (string= comment-postfix "") + (insert comment-postfix))))) + +(defun cider-eval-pprint-with-multiline-comment-handler (buffer location comment-prefix continued-prefix comment-postfix) + "Make a handler for evaluating and inserting results in BUFFER. +The inserted text is pretty-printed and region will be commented. +LOCATION is the location marker at which to insert. +COMMENT-PREFIX is the comment prefix for the first line of output. +CONTINUED-PREFIX is the comment prefix to use for the remaining lines. +COMMENT-POSTFIX is the text to output after the last line." + (let ((res "")) + (nrepl-make-response-handler + buffer + (lambda (_buffer value) + (setq res (concat res value))) + nil + (lambda (_buffer err) + (setq res (concat res err))) + (lambda (buffer) + (with-current-buffer buffer + (save-excursion + (goto-char (marker-position location)) + ;; edge case: defun at eob + (unless (bolp) (insert "\n")) + (cider-maybe-insert-multiline-comment res comment-prefix continued-prefix comment-postfix))) + (when cider-eval-register + (set-register cider-eval-register res))) + nil + nil + (lambda (_buffer warning) + (setq res (concat res warning)))))) + +(defun cider-popup-eval-handler (&optional buffer bounds source-buffer) + "Make a handler for printing evaluation results in popup BUFFER, +BOUNDS representing the buffer bounds of the evaled input, +and SOURCE-BUFFER the original buffer + +This is used by pretty-printing commands." + ;; NOTE: cider-eval-register behavior is not implemented here for performance reasons. + ;; See https://github.com/clojure-emacs/cider/pull/3162 + (let ((chosen-buffer (or buffer (current-buffer))) + (error-phase-requested nil)) ;; avoid requesting the phase more than once - can happen if there are errors during the phase nrepl sync request. + (nrepl-make-response-handler + chosen-buffer + ;; value handler: + (lambda (buffer value) + (cider-emit-into-popup-buffer buffer (ansi-color-apply value) nil t)) + ;; stdout handler: + (lambda (_buffer out) + (cider-emit-interactive-eval-output out)) + ;; stderr handler: + (lambda (buffer err) + (cider-emit-interactive-eval-err-output err) + (when (and source-buffer + (listp bounds)) ;; if it's a list, it represents bounds, otherwise it's a string (code) and we can't display the overlay + (with-current-buffer source-buffer + (let* ((phase (if error-phase-requested + nil + (setq error-phase-requested t) + (cider--error-phase-of-last-exception buffer))) + (end (or (car-safe (cdr-safe bounds)) bounds)) + (end (when end + (copy-marker end)))) + (cider--maybe-display-error-as-overlay phase err end))))) + ;; done handler: + nil + ;; eval-error handler: + (lambda () + (when (and (buffer-live-p chosen-buffer) + (member (buffer-name chosen-buffer) + cider-ancillary-buffers)) + (with-selected-window (get-buffer-window chosen-buffer) + (cider-popup-buffer-quit-function t))) + ;; also call the default nrepl-err-handler, so that our custom behavior doesn't void the base behavior: + (when nrepl-err-handler + (funcall nrepl-err-handler))) + ;; content type handler: + nil + ;; truncated handler: + (lambda (buffer warning) + (cider-emit-into-popup-buffer buffer warning 'font-lock-warning-face t))))) + + +;;; Interactive valuation commands + +(defvar cider-to-nrepl-filename-function + (with-no-warnings + (lambda (path) + (let ((path* (if (eq system-type 'cygwin) + (cygwin-convert-file-name-to-windows path) + path))) + (or (cider--translate-path-to-nrepl path*) path*)))) + "Function to translate Emacs filenames to nREPL namestrings.") + +(defun cider--prep-interactive-eval (form connection) + "Prepare the environment for an interactive eval of FORM in CONNECTION. +Ensure the current ns declaration has been evaluated (so that the ns +containing FORM exists). Cache ns-form in the current buffer unless FORM is +ns declaration itself. Clear any compilation highlights and kill the error +window." + (cider--clear-compilation-highlights) + (cider--quit-error-window) + (let ((cur-ns-form (cider-ns-form))) + (when (and cur-ns-form + (not (cider-ns-form-p form)) + (cider-repl--ns-form-changed-p cur-ns-form connection)) + (when cider-auto-track-ns-form-changes + ;; The first interactive eval on a file can load a lot of libs. This can + ;; easily lead to more than 10 sec. + (let ((nrepl-sync-request-timeout 30)) + ;; TODO: check for evaluation errors + (cider-nrepl-sync-request:eval cur-ns-form connection))) + ;; cache at the end, in case of errors + (cider-repl--cache-ns-form cur-ns-form connection)))) + +(defvar-local cider-interactive-eval-override nil + "Function to call instead of `cider-interactive-eval'.") + +(defun cider-interactive-eval (form &optional callback bounds additional-params) + "Evaluate FORM and dispatch the response to CALLBACK. +If the code to be evaluated comes from a buffer, it is preferred to use a +nil FORM, and specify the code via the BOUNDS argument instead. + +This function is the main entry point in CIDER's interactive evaluation +API. Most other interactive eval functions should rely on this function. +If CALLBACK is nil use `cider-interactive-eval-handler'. +BOUNDS, if non-nil, is a list of two numbers marking the start and end +positions of FORM in its buffer. +ADDITIONAL-PARAMS is a map to be merged into the request message. + +If `cider-interactive-eval-override' is a function, call it with the same +arguments and only proceed with evaluation if it returns nil." + (let ((form (or form (apply #'buffer-substring-no-properties bounds))) + (start (car-safe bounds)) + (end (car-safe (cdr-safe bounds)))) + (when (and start end) + ;; NOTE: don't use `remove-overlays' as it splits and leaves behind + ;; partial overlays, leading to duplicate eval results in some situations. + (dolist (ov (overlays-in start end)) + (when (eq (overlay-get ov 'cider-temporary) t) + (delete-overlay ov)))) + (unless (and cider-interactive-eval-override + (functionp cider-interactive-eval-override) + (condition-case _ + (funcall cider-interactive-eval-override form callback bounds additional-params) + (wrong-number-of-arguments + ;; fallback for backward compatibility + (funcall cider-interactive-eval-override form callback bounds)))) + (cider-map-repls :auto + (lambda (connection) + (cider--prep-interactive-eval form connection) + (cider-nrepl-request:eval + form + (or callback (cider-interactive-eval-handler nil bounds)) + ;; always eval ns forms in the user namespace + ;; otherwise trying to eval ns form for the first time will produce an error + (if (cider-ns-form-p form) "user" (cider-current-ns)) + (when start (line-number-at-pos start)) + (when start (cider-column-number-at-pos start)) + (seq-mapcat #'identity additional-params) + connection)))))) + +(defun cider-eval-region (start end) + "Evaluate the region between START and END." + (interactive "r") + (cider-interactive-eval nil + nil + (list start end) + (cider--nrepl-pr-request-map))) + +(defun cider-eval-last-sexp (&optional output-to-current-buffer) + "Evaluate the expression preceding point. +If invoked with OUTPUT-TO-CURRENT-BUFFER, print the result in the current +buffer." + (interactive "P") + (cider-interactive-eval nil + (when output-to-current-buffer (cider-eval-print-handler)) + (cider-last-sexp 'bounds) + (cider--nrepl-pr-request-map))) + +(defun cider-eval-last-sexp-and-replace () + "Evaluate the expression preceding point and replace it with its result." + (interactive) + (let ((last-sexp (cider-last-sexp))) + ;; we have to be sure the evaluation won't result in an error + (cider-nrepl-sync-request:eval last-sexp) + ;; seems like the sexp is valid, so we can safely kill it + (let ((opoint (point))) + (clojure-backward-logical-sexp) + (kill-region (point) opoint)) + (cider-interactive-eval last-sexp + (cider-eval-print-handler) + nil + (cider--nrepl-pr-request-map)))) + +(defun cider-eval-list-at-point (&optional output-to-current-buffer) + "Evaluate the list (eg. a function call, surrounded by parens) around point. +If invoked with OUTPUT-TO-CURRENT-BUFFER, output the result to current buffer." + (interactive "P") + (save-excursion + (goto-char (cadr (cider-list-at-point 'bounds))) + (cider-eval-last-sexp output-to-current-buffer))) + +(defun cider-eval-sexp-at-point (&optional output-to-current-buffer) + "Evaluate the expression around point. +If invoked with OUTPUT-TO-CURRENT-BUFFER, output the result to current buffer." + (interactive "P") + (save-excursion + (goto-char (cadr (cider-sexp-at-point 'bounds))) + (cider-eval-last-sexp output-to-current-buffer))) + +(defun cider-tap-last-sexp (&optional output-to-current-buffer) + "Evaluate and tap the expression preceding point. +If invoked with OUTPUT-TO-CURRENT-BUFFER, print the result in the current +buffer." + (interactive "P") + (let ((tapped-form (concat "(clojure.core/doto " (cider-last-sexp) " (clojure.core/tap>))"))) + (cider-interactive-eval tapped-form + (when output-to-current-buffer (cider-eval-print-handler)) + nil + (cider--nrepl-pr-request-map)))) + +(defun cider-tap-sexp-at-point (&optional output-to-current-buffer) + "Evaluate and tap the expression around point. +If invoked with OUTPUT-TO-CURRENT-BUFFER, output the result to current buffer." + (interactive "P") + (save-excursion + (goto-char (cadr (cider-sexp-at-point 'bounds))) + (cider-tap-last-sexp output-to-current-buffer))) + +(defvar-local cider-previous-eval-context nil + "The previous evaluation context if any. +That's set by commands like `cider-eval-last-sexp-in-context'.") + + +(defun cider--guess-eval-context () + "Return context for `cider--eval-in-context'. +This is done by extracting all parent let bindings." + (save-excursion + (let ((res "")) + (condition-case nil + (while t + (backward-up-list) + (when (looking-at (rx "(" (or "when-let" "if-let" "let") (opt "*") + symbol-end (* space) + (group "["))) ;; binding vector + (let ((beg (match-end 1)) + (end (save-excursion + (goto-char (match-beginning 1)) + (forward-sexp 1) + (1- (point))))) + (setq res (concat (buffer-substring-no-properties beg end) ", " res))))) + (scan-error res))))) + +(defun cider--eval-in-context (bounds &optional guess) + "Evaluate code at BOUNDS in user-provided evaluation context. +When GUESS is non-nil, attempt to extract the context from parent let-bindings." + (let* ((code (string-trim-right + (buffer-substring-no-properties (car bounds) (cadr bounds)))) + (eval-context + (minibuffer-with-setup-hook (if guess #'beginning-of-buffer #'ignore) + (read-string "Evaluation context (let-style): " + (if guess (cider--guess-eval-context) + cider-previous-eval-context)))) + (code (concat "(let [" eval-context "]\n " code ")"))) + (setq-local cider-previous-eval-context eval-context) + (cider-interactive-eval code + nil + bounds + (cider--nrepl-pr-request-map)))) + +(defun cider-eval-last-sexp-in-context (guess) + "Evaluate the preceding sexp in user-supplied context. +The context is just a let binding vector (without the brackets). +The context is remembered between command invocations. + +When GUESS is non-nil, or called interactively with \\[universal-argument], +attempt to extract the context from parent let-bindings." + (interactive "P") + (cider--eval-in-context (cider-last-sexp 'bounds) guess)) + +(defun cider-eval-sexp-at-point-in-context (guess) + "Evaluate the sexp around point in user-supplied context. + +The context is just a let binding vector (without the brackets). +The context is remembered between command invocations. + +When GUESS is non-nil, or called interactively with \\[universal-argument], +attempt to extract the context from parent let-bindings." + (interactive "P") + (cider--eval-in-context (cider-sexp-at-point 'bounds) guess)) + +(defun cider-eval-defun-to-comment (&optional insert-before) + "Evaluate the \"top-level\" form and insert result as comment. + +The formatting of the comment is defined in `cider-comment-prefix' +which, by default, is \";; => \" and can be customized. + +With the prefix arg INSERT-BEFORE, insert before the form, otherwise afterwards." + (interactive "P") + (let* ((bounds (cider-defun-at-point 'bounds)) + (insertion-point (nth (if insert-before 0 1) bounds))) + (cider-interactive-eval nil + (cider-eval-print-with-comment-handler + (current-buffer) + (set-marker (make-marker) insertion-point) + cider-comment-prefix) + bounds + (cider--nrepl-pr-request-map)))) + +(defun cider-pprint-form-to-comment (form-fn insert-before) + "Evaluate the form selected by FORM-FN and insert result as comment. +FORM-FN can be either `cider-last-sexp' or `cider-defun-at-point'. + +The formatting of the comment is controlled via three options: + `cider-comment-prefix' \";; => \" + `cider-comment-continued-prefix' \";; \" + `cider-comment-postfix' \"\" + +so that with customization you can optionally wrap the output +in the reader macro \"#_( .. )\", or \"(comment ... )\", or any +other desired formatting. + +If INSERT-BEFORE is non-nil, insert before the form, otherwise afterwards." + (let* ((bounds (funcall form-fn 'bounds)) + (insertion-point (nth (if insert-before 0 1) bounds)) + ;; when insert-before, we need a newline after the output to + ;; avoid commenting the first line of the form + (comment-postfix (concat cider-comment-postfix + (if insert-before "\n" "")))) + (cider-interactive-eval nil + (cider-eval-pprint-with-multiline-comment-handler + (current-buffer) + (set-marker (make-marker) insertion-point) + cider-comment-prefix + cider-comment-continued-prefix + comment-postfix) + bounds + (cider--nrepl-print-request-map fill-column)))) + +(defun cider-pprint-eval-last-sexp-to-comment (&optional insert-before) + "Evaluate the last sexp and insert result as comment. + +The formatting of the comment is controlled via three options: + `cider-comment-prefix' \";; => \" + `cider-comment-continued-prefix' \";; \" + `cider-comment-postfix' \"\" + +so that with customization you can optionally wrap the output +in the reader macro \"#_( .. )\", or \"(comment ... )\", or any +other desired formatting. + +If INSERT-BEFORE is non-nil, insert before the form, otherwise afterwards." + (interactive "P") + (cider-pprint-form-to-comment 'cider-last-sexp insert-before)) + +(defun cider-pprint-eval-defun-to-comment (&optional insert-before) + "Evaluate the \"top-level\" form and insert result as comment. + +The formatting of the comment is controlled via three options: + `cider-comment-prefix' \";; => \" + `cider-comment-continued-prefix' \";; \" + `cider-comment-postfix' \"\" + +so that with customization you can optionally wrap the output +in the reader macro \"#_( .. )\", or \"(comment ... )\", or any +other desired formatting. + +If INSERT-BEFORE is non-nil, insert before the form, otherwise afterwards." + (interactive "P") + (cider-pprint-form-to-comment 'cider-defun-at-point insert-before)) + +(declare-function cider-switch-to-repl-buffer "cider-mode") + +(defun cider--eval-last-sexp-to-repl (switch-to-repl request-map) + "Evaluate the expression preceding point and insert its result in the REPL, +honoring SWITCH-TO-REPL, REQUEST-MAP." + (let ((bounds (cider-last-sexp 'bounds))) + (cider-interactive-eval nil + (cider-insert-eval-handler (cider-current-repl) + bounds + (current-buffer) + (lambda () + (when switch-to-repl + (cider-switch-to-repl-buffer)))) + bounds + request-map))) + +(defun cider-eval-last-sexp-to-repl (&optional prefix) + "Evaluate the expression preceding point and insert its result in the REPL. +If invoked with a PREFIX argument, switch to the REPL buffer." + (interactive "P") + (cider--eval-last-sexp-to-repl prefix (cider--nrepl-pr-request-map))) + +(defun cider-pprint-eval-last-sexp-to-repl (&optional prefix) + "Evaluate expr before point and insert its pretty-printed result in the REPL. +If invoked with a PREFIX argument, switch to the REPL buffer." + (interactive "P") + (cider--eval-last-sexp-to-repl prefix (cider--nrepl-print-request-map fill-column))) + +(defun cider-eval-print-last-sexp (&optional pretty-print) + "Evaluate the expression preceding point. +Print its value into the current buffer. +With an optional PRETTY-PRINT prefix it pretty-prints the result." + (interactive "P") + (cider-interactive-eval nil + (cider-eval-print-handler) + (cider-last-sexp 'bounds) + (if pretty-print + (cider--nrepl-print-request-map fill-column) + (cider--nrepl-pr-request-map)))) + +(defun cider--pprint-eval-form (form) + "Pretty print FORM in popup buffer." + (let* ((buffer (current-buffer)) + (result-buffer (cider-popup-buffer cider-result-buffer nil 'clojure-mode 'ancillary)) + (handler (cider-popup-eval-handler result-buffer form buffer))) + (with-current-buffer buffer + (cider-interactive-eval (when (stringp form) form) + handler + (when (consp form) form) + (cider--nrepl-print-request-map fill-column))))) + +(defun cider-pprint-eval-last-sexp (&optional output-to-current-buffer) + "Evaluate the sexp preceding point and pprint its value. +If invoked with OUTPUT-TO-CURRENT-BUFFER, insert as comment in the current +buffer, else display in a popup buffer." + (interactive "P") + (if output-to-current-buffer + (cider-pprint-eval-last-sexp-to-comment) + (cider--pprint-eval-form (cider-last-sexp 'bounds)))) + +(defun cider--prompt-and-insert-inline-dbg () + "Insert a #dbg button at the current sexp." + (save-excursion + (let ((beg)) + (skip-chars-forward "\r\n[:blank:]") + (unless (looking-at-p "(") + (ignore-errors (backward-up-list))) + (setq beg (point)) + (let* ((cond (cider-read-from-minibuffer "Condition for debugging (leave empty for \"always\"): ")) + (button (propertize (concat "#dbg" + (unless (equal cond "") + (format " ^{:break/when %s}" cond))) + 'font-lock-face 'cider-fragile-button-face))) + (when (> (current-column) 30) + (insert "\n") + (indent-according-to-mode)) + (insert button) + (when (> (current-column) 40) + (insert "\n") + (indent-according-to-mode))) + (make-button beg (point) + 'help-echo "Breakpoint. Reevaluate this form to remove it." + :type 'cider-fragile)))) + +(defun cider-eval-dwim (&optional debug-it) + "If no region is active, call `cider-eval-defun-at-point' with DEBUG-IT. +If a region is active, run `cider-eval-region'. + +Always binds `clojure-toplevel-inside-comment-form' to t." + (interactive "P") + (let ((clojure-toplevel-inside-comment-form t)) + (if (use-region-p) + (cider-eval-region (region-beginning) (region-end)) + (cider-eval-defun-at-point debug-it)))) + +(defun cider-eval-defun-at-point (&optional debug-it) + "Evaluate the current toplevel form, and print result in the minibuffer. +With DEBUG-IT prefix argument, also debug the entire form as with the +command `cider-debug-defun-at-point'." + (interactive "P") + (let ((inline-debug (eq 16 (car-safe debug-it)))) + (when debug-it + (when (cider-clojurescript-major-mode-p) + (when (y-or-n-p (concat "The debugger doesn't support ClojureScript yet, and we need help with that." + " \nWould you like to read the Feature Request?")) + (browse-url "https://github.com/clojure-emacs/cider/issues/1416")) + (user-error "The debugger does not support ClojureScript")) + (when inline-debug + (cider--prompt-and-insert-inline-dbg))) + (cider-interactive-eval (when (and debug-it (not inline-debug)) + (concat "#dbg\n" (cider-defun-at-point))) + nil + (cider-defun-at-point 'bounds) + (cider--nrepl-pr-request-map)))) + +(defun cider--insert-closing-delimiters (code) + "Closes all open parenthesized or bracketed expressions of CODE." + (with-temp-buffer + (insert code) + (goto-char (point-max)) + (let ((matching-delimiter nil)) + (while (ignore-errors + (save-excursion + (backward-up-list 1) + (setq matching-delimiter (cdr (syntax-after (point))))) + t) + (insert-char matching-delimiter))) + (buffer-string))) + +(defun cider-eval-defun-up-to-point (&optional output-to-current-buffer) + "Evaluate the current toplevel form up to point. +If invoked with OUTPUT-TO-CURRENT-BUFFER, print the result in the current +buffer. It constructs an expression to eval in the following manner: + +- It find the code between the point and the start of the toplevel expression; +- It balances this bit of code by closing all open expressions; +- It evaluates the resulting code using `cider-interactive-eval'." + (interactive "P") + (let* ((beg-of-defun (save-excursion (beginning-of-defun-raw) (point))) + (code (buffer-substring-no-properties beg-of-defun (point))) + (code (cider--insert-closing-delimiters code))) + (cider-interactive-eval code + (when output-to-current-buffer + (cider-eval-print-handler)) + (list beg-of-defun (point)) + (cider--nrepl-pr-request-map)))) + +(defun cider--matching-delimiter (delimiter) + "Get the matching (opening/closing) delimiter for DELIMITER." + (pcase delimiter + (?\( ?\)) + (?\[ ?\]) + (?\{ ?\}) + (?\) ?\() + (?\] ?\[) + (?\} ?\{))) + +(defun cider-eval-sexp-up-to-point (&optional output-to-current-buffer) + "Evaluate the current sexp form up to point. +If invoked with OUTPUT-TO-CURRENT-BUFFER, print the result in the current +buffer. It constructs an expression to eval in the following manner: + +- It finds the code between the point and the start of the sexp expression; +- It balances this bit of code by closing the expression; +- It evaluates the resulting code using `cider-interactive-eval'." + (interactive "P") + (let* ((beg-of-sexp (save-excursion (up-list) (backward-list) (point))) + (beg-delimiter (save-excursion (up-list) (backward-list) (char-after))) + (beg-set? (save-excursion (up-list) (backward-list) (char-before))) + (code (buffer-substring-no-properties beg-of-sexp (point))) + (code (if (= beg-set? ?#) (concat (list beg-set?) code) code)) + (code (concat code (list (cider--matching-delimiter beg-delimiter))))) + (cider-interactive-eval code + (when output-to-current-buffer + (cider-eval-print-handler)) + (list beg-of-sexp (point)) + (cider--nrepl-pr-request-map)))) + +(defun cider-pprint-eval-defun-at-point (&optional output-to-current-buffer) + "Evaluate the \"top-level\" form at point and pprint its value. +If invoked with OUTPUT-TO-CURRENT-BUFFER, insert as comment in the current +buffer, else display in a popup buffer." + (interactive "P") + (if output-to-current-buffer + (cider-pprint-eval-defun-to-comment) + (cider--pprint-eval-form (cider-defun-at-point 'bounds)))) + +(defun cider-eval-ns-form (&optional undef-all) + "Evaluate the current buffer's namespace form. +When UNDEF-ALL is non-nil, unmap all symbols and aliases first." + (interactive "P") + (when-let ((ns (cider-get-ns-name))) + (save-excursion + (goto-char (match-beginning 0)) + (when undef-all + (cider-undef-all ns)) + (cider-eval-defun-at-point)))) + +(defun cider-read-and-eval (&optional value) + "Read a sexp from the minibuffer and output its result to the echo area. +If VALUE is non-nil, it is inserted into the minibuffer as initial input." + (interactive) + (let* ((form (cider-read-from-minibuffer "Clojure Eval: " value)) + (override cider-interactive-eval-override) + (ns-form (if (cider-ns-form-p form) "" (format "(ns %s)" (cider-current-ns))))) + (with-current-buffer (get-buffer-create cider-read-eval-buffer) + (erase-buffer) + (clojure-mode) + (unless (string= "" ns-form) + (insert ns-form "\n\n")) + (insert form) + (let ((cider-interactive-eval-override override)) + (cider-interactive-eval form + nil + nil + (cider--nrepl-pr-request-map)))))) + +(defun cider-read-and-eval-defun-at-point () + "Insert the toplevel form at point in the minibuffer and output its result. +The point is placed next to the function name in the minibuffer to allow +passing arguments." + (interactive) + (let* ((fn-name (cadr (split-string (cider-defun-at-point)))) + (form (format "(%s)" fn-name))) + (cider-read-and-eval (cons form (length form))))) + +(defun cider-kill-last-result () + "Save the last evaluated result into the kill ring." + (interactive) + (kill-new + (nrepl-dict-get (cider-nrepl-sync-request:eval "*1") "value"))) + +(defun cider-undef () + "Undefine a symbol from the current ns." + (interactive) + (cider-ensure-op-supported "undef") + (cider-read-symbol-name + "Undefine symbol: " + (lambda (sym) + (cider-nrepl-send-request + `("op" "undef" + "ns" ,(cider-current-ns) + "sym" ,sym) + (cider-interactive-eval-handler (current-buffer)))))) + +(defun cider-undef-all (&optional ns) + "Undefine all symbols and aliases from the namespace NS." + (interactive) + (cider-ensure-op-supported "undef-all") + (cider-nrepl-send-sync-request + `("op" "undef-all" + "ns" ,(or ns (cider-current-ns))))) + +;; Eval keymaps +(defvar cider-eval-pprint-commands-map + (let ((map (define-prefix-command 'cider-eval-pprint-commands-map))) + ;; single key bindings defined last for display in menu + (define-key map (kbd "e") #'cider-pprint-eval-last-sexp) + (define-key map (kbd "d") #'cider-pprint-eval-defun-at-point) + (define-key map (kbd "c e") #'cider-pprint-eval-last-sexp-to-comment) + (define-key map (kbd "c d") #'cider-pprint-eval-defun-to-comment) + + ;; duplicates with C- for convenience + (define-key map (kbd "C-e") #'cider-pprint-eval-last-sexp) + (define-key map (kbd "C-d") #'cider-pprint-eval-defun-at-point) + (define-key map (kbd "C-c e") #'cider-pprint-eval-last-sexp-to-comment) + (define-key map (kbd "C-c C-e") #'cider-pprint-eval-last-sexp-to-comment) + (define-key map (kbd "C-c d") #'cider-pprint-eval-defun-to-comment) + (define-key map (kbd "C-c C-d") #'cider-pprint-eval-defun-to-comment) + map)) + +(defvar cider-eval-commands-map + (let ((map (define-prefix-command 'cider-eval-commands-map))) + ;; single key bindings defined last for display in menu + (define-key map (kbd "w") #'cider-eval-last-sexp-and-replace) + (define-key map (kbd "r") #'cider-eval-region) + (define-key map (kbd "n") #'cider-eval-ns-form) + (define-key map (kbd "s") #'cider-eval-dwim) + (define-key map (kbd "d") #'cider-eval-defun-at-point) + (define-key map (kbd "e") #'cider-eval-last-sexp) + (define-key map (kbd "q") #'cider-tap-last-sexp) + (define-key map (kbd "l") #'cider-eval-list-at-point) + (define-key map (kbd "v") #'cider-eval-sexp-at-point) + (define-key map (kbd "t") #'cider-tap-sexp-at-point) + (define-key map (kbd "o") #'cider-eval-sexp-up-to-point) + (define-key map (kbd ".") #'cider-read-and-eval-defun-at-point) + (define-key map (kbd "z") #'cider-eval-defun-up-to-point) + (define-key map (kbd "c") #'cider-eval-last-sexp-in-context) + (define-key map (kbd "b") #'cider-eval-sexp-at-point-in-context) + (define-key map (kbd "k") #'cider-kill-last-result) + (define-key map (kbd "f") 'cider-eval-pprint-commands-map) + + ;; duplicates with C- for convenience + (define-key map (kbd "C-w") #'cider-eval-last-sexp-and-replace) + (define-key map (kbd "C-r") #'cider-eval-region) + (define-key map (kbd "C-n") #'cider-eval-ns-form) + (define-key map (kbd "C-s") #'cider-eval-dwim) + (define-key map (kbd "C-d") #'cider-eval-defun-at-point) + (define-key map (kbd "C-e") #'cider-eval-last-sexp) + (define-key map (kbd "C-q") #'cider-tap-last-sexp) + (define-key map (kbd "C-l") #'cider-eval-list-at-point) + (define-key map (kbd "C-v") #'cider-eval-sexp-at-point) + (define-key map (kbd "C-t") #'cider-tap-sexp-at-point) + (define-key map (kbd "C-o") #'cider-eval-sexp-up-to-point) + (define-key map (kbd "C-.") #'cider-read-and-eval-defun-at-point) + (define-key map (kbd "C-z") #'cider-eval-defun-up-to-point) + (define-key map (kbd "C-c") #'cider-eval-last-sexp-in-context) + (define-key map (kbd "C-b") #'cider-eval-sexp-at-point-in-context) + (define-key map (kbd "C-k") #'cider-kill-last-result) + (define-key map (kbd "C-f") 'cider-eval-pprint-commands-map) + map)) + +(defun cider--file-string (file) + "Read the contents of a FILE and return as a string." + (with-current-buffer (find-file-noselect file) + (save-restriction + (widen) + (substring-no-properties (buffer-string))))) + +(defun cider-load-buffer (&optional buffer callback undef-all) + "Load (eval) BUFFER's file in nREPL. +If no buffer is provided the command acts on the current buffer. If the +buffer is for a cljc file, and both a Clojure and ClojureScript REPL exists +for the project, it is evaluated in both REPLs. +Optional argument CALLBACK will override the default ‘cider-load-file-handler’. +When UNDEF-ALL is non-nil or called with \\[universal-argument], removes +all ns aliases and var mappings from the namespace before reloading it." + (interactive (list (current-buffer) nil (equal current-prefix-arg '(4)))) + (setq buffer (or buffer (current-buffer))) + ;; When cider-load-buffer or cider-load-file are called in programs the + ;; current context might not match the buffer's context. We use the caller + ;; context instead of the buffer's context because that's the common use + ;; case. For the other use case just let-bind the default-directory. + (let ((orig-default-directory default-directory)) + (with-current-buffer buffer + (check-parens) + (let ((default-directory orig-default-directory)) + (unless buffer-file-name + (user-error "Buffer `%s' is not associated with a file" (current-buffer))) + (when (and cider-save-file-on-load + (buffer-modified-p) + (or (eq cider-save-file-on-load t) + (y-or-n-p (format "Save file %s? " buffer-file-name)))) + (save-buffer)) + (remove-overlays nil nil 'cider-temporary t) + (when undef-all + (cider-undef-all (cider-current-ns))) + (cider--clear-compilation-highlights) + (cider--quit-error-window) + (let ((filename (buffer-file-name buffer)) + (ns-form (cider-ns-form))) + (cider-map-repls :auto + (lambda (repl) + (when ns-form + (cider-repl--cache-ns-form ns-form repl)) + (cider-request:load-file (cider--file-string filename) + (funcall cider-to-nrepl-filename-function + (cider--server-filename filename)) + (file-name-nondirectory filename) + repl + callback))) + (message "Loading %s..." filename)))))) + +(defun cider-load-file (filename &optional undef-all) + "Load (eval) the Clojure file FILENAME in nREPL. +If the file is a cljc file, and both a Clojure and ClojureScript REPL +exists for the project, it is evaluated in both REPLs. The heavy lifting +is done by `cider-load-buffer'. +When UNDEF-ALL is non-nil or called with \\[universal-argument], removes +all ns aliases and var mappings from the namespace before reloading it." + (interactive (list + (read-file-name "Load file: " nil nil nil + (when (buffer-file-name) + (file-name-nondirectory + (buffer-file-name)))) + (equal current-prefix-arg '(4)))) + (if-let* ((buffer (find-buffer-visiting filename))) + (cider-load-buffer buffer nil undef-all) + (cider-load-buffer (find-file-noselect filename) nil undef-all))) + +(defun cider-load-all-files (directory undef-all) + "Load all files in DIRECTORY (recursively). +Useful when the running nREPL on remote host. +When UNDEF-ALL is non-nil or called with \\[universal-argument], removes +all ns aliases and var mappings from the namespaces being reloaded" + (interactive "DRecursively load files in directory: \nP") + (let* ((files (directory-files-recursively directory "\\.clj[cs]?$")) + (reporter (make-progress-reporter "Loading files" 0 (length files)))) + (seq-do-indexed (lambda (file idx) + (let ((inhibit-message t)) + (cider-load-file file undef-all)) + (progress-reporter-update reporter (1+ idx) file)) + files) + (progress-reporter-done reporter))) + +(defalias 'cider-eval-file #'cider-load-file + "A convenience alias as some people are confused by the load-* names.") + +(defalias 'cider-eval-all-files #'cider-load-all-files + "A convenience alias as some people are confused by the load-* names.") + +(defalias 'cider-eval-buffer #'cider-load-buffer + "A convenience alias as some people are confused by the load-* names.") + +(defun cider-load-all-project-ns () + "Load all namespaces in the current project." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "ns-load-all") + (when (y-or-n-p "Are you sure you want to load all namespaces in the project? ") + (message "Loading all project namespaces...") + (let ((loaded-ns-count (length (cider-sync-request:ns-load-all)))) + (message "Loaded %d namespaces" loaded-ns-count)))) + +(provide 'cider-eval) + +;;; cider-eval.el ends here diff --git a/elpa/cider-20241203.1607/cider-find.el b/elpa/cider-20241203.1607/cider-find.el new file mode 100644 index 00000000..0af706e2 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-find.el @@ -0,0 +1,285 @@ +;;; cider-find.el --- Functionality for finding things -*- lexical-binding: t -*- + +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Bozhidar Batsov +;; Artur Malabarba + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; A bunch of commands for finding resources and definitions. + +;;; Code: + +(require 'cider-client) +(require 'cider-common) +(require 'cider-resolve) + +(require 'thingatpt) + +(defun cider--find-var-other-window (var &optional line) + "Find the definition of VAR, optionally at a specific LINE. + +Display the results in a different window." + (if-let* ((info (cider-var-info var))) + (progn + (if line (setq info (nrepl-dict-put info "line" line))) + (cider--jump-to-loc-from-info info t)) + (user-error "Symbol `%s' not resolved" var))) + +(defun cider--find-var (var &optional line) + "Find the definition of VAR, optionally at a specific LINE." + (if-let* ((info (cider-var-info var))) + (progn + (if line (setq info (nrepl-dict-put info "line" line))) + (cider--jump-to-loc-from-info info)) + (user-error "Symbol `%s' not resolved" var))) + +;;;###autoload +(defun cider-find-var (&optional arg var line) + "Find definition for VAR at LINE. +Prompt according to prefix ARG and `cider-prompt-for-symbol'. +A single or double prefix argument inverts the meaning of +`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes +the results to be displayed in a different window. The default value is +thing at point." + (interactive "P") + (if var + (cider--find-var var line) + (funcall (cider-prompt-for-symbol-function arg) + "Symbol" + (if (cider--open-other-window-p arg) + #'cider--find-var-other-window + #'cider--find-var)))) + +;;;###autoload +(defun cider-find-dwim-at-mouse (event) + "Find and display variable or resource at mouse EVENT." + (interactive "e") + (if-let* ((symbol-file (save-excursion + (mouse-set-point event) + (cider-symbol-at-point 'look-back)))) + (cider-find-dwim symbol-file) + (user-error "No variable or resource here"))) + +(defun cider--find-dwim (symbol-file callback &optional other-window) + "Find the SYMBOL-FILE at point. +CALLBACK upon failure to invoke prompt if not prompted previously. +Show results in a different window if OTHER-WINDOW is true." + (if-let* ((info (cider-var-info symbol-file))) + (cider--jump-to-loc-from-info info other-window) + (progn + (cider-ensure-op-supported "resource") + (if-let* ((resource (cider-sync-request:resource symbol-file)) + (buffer (cider-find-file resource))) + (cider-jump-to buffer 0 other-window) + (if (cider--prompt-for-symbol-p current-prefix-arg) + (error "Resource or var %s not resolved" symbol-file) + (let ((current-prefix-arg (if current-prefix-arg nil '(4)))) + (call-interactively callback))))))) + +(defun cider--find-dwim-interactive (prompt) + "Get interactive arguments for jump-to functions using PROMPT as needed." + (if (cider--prompt-for-symbol-p current-prefix-arg) + (list + (cider-read-from-minibuffer prompt (thing-at-point 'filename))) + (list (or (thing-at-point 'filename) "")))) ; No prompt. + +(defun cider-find-dwim-other-window (symbol-file) + "Jump to SYMBOL-FILE at point, place results in other window." + (interactive (cider--find-dwim-interactive "Jump to: ")) + (cider--find-dwim symbol-file 'cider-find-dwim-other-window t)) + +;;;###autoload +(defun cider-find-dwim (symbol-file) + "Find and display the SYMBOL-FILE at point. +SYMBOL-FILE could be a var or a resource. If thing at point is empty then +show Dired on project. If var is not found, try to jump to resource of the +same name. When called interactively, a prompt is given according to the +variable `cider-prompt-for-symbol'. A single or double prefix argument +inverts the meaning. A prefix of `-' or a double prefix argument causes +the results to be displayed in a different window. A default value of thing +at point is given when prompted." + (interactive (cider--find-dwim-interactive "Jump to: ")) + (cider--find-dwim symbol-file `cider-find-dwim + (cider--open-other-window-p current-prefix-arg))) + +;;;###autoload +(defun cider-find-resource (path) + "Find the resource at PATH. +Prompt for input as indicated by the variable `cider-prompt-for-symbol'. +A single or double prefix argument inverts the meaning of +`cider-prompt-for-symbol'. A prefix argument of `-` or a double prefix +argument causes the results to be displayed in other window. The default +value is thing at point." + (interactive + (list + (if (cider--prompt-for-symbol-p current-prefix-arg) + (completing-read "Resource: " + (cider-sync-request:resources-list) + nil nil + (thing-at-point 'filename)) + (or (thing-at-point 'filename) "")))) + (cider-ensure-op-supported "resource") + (when (= (length path) 0) + (error "Cannot find resource for empty path")) + (if-let* ((resource (cider-sync-request:resource path)) + (buffer (cider-find-file resource))) + (cider-jump-to buffer nil (cider--open-other-window-p current-prefix-arg)) + (if (cider--prompt-for-symbol-p current-prefix-arg) + (error "Cannot find resource %s" path) + (let ((current-prefix-arg (cider--invert-prefix-arg current-prefix-arg))) + (call-interactively 'cider-find-resource))))) + +(defun cider--invert-prefix-arg (arg) + "Invert the effect of prefix value ARG on `cider-prompt-for-symbol'. +This function preserves the `other-window' meaning of ARG." + (let ((narg (prefix-numeric-value arg))) + (pcase narg + (16 -1) ; empty empty -> - + (-1 16) ; - -> empty empty + (4 nil) ; empty -> no-prefix + (_ 4)))) ; no-prefix -> empty + +(defun cider--prefix-invert-prompt-p (arg) + "Test prefix value ARG for its effect on `cider-prompt-for-symbol`." + (let ((narg (prefix-numeric-value arg))) + (pcase narg + (16 t) ; empty empty + (4 t) ; empty + (_ nil)))) + +(defun cider--prompt-for-symbol-p (&optional prefix) + "Check if cider should prompt for symbol. +Tests againsts PREFIX and the value of `cider-prompt-for-symbol'. +Invert meaning of `cider-prompt-for-symbol' if PREFIX indicates it should be." + (if (cider--prefix-invert-prompt-p prefix) + (not cider-prompt-for-symbol) cider-prompt-for-symbol)) + +(defun cider--find-ns (ns &optional other-window) + "Find the file containing NS's definition. +Optionally open it in a different window if OTHER-WINDOW is truthy." + (if-let* ((path (cider-sync-request:ns-path ns))) + (cider-jump-to (cider-find-file path) nil other-window) + (user-error "Can't find namespace `%s'" ns))) + +;;;###autoload +(defun cider-find-ns (&optional arg ns) + "Find the file containing NS. +A prefix ARG of `-` or a double prefix argument causes +the results to be displayed in a different window." + (interactive "P") + (cider-ensure-connected) + (cider-ensure-op-supported "ns-path") + (if ns + (cider--find-ns ns) + (let* ((namespaces (cider-sync-request:ns-list)) + (ns (completing-read "Find namespace: " namespaces))) + (cider--find-ns ns (cider--open-other-window-p arg))))) + +(defun cider--find-keyword-in-buffer (buffer kw) + "Returns the point where `KW' is found in `BUFFER'. +Returns nil of no matching keyword is found. +Occurrences of `KW' as (or within) strings, comments, #_ forms, symbols, etc +are disregarded." + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (font-lock-ensure) ;; make the forthcoming `text-properties-at` call useful + (let ((found nil) + (continue t) + (current-point (point))) + (while continue + (setq found (and (search-forward-regexp kw nil 'noerror) + (member 'clojure-keyword-face (text-properties-at (1- (point)))))) + (setq continue (and (not found) + ;; if we haven't moved, there's nothing left to search: + (not (equal current-point (point))))) + (setq current-point (point))) + (when found + current-point))))) + +(defun cider--find-keyword-loc (kw) + "Given `KW', returns an nrepl-dict with url, dest, dest-point. + +Returns the dict in all cases. `dest-point' indicates success: +integer on successful finds, nil otherwise." + (let* ((simple-ns-qualifier (and + (string-match "^:\\(.+\\)/.+$" kw) + (match-string 1 kw))) + (auto-resolved-ns-qualifier (and + (string-match "^::\\(.+\\)/.+$" kw) + (match-string 1 kw))) + (kw-ns (or (and auto-resolved-ns-qualifier + (or (cider-resolve-alias (cider-current-ns) auto-resolved-ns-qualifier) + (user-error "Could not resolve alias: %S" auto-resolved-ns-qualifier))) + (and (string-match "^::" kw) + (cider-current-ns :no-default)) + simple-ns-qualifier + (user-error "Not a ns-qualified keyword: %S" kw))) + (kw-name (replace-regexp-in-string "^:+\\(.+/\\)?" "" kw)) + (beginning-of-symbol "\\_<") + (end-of-symbol "\\_>") ;; important: if searching for foo, we don't want to match foobar (a larger symbol) + (kw-to-find (concat beginning-of-symbol + "\\(" + (concat "::" kw-name) + "\\|" + (concat ":" kw-ns "/" kw-name) + "\\)" + end-of-symbol))) + (let* ((url (when kw-ns + (cider-sync-request:ns-path kw-ns t))) + (dest (when url + (cider-find-file url))) + (dest-point (when dest + (cider--find-keyword-in-buffer dest kw-to-find)))) + (nrepl-dict "url" url "dest" dest "dest-point" dest-point)))) + +;;;###autoload +(defun cider-find-keyword (&optional arg) + "Find the namespace of the keyword at point and its primary occurrence there. + +For instance - if the keyword at point is \":cider.demo/keyword\", this command +would find the namespace \"cider.demo\" and afterwards find the primary (most relevant or first) +mention of \"::keyword\" there. + +Prompt according to prefix ARG and `cider-prompt-for-symbol'. +A single or double prefix argument inverts the meaning of +`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes +the results to be displayed in a different window. The default value is +thing at point." + (interactive "P") + (cider-ensure-connected) + (let* ((kw (let ((kw-at-point (cider-symbol-at-point 'look-back))) + (if (or cider-prompt-for-symbol arg) + (read-string + (format "Keyword (default %s): " kw-at-point) + nil nil kw-at-point) + kw-at-point))) + (before (buffer-list)) + (result (cider--find-keyword-loc kw))) + (nrepl-dbind-response result (dest dest-point) + (if dest-point + (cider-jump-to dest dest-point arg) + (progn + (unless (memq dest before) + (kill-buffer dest)) + (user-error "Couldn't find a definition for %S" kw)))))) + +(provide 'cider-find) +;;; cider-find.el ends here diff --git a/elpa/cider-20241203.1607/cider-format.el b/elpa/cider-20241203.1607/cider-format.el new file mode 100644 index 00000000..2673430f --- /dev/null +++ b/elpa/cider-20241203.1607/cider-format.el @@ -0,0 +1,154 @@ +;;; cider-format.el --- Code and EDN formatting functionality -*- lexical-binding: t -*- + +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Bozhidar Batsov +;; Artur Malabarba + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Middleware-powered code and EDN formatting functionality. + +;;; Code: + +(require 'map) +(require 'seq) +(require 'subr-x) + +(require 'cider-client) +(require 'cider-util) + + +;; Format + +(defun cider--format-reindent (formatted start) + "Reindent FORMATTED to align with buffer position START." + (let* ((start-column (save-excursion (goto-char start) (current-column))) + (indent-line (concat "\n" (make-string start-column ? )))) + (replace-regexp-in-string "\n" indent-line formatted))) + + +;;; Format region + +(defun cider--format-region (start end formatter) + "Format the contents of the given region. + +START and END represent the region's boundaries. + +FORMATTER is a function of one argument which is used to convert +the string contents of the region into a formatted string. + +Uses the following heuristic to try to maintain point position: + +- Take a snippet of text starting at current position, up to 64 chars. +- Search for the snippet, with lax whitespace, in the formatted text. + - If snippet is less than 64 chars (point was near end of buffer), search + from end instead of beginning. +- Place point at match beginning, or `point-min' if no match." + (let* ((original (buffer-substring-no-properties start end)) + (formatted (funcall formatter original)) + (indented (cider--format-reindent formatted start))) + (unless (equal original indented) + (let* ((pos (point)) + (pos-max (1+ (buffer-size))) + (l 64) + (endp (> (+ pos l) pos-max)) + (snippet (thread-last + (buffer-substring-no-properties + pos (min (+ pos l) pos-max)) + (regexp-quote) + (replace-regexp-in-string "[[:space:]\t\n\r]+" "[[:space:]\t\n\r]*")))) + (delete-region start end) + (insert indented) + (goto-char (if endp (point-max) (point-min))) + (funcall (if endp #'re-search-backward #'re-search-forward) snippet nil t) + (goto-char (or (match-beginning 0) start)) + (when (looking-at-p "\n") (forward-char)))))) + +;;;###autoload +(defun cider-format-region (start end) + "Format the Clojure code in the current region. +START and END represent the region's boundaries." + (interactive "r") + (cider-ensure-connected) + (cider--format-region start end + (lambda (buf) + (cider-sync-request:format-code buf cider-format-code-options)))) + + +;;; Format defun + +;;;###autoload +(defun cider-format-defun () + "Format the code in the current defun." + (interactive) + (cider-ensure-connected) + (let ((defun-bounds (cider-defun-at-point 't))) + (cider-format-region (car defun-bounds) (cadr defun-bounds)))) + + +;;; Format buffer + +(defun cider--format-buffer (formatter) + "Format the contents of the current buffer. + +Uses FORMATTER, a function of one argument, to convert the string contents +of the buffer into a formatted string." + (cider--format-region 1 (1+ (buffer-size)) formatter)) + +;;;###autoload +(defun cider-format-buffer () + "Format the Clojure code in the current buffer." + (interactive) + (check-parens) + (cider-ensure-connected) + (cider--format-buffer (lambda (buf) + (cider-sync-request:format-code buf cider-format-code-options)))) + + +;;; Format EDN + +;;;###autoload +(defun cider-format-edn-buffer () + "Format the EDN data in the current buffer." + (interactive) + (check-parens) + (cider-ensure-connected) + (cider--format-buffer (lambda (edn) + (cider-sync-request:format-edn edn fill-column)))) + +;;;###autoload +(defun cider-format-edn-region (start end) + "Format the EDN data in the current region. +START and END represent the region's boundaries." + (interactive "r") + (cider-ensure-connected) + (let* ((start-column (save-excursion (goto-char start) (current-column))) + (right-margin (- fill-column start-column))) + (cider--format-region start end + (lambda (edn) + (cider-sync-request:format-edn edn right-margin))))) + +;;;###autoload +(defun cider-format-edn-last-sexp () + "Format the EDN data of the last sexp." + (interactive) + (apply #'cider-format-edn-region (cider-sexp-at-point 'bounds))) + +(provide 'cider-format) +;;; cider-format.el ends here diff --git a/elpa/cider-20241203.1607/cider-inspector.el b/elpa/cider-20241203.1607/cider-inspector.el new file mode 100644 index 00000000..17567b55 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-inspector.el @@ -0,0 +1,836 @@ +;;; cider-inspector.el --- Object inspector -*- lexical-binding: t -*- + +;; Copyright © 2013-2024 Vital Reactor, LLC +;; Copyright © 2014-2024 Bozhidar Batsov and CIDER contributors + +;; Author: Ian Eslick +;; Bozhidar Batsov + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Clojure object inspector inspired by SLIME. + +;;; Code: + +(require 'cl-lib) +(require 'easymenu) +(require 'seq) +(require 'cider-eval) + +;; =================================== +;; Inspector Key Map and Derived Mode +;; =================================== + +(defconst cider-inspector-buffer "*cider-inspect*") + +;;; Customization +(defgroup cider-inspector nil + "Presentation and behavior of the CIDER value inspector." + :prefix "cider-inspector-" + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-inspector-page-size 32 + "Default page size in paginated inspector view. +The page size can be also changed interactively within the inspector." + :type '(integer :tag "Page size" 32) + :package-version '(cider . "0.10.0")) + +(defcustom cider-inspector-max-atom-length 150 + "Default max length of nested atoms before they are truncated. +'Atom' here means any collection member that satisfies (complement coll?). +The max length can be also changed interactively within the inspector." + :type '(integer :tag "Max atom length" 150) + :package-version '(cider . "1.1.0")) + +(defcustom cider-inspector-max-coll-size 5 + "Default number of nested collection members to display before truncating. +The max size can be also changed interactively within the inspector." + :type '(integer :tag "Max collection size" 5) + :package-version '(cider . "1.1.0")) + +(defcustom cider-inspector-max-nested-depth 5 + "Default level of nesting for collections to display before truncating. +The max depth can be also changed interactively within the inspector." + :type '(integer :tag "Max nested collection depth" 5) + :package-version '(cider . "1.14.0")) + +(defvar cider-inspector-spacious-collections nil + "Controls whether the inspector renders values in collections spaciously.") + +(defcustom cider-inspector-fill-frame nil + "Controls whether the CIDER inspector window fills its frame." + :type 'boolean + :package-version '(cider . "0.15.0")) + +(defcustom cider-inspector-skip-uninteresting t + "Controls whether to skip over uninteresting values in the inspector. +Only applies to navigation with `cider-inspector-prev-inspectable-object' +and `cider-inspector-next-inspectable-object', values are still inspectable +by clicking or navigating to them by other means." + :type 'boolean + :package-version '(cider . "0.25.0")) + +(defcustom cider-inspector-auto-select-buffer t + "Determines if the inspector buffer should be auto selected." + :type 'boolean + :package-version '(cider . "0.27.0")) + +(defvar cider-inspector-uninteresting-regexp + (concat "nil" ; nils are not interesting + "\\|:" clojure--sym-regexp ; nor keywords + ;; FIXME: This range also matches ",", is it on purpose? + "\\|[+-.0-9]+") ; nor numbers. Note: BigInts, ratios etc. are interesting + "Regexp of uninteresting and skippable values.") + +(defun cider-inspector-open-thing-at-point () + "Opens the thing at point if found, without prompting." + (interactive) + (if-let ((url (thing-at-point 'url))) + (browse-url url) + (if-let ((filename (thing-at-point 'filename))) + (find-file filename)))) + +(defvar cider-inspector-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map cider-popup-buffer-mode-map) + (define-key map (kbd "RET") #'cider-inspector-operate-on-point) + (define-key map [mouse-1] #'cider-inspector-operate-on-click) + (define-key map "l" #'cider-inspector-pop) + (define-key map "g" #'cider-inspector-refresh) + (define-key map "o" #'cider-inspector-open-thing-at-point) + ;; Page-up/down + (define-key map [next] #'cider-inspector-next-page) + (define-key map [prior] #'cider-inspector-prev-page) + (define-key map " " #'cider-inspector-next-page) + (define-key map (kbd "M-SPC") #'cider-inspector-prev-page) + (define-key map (kbd "S-SPC") #'cider-inspector-prev-page) + (define-key map "s" #'cider-inspector-set-page-size) + (define-key map "a" #'cider-inspector-set-max-atom-length) + (define-key map "c" #'cider-inspector-set-max-coll-size) + (define-key map "C" #'cider-inspector-set-max-nested-depth) + (define-key map "v" #'cider-inspector-toggle-view-mode) + (define-key map "d" #'cider-inspector-def-current-val) + (define-key map "t" #'cider-inspector-tap-current-val) + (define-key map "1" #'cider-inspector-tap-at-point) + (define-key map [tab] #'cider-inspector-next-inspectable-object) + (define-key map "\C-i" #'cider-inspector-next-inspectable-object) + (define-key map "n" #'cider-inspector-next-inspectable-object) + (define-key map [(shift tab)] #'cider-inspector-previous-inspectable-object) + (define-key map "p" #'cider-inspector-previous-inspectable-object) + (define-key map ":" #'cider-inspect-expr-from-inspector) + (define-key map "f" #'forward-char) + (define-key map "b" #'backward-char) + (define-key map "9" #'cider-inspector-previous-sibling) + (define-key map "0" #'cider-inspector-next-sibling) + ;; Emacs translates S-TAB to BACKTAB on X. + (define-key map [backtab] #'cider-inspector-previous-inspectable-object) + (easy-menu-define cider-inspector-mode-menu map + "Menu for CIDER's inspector." + `("CIDER Inspector" + ["Inspect" cider-inspector-operate-on-point] + ["Pop" cider-inspector-pop] + ["Refresh" cider-inspector-refresh] + "--" + ["Next Inspectable Object" cider-inspector-next-inspectable-object] + ["Previous Inspectable Object" cider-inspector-previous-inspectable-object] + "--" + ["Next Page" cider-inspector-next-page] + ["Previous Page" cider-inspector-prev-page] + ["Set Page Size" cider-inspector-set-page-size] + ["Set Max Atom Length" cider-inspector-set-max-atom-length] + ["Set Max Collection Size" cider-inspector-set-max-coll-size] + ["Define Var" cider-inspector-def-current-val] + "--" + ["Quit" cider-popup-buffer-quit-function] + )) + map)) + +(define-derived-mode cider-inspector-mode special-mode "Inspector" + "Major mode for inspecting Clojure data structures. + +\\{cider-inspector-mode-map}" + (set-syntax-table clojure-mode-syntax-table) + (setq-local electric-indent-chars nil) + (setq-local sesman-system 'CIDER) + (visual-line-mode 1)) + +;;;###autoload +(defun cider-inspect-last-sexp () + "Inspect the result of the the expression preceding point." + (interactive) + (cider-inspect-expr (cider-last-sexp) (cider-current-ns))) + +;;;###autoload +(defun cider-inspect-defun-at-point () + "Inspect the result of the \"top-level\" expression at point." + (interactive) + (cider-inspect-expr (cider-defun-at-point) (cider-current-ns))) + +;;;###autoload +(defun cider-inspect-last-result () + "Inspect the most recent eval result." + (interactive) + (cider-inspect-expr "*1" (cider-current-ns))) + +;;;###autoload +(defun cider-inspect (&optional arg) + "Inspect the result of the preceding sexp. + +With a prefix argument ARG it inspects the result of the \"top-level\" form. +With a second prefix argument it prompts for an expression to eval and inspect." + (interactive "p") + (pcase arg + (1 (cider-inspect-last-sexp)) + (4 (cider-inspect-defun-at-point)) + (16 (call-interactively #'cider-inspect-expr)))) + +(defvar cider-inspector-location-stack nil + "A stack used to save point locations in inspector buffers. +These locations are used to emulate `save-excursion' between +`cider-inspector-push' and `cider-inspector-pop' operations.") + +(defvar cider-inspector-page-location-stack nil + "A stack used to save point locations in inspector buffers. +These locations are used to emulate `save-excursion' between +`cider-inspector-next-page' and `cider-inspector-prev-page' operations.") + +(defvar cider-inspector-last-command nil + "Contains the value of the most recently used `cider-inspector-*' command. +This is used as an alternative to the built-in `last-command'. Whenever we +invoke any command through \\[execute-extended-command] and its variants, +the value of `last-command' is not set to the command it invokes.") + +(defvar cider-inspector--current-repl nil + "Contains the reference to the REPL where inspector was last invoked from. +This is needed for internal inspector buffer operations (push, +pop) to execute against the correct REPL session.") + +;; Operations +;;;###autoload +(defun cider-inspect-expr (expr ns) + "Evaluate EXPR in NS and inspect its value. +Interactively, EXPR is read from the minibuffer, and NS the +current buffer's namespace." + (interactive (list (cider-read-from-minibuffer "Inspect expression: " (cider-sexp-at-point)) + (cider-current-ns))) + (setq cider-inspector--current-repl (cider-current-repl)) + (let ((result (cider-sync-request:inspect-expr expr ns 'v2))) + (when (nrepl-dict-get result "value") + (cider-inspector--render-value result 'v2)))) + +(defun cider-inspect-expr-from-inspector () + "Performs `cider-inspect-expr' in a way that is suitable from the Inspector itself. +In particular, it does not read `cider-sexp-at-point'." + (interactive) + (let* ((ns (cider-current-ns)) + (prompt (format "Inspect expression in %s" + (substring-no-properties (funcall cider-repl-prompt-function ns))))) + (cider-inspect-expr (cider-read-from-minibuffer prompt nil 'skip-colon) + ns))) + +(defun cider-inspector-pop () + "Pop the last value off the inspector stack and render it. +See `cider-sync-request:inspect-pop' and `cider-inspector--render-value'." + (interactive) + (setq cider-inspector-last-command 'cider-inspector-pop) + (let ((result (cider-sync-request:inspect-pop 'v2))) + (when (nrepl-dict-get result "value") + (cider-inspector--render-value result 'v2)))) + +(defun cider-inspector-push (idx) + "Inspect the value at IDX in the inspector stack and render it. +See `cider-sync-request:inspect-push' and `cider-inspector--render-value'" + (interactive) + (let ((result (cider-sync-request:inspect-push idx 'v2))) + (when (nrepl-dict-get result "value") + (push (point) cider-inspector-location-stack) + (cider-inspector--render-value result 'v2) + (cider-inspector-next-inspectable-object 1)))) + +(defun cider-inspector-inspect-last-exception (index) + "Inspects the exception in the cause stack identified by INDEX." + (interactive) + (cl-assert (numberp index)) + (setq cider-inspector--current-repl (cider-current-repl)) + (let ((result (cider-sync-request:inspect-last-exception index 'v2))) + (when (nrepl-dict-get result "value") + (push (point) cider-inspector-location-stack) + (cider-inspector--render-value result 'v2) + (cider-inspector-next-inspectable-object 1)))) + +(defun cider-inspector-previous-sibling () + "Inspect the previous sibling value within a sequential parent. +See `cider-sync-request:inspect-previous-sibling' and `cider-inspector--render-value'" + (interactive) + (let ((result (cider-sync-request:inspect-previous-sibling 'v2))) + (when (nrepl-dict-get result "value") + (push (point) cider-inspector-location-stack) + (cider-inspector--render-value result 'v2) + (cider-inspector-next-inspectable-object 1)))) + +(defun cider-inspector-next-sibling () + "Inspect the next sibling value within a sequential parent. +See `cider-sync-request:inspect-next-sibling' and `cider-inspector--render-value'" + (interactive) + (let ((result (cider-sync-request:inspect-next-sibling 'v2))) + (when (nrepl-dict-get result "value") + (push (point) cider-inspector-location-stack) + (cider-inspector--render-value result 'v2) + (cider-inspector-next-inspectable-object 1)))) + +(defun cider-inspector--refresh-with-opts (&rest opts) + "Invokes `inspect-refresh' op with supplied extra OPTS. +Re-renders the currently inspected value." + (let ((result (cider-nrepl-send-sync-request `("op" "inspect-refresh" ,@opts) + cider-inspector--current-repl))) + (when (nrepl-dict-get result "value") + (cider-inspector--render-value result 'v2)))) + +(defun cider-inspector-refresh () + "Re-render the currently inspected value. +See `cider-sync-request:inspect-refresh' and `cider-inspector--render-value'" + (interactive) + (cider-inspector--refresh-with-opts)) + +(defun cider-inspector-next-page () + "Jump to the next page when inspecting a paginated sequence/map. + +Does nothing if already on the last page." + (interactive) + (push (point) cider-inspector-page-location-stack) + (let ((result (cider-sync-request:inspect-next-page 'v2))) + (when (nrepl-dict-get result "value") + (cider-inspector--render-value result 'v2)))) + +(defun cider-inspector-prev-page () + "Jump to the previous page when expecting a paginated sequence/map. + +Does nothing if already on the first page." + (interactive) + (setq cider-inspector-last-command 'cider-inspector-prev-page) + (let ((result (cider-sync-request:inspect-prev-page 'v2))) + (when (nrepl-dict-get result "value") + (cider-inspector--render-value result 'v2)))) + +(defun cider-inspector-set-page-size (page-size) + "Set the page size in pagination mode to the specified PAGE-SIZE. + +Current page will be reset to zero." + (interactive (list (read-number "Page size: " cider-inspector-page-size))) + (cider-inspector--refresh-with-opts "page-size" page-size)) + +(defun cider-inspector-set-max-atom-length (max-length) + "Set the max length of nested atoms to MAX-LENGTH." + (interactive (list (read-number "Max atom length: " cider-inspector-max-atom-length))) + (cider-inspector--refresh-with-opts "max-atom-length" max-length)) + +(defun cider-inspector-set-max-coll-size (max-size) + "Set the number of nested collection members to display before truncating. +MAX-SIZE is the new value." + (interactive (list (read-number "Max collection size: " cider-inspector-max-coll-size))) + (cider-inspector--refresh-with-opts "max-coll-size" max-size)) + +(defun cider-inspector-set-max-nested-depth (max-nested-depth) + "Set the level of nesting for collections to display beflore truncating. +MAX-NESTED-DEPTH is the new value." + (interactive (list (read-number "Max nested depth: " cider-inspector-max-nested-depth))) + (cider-inspector--refresh-with-opts "max-nested-depth" max-nested-depth)) + +(defun cider-inspector-toggle-view-mode () + "Toggle the view mode of the inspector between normal and object view mode." + (interactive) + (let ((result (cider-nrepl-send-sync-request `("op" "inspect-toggle-view-mode") + cider-inspector--current-repl))) + (when (nrepl-dict-get result "value") + (cider-inspector--render-value result 'v2)))) + +(defcustom cider-inspector-preferred-var-names nil + "The preferred var names to be suggested by `cider-inspector-def-current-val'. + +If you choose a different one while completing interactively, +it will be included (in the first position) the next time +you use `cider-inspector-def-current-val'." + :type '(repeat string) + :group 'cider + :package-version '(cider . "1.8.0")) + +(defun cider-inspector--read-var-name-from-user (ns) + "Reads a var name from the user, to be defined within NS. +Grows `cider-inspector-preferred-var-names' if the user chose a new name, +making that new name take precedence for subsequent usages." + (let ((v (completing-read (format "Name of the var to be defined in ns %s: " ns) + cider-inspector-preferred-var-names))) + (unless (member v cider-inspector-preferred-var-names) + (setq cider-inspector-preferred-var-names (cons v cider-inspector-preferred-var-names))) + v)) + +(defun cider-inspector-def-current-val (var-name ns) + "Defines a var with VAR-NAME in current namespace. + +Doesn't modify current page. When called interactively NS defaults to +current-namespace." + (interactive (let ((ns (cider-current-ns))) + (list (cider-inspector--read-var-name-from-user ns) + ns))) + (when-let* ((result (cider-sync-request:inspect-def-current-val ns var-name 'v2))) + (cider-inspector--render-value result 'v2) + (message "Defined current inspector value as #'%s/%s" ns var-name))) + +(defun cider-inspector-tap-current-val () + "Sends the current Inspector current value to `tap>'." + (interactive) + ;; NOTE: we don't set `cider-inspector--current-repl', because we mean to tap the current value of an existing Inspector, + ;; so whatever repl was used for it, should be used here. + (if cider-inspector--current-repl + (let ((response (cider-sync-request:inspect-tap-current-val))) + (nrepl-dbind-response response (value err) + (if value + (message "Successfully tapped the current Inspector value") + (error "Could not tap the current Inspector value: %s" err)))) + (user-error "No CIDER session found"))) + +(defun cider-inspector-tap-at-point () + "Sends the current Inspector current sub-value (per POINT) to `tap>'." + (interactive) + ;; NOTE: we don't set `cider-inspector--current-repl', because we mean to tap the current value of an existing Inspector, + ;; so whatever repl was used for it, should be used here. + (if cider-inspector--current-repl + (seq-let (property value) (cider-inspector-property-at-point) + (pcase property + (`cider-value-idx + (let* ((idx value) + (response (cider-sync-request:inspect-tap-indexed idx))) + (nrepl-dbind-response response (value err) + (if value + (message "Successfully tapped the Inspector item at point") + (error "Could not tap the Inspector item at point: %s" err))))) + (_ (error "No object at point")))) + (user-error "No CIDER session found"))) + +;; nREPL interactions +(defun cider-sync-request:inspect-pop (&optional v2) + "Move one level up in the inspector stack, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (let ((result (thread-first '("op" "inspect-pop") + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-push (idx &optional v2) + "Inspect the inside value specified by IDX, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (let ((result (thread-first `("op" "inspect-push" + "idx" ,idx) + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-previous-sibling (&optional v2) + "Inspect the previous sibling value within a sequential parent, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (let ((result (thread-first `("op" "inspect-previous-sibling") + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +;;;###autoload +(defun cider-sync-request:inspect-last-exception (index &optional v2) + "Inspects the exception in the cause stack identified by INDEX, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (cl-assert (numberp index)) + (let ((result (thread-first `("op" "inspect-last-exception" + "index" ,index) + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-next-sibling (&optional v2) + "Inspect the next sibling value within a sequential parent, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (let ((result (thread-first `("op" "inspect-next-sibling") + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-refresh (&optional v2) + "Re-render the currently inspected value, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (let ((result (thread-first '("op" "inspect-refresh") + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-next-page (&optional v2) + "Jump to the next page in paginated collection view, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (let ((result (thread-first '("op" "inspect-next-page") + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-prev-page (&optional v2) + "Jump to the previous page in paginated collection view, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (let ((result (thread-first '("op" "inspect-prev-page") + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-set-page-size (page-size &optional v2) + "Set the page size in paginated view to PAGE-SIZE, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (declare (obsolete "use `inspect-refresh' op instead." "1.15.0")) + (let ((result (thread-first `("op" "inspect-set-page-size" + "page-size" ,page-size) + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-set-max-atom-length (max-length &optional v2) + "Set the max length of nested atoms to MAX-LENGTH, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (declare (obsolete "use `inspect-refresh' op instead." "1.15.0")) + (let ((result (thread-first `("op" "inspect-set-max-atom-length" + "max-atom-length" ,max-length) + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-set-max-coll-size (max-size &optional v2) + "Set the number of nested collection members to display before truncating. +MAX-SIZE is the new value, V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (declare (obsolete "use `inspect-refresh' op instead." "1.15.0")) + (let ((result (thread-first `("op" "inspect-set-max-coll-size" + "max-coll-size" ,max-size) + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-set-max-nested-depth (max-nested-depth &optional v2) + "Set the level of nesting for collections to display before truncating. +MAX-NESTED-DEPTH is the new value, V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (declare (obsolete "use `inspect-refresh' op instead." "1.15.0")) + (let ((result (thread-first `("op" "inspect-set-max-nested-depth" + "max-nested-depth" ,max-nested-depth) + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-def-current-val (ns var-name &optional v2) + "Defines a var with VAR-NAME in NS with the current inspector value, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (let ((result (thread-first `("op" "inspect-def-current-value" + "ns" ,ns + "var-name" ,var-name) + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(defun cider-sync-request:inspect-tap-current-val () + "Sends current inspector value to tap>." + (cider-nrepl-send-sync-request '("op" "inspect-tap-current-value") cider-inspector--current-repl)) + +(defun cider-sync-request:inspect-tap-indexed (idx) + "Sends current inspector sub-value to tap>, per IDX." + (cl-assert idx) + (cider-nrepl-send-sync-request `("op" "inspect-tap-indexed" + "idx" ,idx) + cider-inspector--current-repl)) + +(defun cider-sync-request:inspect-expr (expr ns &optional v2) + "Evaluate EXPR in context of NS and inspect its result. +Set the page size in paginated view to PAGE-SIZE, maximum length of atomic +collection members to MAX-ATOM-LENGTH, and maximum size of nested collections to +MAX-COLL-SIZE if non nil, +V2 indicates if the entire response should be returned +instead of just its \"value\" entry." + (let ((result (thread-first + (append (nrepl--eval-request expr ns) + `("inspect" "true" + ,@(when cider-inspector-page-size + `("page-size" ,cider-inspector-page-size)) + ,@(when cider-inspector-max-atom-length + `("max-atom-length" ,cider-inspector-max-atom-length)) + ,@(when cider-inspector-max-coll-size + `("max-coll-size" ,cider-inspector-max-coll-size)) + ,@(when cider-inspector-max-nested-depth + `("max-nested-depth" ,cider-inspector-max-nested-depth)) + "spacious" ,(if cider-inspector-spacious-collections + "true" "false"))) + (cider-nrepl-send-sync-request cider-inspector--current-repl)))) + (if v2 + result + (nrepl-dict-get result "value")))) + +(declare-function cider-set-buffer-ns "cider-mode") + +;; Render Inspector from Structured Values +(defun cider-inspector--render-value (dict-or-value &optional v2) + "Render DICT-OR-VALUE, depending on V2." + (let* ((value (if v2 + (nrepl-dict-get dict-or-value "value") + dict-or-value)) + (fragments (when v2 + (nrepl-dict-get dict-or-value "doc-fragments"))) + (block-tags (when v2 + (nrepl-dict-get dict-or-value "doc-block-tags-fragments"))) + (ns (cider-current-ns)) + (font-size (when-let* ((b (get-buffer cider-inspector-buffer)) + (variable 'text-scale-mode-amount) + (continue (local-variable-p variable b))) + ;; The font size is lost between inspector 'screens', + ;; because on each re-rendering, we wipe everything, including the mode. + ;; Enabling cider-inspector-mode is the specific step that loses the font size. + (buffer-local-value variable b))) + (truncate-lines-defined (when-let* ((b (get-buffer cider-inspector-buffer))) + (local-variable-p 'truncate-lines b))) + (truncate-lines-p (when-let* ((b (get-buffer cider-inspector-buffer)) + (continue truncate-lines-defined)) + (buffer-local-value 'truncate-lines b)))) + (cider-make-popup-buffer cider-inspector-buffer 'cider-inspector-mode 'ancillary) + (cider-inspector-render cider-inspector-buffer value + :font-size font-size + :truncate-lines-defined truncate-lines-defined + :truncate-lines-p truncate-lines-p + :fragments fragments + :block-tags block-tags) + (cider-popup-buffer-display cider-inspector-buffer cider-inspector-auto-select-buffer) + (when cider-inspector-fill-frame (delete-other-windows)) + (ignore-errors (cider-inspector-next-inspectable-object 1)) + (with-current-buffer cider-inspector-buffer + (cider-set-buffer-ns ns) + (when (eq cider-inspector-last-command 'cider-inspector-pop) + (setq cider-inspector-last-command nil) + ;; Prevents error message being displayed when we try to pop + ;; from the top-level of a data structure + (when cider-inspector-location-stack + (goto-char (pop cider-inspector-location-stack)))) + + (when (eq cider-inspector-last-command 'cider-inspector-prev-page) + (setq cider-inspector-last-command nil) + ;; Prevents error message being displayed when we try to + ;; go to a prev-page from the first page + (when cider-inspector-page-location-stack + (goto-char (pop cider-inspector-page-location-stack))))))) + +(cl-defun cider-inspector-render (buffer str &key font-size truncate-lines-defined truncate-lines-p fragments block-tags) + "Render STR in BUFFER." + (with-current-buffer buffer + (cider-inspector-mode) + (when font-size + (text-scale-set font-size)) + (when truncate-lines-defined + (setq-local truncate-lines truncate-lines-p)) + (let ((inhibit-read-only t)) + (condition-case nil + (cider-inspector-render* (car (read-from-string str)) + fragments + block-tags) + (error (insert "\nInspector error for: " str)))) + (goto-char (point-min)))) + +(defvar cider-inspector-looking-at-java-p nil) + +(defun cider-inspector-render* (elements &optional fragments block-tags) + "Render ELEMENTS, and FRAGMENTS, BLOCK-TAGS if present." + (setq cider-inspector-looking-at-java-p nil) + (dolist (el elements) + (cider-inspector-render-el* el)) + (when fragments + (insert "\n\n") + (insert (cider--render-docstring (list "doc-fragments" fragments + "doc-block-tags-fragments" block-tags))))) + +(defconst cider--inspector-java-headers + ;; NOTE "--- Static fields:" "--- Instance fields:" are for objects, + ;; and don't deserve Java syntax highlighting (they can contain a Clojure value like `:foo/bar`, for instance) + '("--- Interfaces:" + "--- Fields:" ;; rendered only for Class objects (and not other objects) - see previous comment + "--- Constructors:" + "--- Methods:" + "--- Imports:")) + +(defun cider-inspector-render-el* (el) + "Render EL." + (let ((header-p (or (member el cider--inspector-java-headers) + (and (stringp el) + (string-prefix-p "--- " el))))) + ;; Headers reset the Java syntax coloring: + (when header-p + (setq cider-inspector-looking-at-java-p nil)) + + (cond ((symbolp el) (insert (symbol-name el))) + ((stringp el) (insert (if cider-inspector-looking-at-java-p + (cider-font-lock-as 'java-mode el) + (let ((trimmed-el (replace-regexp-in-string (regexp-quote "") + "" + el))) + (propertize trimmed-el 'font-lock-face (if header-p + 'font-lock-comment-face + 'font-lock-keyword-face)))))) + ((and (consp el) (eq (car el) :newline)) + (insert "\n")) + ((and (consp el) (eq (car el) :value)) + (cider-inspector-render-value (cadr el) (cl-caddr el))) + (t (message "Unrecognized inspector object: %s" el)))) + + ;; Java-related headers indicate that the next elements to be rendered + ;; should be syntax-colored as Java: + (when (member el cider--inspector-java-headers) + (setq cider-inspector-looking-at-java-p t))) + +(defun cider-inspector-render-value (value idx) + "Render VALUE at IDX." + (cider-propertize-region + (list 'cider-value-idx idx + 'mouse-face 'highlight) + (cider-inspector-render-el* (cider-font-lock-as-clojure value)))) + + +;; =================================================== +;; Inspector Navigation (lifted from SLIME inspector) +;; =================================================== + +(defun cider-find-inspectable-object (direction limit) + "Find the next/previous inspectable object. +DIRECTION can be either 'next or 'prev. +LIMIT is the maximum or minimum position in the current buffer. + +Return a list of two values: If an object could be found, the +starting position of the found object and T is returned; +otherwise LIMIT and NIL is returned." + (let ((finder (cl-ecase direction + (next 'next-single-property-change) + (prev 'previous-single-property-change)))) + (let ((prop nil) (curpos (point))) + (while (and (not prop) (not (= curpos limit))) + (let ((newpos (funcall finder curpos 'cider-value-idx nil limit))) + (setq prop (get-text-property newpos 'cider-value-idx)) + (setq curpos newpos))) + (list curpos (and prop t))))) + +(defun cider-inspector-next-inspectable-object (arg) + "Move point to the next inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move backwards." + (interactive "p") + (let ((maxpos (point-max)) (minpos (point-min)) + (previously-wrapped-p nil)) + ;; Forward. + (while (> arg 0) + (seq-let (pos foundp) (cider-find-inspectable-object 'next maxpos) + (if foundp + (progn (goto-char pos) + (unless (and cider-inspector-skip-uninteresting + (looking-at-p cider-inspector-uninteresting-regexp)) + (setq arg (1- arg)) + (setq previously-wrapped-p nil))) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char minpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))) + ;; Backward. + (while (< arg 0) + (seq-let (pos foundp) (cider-find-inspectable-object 'prev minpos) + ;; CIDER-OPEN-INSPECTOR inserts the title of an inspector page + ;; as a presentation at the beginning of the buffer; skip + ;; that. (Notice how this problem can not arise in ``Forward.'') + (if (and foundp (/= pos minpos)) + (progn (goto-char pos) + (unless (and cider-inspector-skip-uninteresting + (looking-at-p cider-inspector-uninteresting-regexp)) + (setq arg (1+ arg)) + (setq previously-wrapped-p nil))) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char maxpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))))) + +(defun cider-inspector-previous-inspectable-object (arg) + "Move point to the previous inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move forwards." + (interactive "p") + (cider-inspector-next-inspectable-object (- arg))) + +(defun cider-inspector-property-at-point () + "Return property at point." + (let* ((properties '(cider-value-idx cider-range-button + cider-action-number)) + (find-property + (lambda (point) + (cl-loop for property in properties + for value = (get-text-property point property) + when value + return (list property value))))) + (or (funcall find-property (point)) + (funcall find-property (max (point-min) (1- (point))))))) + +(defun cider-inspector-operate-on-point () + "Invoke the command for the text at point. +1. If point is on a value then recursively call the inspector on +that value. +2. If point is on an action then call that action. +3. If point is on a range-button fetch and insert the range." + (interactive) + (seq-let (property value) (cider-inspector-property-at-point) + (pcase property + (`cider-value-idx + (cider-inspector-push value)) + ;; TODO: range and action handlers + (_ (error "No object at point"))))) + +(defun cider-inspector-operate-on-click (event) + "Move to EVENT's position and operate the part." + (interactive "@e") + (let ((point (posn-point (event-end event)))) + (cond ((and point + (or (get-text-property point 'cider-value-idx))) + (goto-char point) + (cider-inspector-operate-on-point)) + (t + (error "No clickable part here"))))) + +(provide 'cider-inspector) + +;;; cider-inspector.el ends here diff --git a/elpa/cider-20241203.1607/cider-jar.el b/elpa/cider-20241203.1607/cider-jar.el new file mode 100644 index 00000000..006ad7ec --- /dev/null +++ b/elpa/cider-20241203.1607/cider-jar.el @@ -0,0 +1,141 @@ +;;; cider-jar.el --- Jar functionality for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2022-2024 Arne Brasseur +;; +;; Author: Arne Brasseur + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Dealing with JAR (Java archive) files, which are really just zip files in +;; disguise. In particular downloading and retrieving the cider-nrepl jar. + +;;; Code: + +(require 'url) +(require 'arc-mode) +(require 'map) + + +(defvar cider-jar-cache-dir (expand-file-name "cider-cache" user-emacs-directory) + "Location where we store downloaded files for later use.") + +(defvar cider-jar-content-cache (make-hash-table :test #'equal) + "Nested hash table of jar-path -> file-path -> bool. +This provides an efficient check to see if a file exists in a jar or not.") + +(defun cider-jar-clojars-url (group artifact version) + "URL to download a specific jar from Clojars. +GROUP, ARTIFACT, and VERSION are the components of the Maven coordinates." + (concat "https://repo.clojars.org/" group "/" artifact "/" + version + "/cider-nrepl-" + version + ".jar")) + +(defun cider-jar-find-or-fetch (group artifact version) + "Download the given jar off clojars and cache it. + +GROUP, ARTIFACT, and VERSION are the components of the Maven coordinates. +Returns the path to the jar." + (let* ((m2-path (expand-file-name (concat "~/.m2/repository/" group "/" artifact "/" version "/" artifact "-" version ".jar"))) + (clojars-url (cider-jar-clojars-url group artifact version)) + (cache-path (expand-file-name (replace-regexp-in-string "https://" "" clojars-url) cider-jar-cache-dir))) + (cond + ((file-exists-p m2-path) m2-path) + ((file-exists-p cache-path) cache-path) + (t + (make-directory (file-name-directory cache-path) t) + (url-copy-file clojars-url cache-path) + cache-path)))) + +(defun cider-jar--archive-zip-summarize () + "Forked version of `archive-zip-summarize'. +Only read the information we need, and be version independent." + (goto-char (- (point-max) (- 22 18))) + (search-backward-regexp "[P]K\005\006") + (let ((p (archive-l-e (+ (point) 16) 4)) + files) + (when (or (= p #xffffffff) (= p -1)) + ;; If the offset of end-of-central-directory is 0xFFFFFFFF, this + ;; is a Zip64 extended ZIP file format, and we need to glean the + ;; info from Zip64 records instead. + ;; + ;; First, find the Zip64 end-of-central-directory locator. + (search-backward "PK\006\007") + (setq p (+ (point-min) + (archive-l-e (+ (point) 8) 8))) + (goto-char p) + ;; We should be at Zip64 end-of-central-directory record now. + (or (string= "PK\006\006" (buffer-substring p (+ p 4))) + (error "Unrecognized ZIP file format")) + ;; Offset to central directory: + (setq p (archive-l-e (+ p 48) 8))) + (setq p (+ p (point-min))) + (while (string= "PK\001\002" (buffer-substring p (+ p 4))) + (let* ((fnlen (archive-l-e (+ p 28) 2)) + (exlen (archive-l-e (+ p 30) 2)) + (fclen (archive-l-e (+ p 32) 2)) + (efnname (let ((str (buffer-substring (+ p 46) (+ p 46 fnlen)))) + (decode-coding-string + str archive-file-name-coding-system)))) + (setq files (cons efnname files) + p (+ p 46 fnlen exlen fclen)))) + files)) + +(defun cider-jar-contents (jarfile) + "Get the list of filenames in a jar (or zip) file. +JARFILE is the location of the archive." + (with-temp-buffer + (set-buffer-multibyte nil) + (setq buffer-file-coding-system 'binary) + (insert-file-contents-literally jarfile nil) + (cider-jar--archive-zip-summarize))) + +(defun cider-jar-contents-cached (jarfile) + "Like cider-jar-contents, but cached. + +Instead of returning a list of strings this returns a hash table of string +keys and values `t`, for quick lookup. JARFILE is the location of the +archive." + (let ((m (map-elt cider-jar-content-cache jarfile))) + (if m + m + (let ((m (make-hash-table :test #'equal))) + (seq-do (lambda (path) + (puthash path t m)) + (cider-jar-contents jarfile)) + (puthash jarfile m cider-jar-content-cache) + m)))) + +(defun cider-jar-contains-p (jarfile name) + "Does the JARFILE contain a file with the given NAME?" + (map-elt (cider-jar-contents-cached jarfile) name)) + +(defun cider-jar-retrieve-resource (jarfile name) + "Extract a file NAME from a JARFILE as a string." + (make-directory archive-tmpdir :make-parents) + (when (cider-jar-contains-p jarfile name) + (let ((default-directory archive-tmpdir)) + (with-temp-buffer + (set-buffer-multibyte nil) + (setq buffer-file-coding-system 'binary) + (archive-zip-extract jarfile name) + (buffer-substring-no-properties (point-min) (point-max)))))) + +(provide 'cider-jar) +;;; cider-jar.el ends here diff --git a/elpa/cider-20241203.1607/cider-log.el b/elpa/cider-20241203.1607/cider-log.el new file mode 100644 index 00000000..4f01f41c --- /dev/null +++ b/elpa/cider-20241203.1607/cider-log.el @@ -0,0 +1,1515 @@ +;;; cider-log.el --- Log inspection functionality for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2023-2024 Bozhidar Batsov and CIDER contributors + +;; Author: r0man + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Log inspection functionality for Clojure. +;; +;; Please, refer to the online documentation for more details +;; https://docs.cider.mx/cider/debugging/logging.html. + +;;; Code: + +(require 'cider-inspector) +(require 'cider-stacktrace) +(require 'cl-lib) +(require 'logview nil t) +(require 'org) +(require 'seq) +(require 'transient) + +(defcustom cider-log-framework-name nil + "The name of the default log framework. + +You may want to set this in .dir-locals.el, +for a more streamlined setup. + +Example values: \"Logback\", \"Timbre\"." + :group 'cider + :package-version '(cider . "1.8.0") + :safe #'stringp + :type 'string) + +(defcustom cider-log-frameworks-buffer "*cider-log-frameworks*" + "The name of the log frameworks popup buffer." + :group 'cider + :package-version '(cider . "1.17") + :safe #'stringp + :type 'string) + +(defcustom cider-log-auto-select-frameworks-buffer t + "Whether to auto-select the log frameworks popup buffer." + :group 'cider + :package-version '(cider . "1.17") + :safe #'booleanp + :type 'boolean) + +(defcustom cider-log-appender-id "cider-log" + "The name of the default log appender." + :group 'cider + :package-version '(cider . "1.8.0") + :safe #'stringp + :type 'string) + +(defcustom cider-log-buffer "*cider-log*" + "The name of the log buffer." + :group 'cider + :package-version '(cider . "1.8.0") + :safe #'stringp + :type 'string) + +(defcustom cider-log-event-buffer "*cider-log-event*" + "The name of the log event buffer." + :group 'cider + :package-version '(cider . "1.8.0") + :safe #'stringp + :type 'string) + +(defcustom cider-log-max-message-length 500 + "The maximum length of the log message to display." + :group 'cider + :package-version '(cider . "1.8.0") + :safe #'integerp + :type 'integer) + +(defcustom cider-log-pagination-limit 250 + "The maximum number of log events to return when searching events." + :group 'cider + :package-version '(cider . "1.8.0") + :safe #'integerp + :type 'integer) + +(defcustom cider-log-pagination-offset 0 + "The offset from which to return results when searching events." + :group 'cider + :package-version '(cider . "1.8.0") + :safe #'integerp + :type 'integer) + +(defcustom cider-log-use-logview t + "Whether to use `logview-mode'. + +It will not be used if the package hasn't been installed." + :group 'cider + :package-version '(cider . "1.8.0") + :safe #'booleanp + :type 'boolean) + +(defun cider-log-use-logview () + "Whether to use `logview-mode'." + (and (fboundp 'logview-mode) + cider-log-use-logview)) + +(defvar logview-mode-map) +(declare-function logview--guess-submode "logview" () t) +(declare-function logview-initialized-p "logview" () t) +(declare-function logview-mode "logview" () t) + +(defvar cider-log--initialized-once-p nil + "Set to t if log framework and appender have been initialized once.") + +(defvar cider-log-framework nil + "The current log framework to use.") + +(defvar cider-log-appender nil + "The current log appender.") + +(defvar cider-log-appender-size 100000 + "The size of the log appender.") + +(defvar cider-log-appender-threshold 10 + "The threshold in percent of the log appender.") + +(defvar-local cider-log-consumer nil + "The current log consumer.") + +;; Filters + +(defvar cider-log--end-time-filter nil) +(defvar cider-log--exceptions-filter nil) +(defvar cider-log--level-filter nil) +(defvar cider-log--loggers-filter nil) +(defvar cider-log--pattern-filter nil) +(defvar cider-log--start-time-filter nil) +(defvar cider-log--threads-filter nil) + +(defun cider-log--bold (s) + "Return S with a bold face." + (when s (propertize (format "%s" s) 'face 'bold))) + +(defun cider-log-buffer-clear-p (&optional buffer) + "Return non-nil if BUFFER is not empty, otherwise nil." + (when-let (buffer (get-buffer (or buffer cider-log-buffer))) + (> (buffer-size buffer) 0))) + +(defun cider-log--description-clear-events-buffer () + "Return the description for the set framework action." + (format "Clear %s buffer" + (if cider-log-buffer + (cider-log--format-value cider-log-buffer) + (propertize "n/a" 'face 'font-lock-comment-face)))) + +(defun cider-log--description-set-framework () + "Return the description for the set framework action." + (format "Select framework %s" + (if cider-log-framework-name + (cider-log--format-value cider-log-framework-name) + (propertize "n/a" 'face 'font-lock-comment-face)))) + +(defun cider-log--description-set-buffer () + "Return the description for the set buffer action." + (format "Select buffer %s" + (if cider-log-buffer + (cider-log--format-value cider-log-buffer) + (propertize "n/a" 'face 'font-lock-comment-face)))) + +(defun cider-log--buffers-in-major-mode (expected) + "Return all buffers which are in the EXPECTED major mode." + (seq-filter (lambda (buffer) + (with-current-buffer buffer + (equal expected major-mode))) + (buffer-list))) + +(defun cider-log--format-time (time) + "Format TIME in ISO8601 format." + (format-time-string "%FT%T%z" time)) + +(defun cider-log--format-value (value) + "Format the VALUE for display in a transient menu." + (cond ((null value) "") + ((or (listp value) (vectorp value)) + (string-join (seq-map #'cider-log--format-value value) + (propertize ", " 'face 'font-lock-comment-face))) + (t (propertize (format "%s" value) 'face 'transient-value)))) + +(defun cider-log--strip-whitespace (s) + "Replace multiple white space characters in S with a single one." + (replace-regexp-in-string "[\n ]+" " " s)) + +;; NREPL + +(defun cider-request:log-add-consumer (framework appender consumer &optional callback) + "Add CONSUMER to the APPENDER of FRAMEWORK and call CALLBACK on log events." + (cider-ensure-op-supported "cider/log-add-consumer") + (thread-first `("op" "cider/log-add-consumer" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender) + "filters" ,(cider-log-consumer-filters consumer)) + (cider-nrepl-send-request callback))) + +(defun cider-request:log-analyze-stacktrace (framework appender event &optional callback) + "Analyze the EVENT stacktrace of the APPENDER of FRAMEWORK and call CALLBACK." + (cider-ensure-op-supported "cider/log-analyze-stacktrace") + (thread-first `("op" "cider/log-analyze-stacktrace" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender) + "event" ,(cider-log-event-id event)) + (cider-nrepl-send-request callback))) + +(defun cider-sync-request:log-update-consumer (framework appender consumer) + "Add CONSUMER to the APPENDER of FRAMEWORK and call CALLBACK on log events." + (cider-ensure-op-supported "cider/log-update-consumer") + (thread-first `("op" "cider/log-update-consumer" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender) + "consumer" ,(cider-log-consumer-id consumer) + "filters" ,(cider-log-consumer-filters consumer)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-update-consumer"))) + +(defun cider-sync-request:log-add-appender (framework appender) + "Add the APPENDER to the log FRAMEWORK." + (cider-ensure-op-supported "cider/log-add-appender") + (thread-first `("op" "cider/log-add-appender" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender) + "filters" ,(cider-log-appender-filters appender) + "size" ,(cider-log-appender-size appender) + "threshold" ,(cider-log-appender-threshold appender)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-add-appender"))) + +(defun cider-sync-request:log-update-appender (framework appender) + "Update the APPENDER of the log FRAMEWORK." + (cider-ensure-op-supported "cider/log-update-appender") + (thread-first `("op" "cider/log-update-appender" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender) + "filters" ,(cider-log-appender-filters appender) + "size" ,(cider-log-appender-size appender) + "threshold" ,(cider-log-appender-threshold appender)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-update-appender"))) + +(defun cider-sync-request:log-clear (framework appender) + "Clear the log events for FRAMEWORK and APPENDER." + (cider-ensure-op-supported "cider/log-clear-appender") + (thread-first `("op" "cider/log-clear-appender" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-clear-appender"))) + +(defun cider-sync-request:log-inspect-event (framework appender event) + "Inspect the log event with the ID in the APPENDER of the log FRAMEWORK." + (cider-ensure-op-supported "cider/log-inspect-event") + (thread-first `("op" "cider/log-inspect-event" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender) + "event" ,(cider-log-event-id event)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "value"))) + +(defun cider-sync-request:log-format-event (framework appender event) + "Format the log EVENT from the APPENDER of the log FRAMEWORK." + (cider-ensure-op-supported "cider/log-format-event") + (thread-first + (seq-mapcat #'identity + (map-merge 'list + (cider--nrepl-print-request-map fill-column) + `(("op" "cider/log-format-event") + ("framework" ,(cider-log-framework-id framework)) + ("appender" ,(cider-log-appender-id appender)) + ("event" ,(cider-log-event-id event))))) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-format-event"))) + +(defun cider-sync-request:log-frameworks () + "Return the available log frameworks." + (cider-ensure-op-supported "cider/log-frameworks") + (thread-first `("op" "cider/log-frameworks") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-frameworks"))) + +(cl-defun cider-sync-request:log-search (framework appender &key filters limit offset) + "Search log events of FRAMEWORK and APPENDER using FILTERS, LIMIT and OFFSET." + (cider-ensure-op-supported "cider/log-search") + (thread-first `("op" "cider/log-search" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender) + "filters" ,filters + "limit" ,limit + "offset" ,offset) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-search"))) + +(defun cider-sync-request:log-exceptions (framework appender) + "Return the Cider log exceptions for FRAMEWORK and APPENDER." + (cider-ensure-op-supported "cider/log-exceptions") + (thread-first `("op" "cider/log-exceptions" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-exceptions"))) + +(defun cider-sync-request:log-levels (framework appender) + "Return the Cider log levels for FRAMEWORK and APPENDER." + (cider-ensure-op-supported "cider/log-levels") + (thread-first `("op" "cider/log-levels" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-levels"))) + +(defun cider-sync-request:log-loggers (framework appender) + "Return the Cider loggers for FRAMEWORK and APPENDER." + (cider-ensure-op-supported "cider/log-loggers") + (thread-first `("op" "cider/log-loggers" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-loggers"))) + +(defun cider-sync-request:log-remove-appender (framework appender) + "Remove the APPENDER from the log FRAMEWORK." + (cider-ensure-op-supported "cider/log-remove-appender") + (thread-first `("op" "cider/log-remove-appender" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-remove-appender"))) + +(defun cider-sync-request:log-remove-consumer (framework appender consumer) + "Remove the CONSUMER from the APPENDER of the log FRAMEWORK." + (cider-ensure-op-supported "cider/log-remove-consumer") + (thread-first `("op" "cider/log-remove-consumer" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender) + "consumer" ,(cider-log-consumer-id consumer)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-remove-consumer"))) + +(defun cider-sync-request:log-threads (framework appender) + "Return the threads for FRAMEWORK and APPENDER." + (cider-ensure-op-supported "cider/log-threads") + (thread-first `("op" "cider/log-threads" + "framework" ,(cider-log-framework-id framework) + "appender" ,(cider-log-appender-id appender)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "cider/log-threads"))) + +(defun cider-log--completion-extra-properties (keys &optional separator) + "Return the completion properties for NREPL dictionaries. + +The KEYS are used to lookup the values and are joined by SEPARATOR." + `(:annotation-function + ,(lambda (identifier) + (when-let (dict (cadr (assoc identifier minibuffer-completion-table))) + (let ((annotation (string-join (seq-map (lambda (key) (nrepl-dict-get dict key)) keys) + (or separator " ")))) + (unless (string-blank-p annotation) + (propertize (format " - %s" (cider-log--strip-whitespace annotation)) + 'face 'font-lock-comment-face))))))) + +(defun cider-log--read-appender-id (prompt initial-input history) + "Read a appender from the minibuffer using PROMPT, INITIAL-INPUT and HISTORY." + (let ((table (when cider-log-framework + (when-let (framework (cider-log-framework-reload cider-log-framework)) + (seq-map #'cider-log-appender-id (cider-log-framework-appenders framework)))))) + (completing-read (or prompt "Log appender: ") table nil nil + (or initial-input cider-log-appender-id) + history cider-log-appender-id))) + +(defun cider-log--read-buffer (&optional prompt initial-input history) + "Read the log buffer name using PROMPT, INITIAL-INPUT and HISTORY." + (let ((table (seq-map #'buffer-name (cider-log--buffers-in-major-mode 'cider-log-mode)))) + (completing-read (or prompt "Buffer: ") table nil nil + (or initial-input cider-log-buffer) + history cider-log-buffer))) + +(defun cider-log--read-exceptions (&optional prompt initial-input history) + "Read a list of exceptions using PROMPT, INITIAL-INPUT and HISTORY." + (let ((table (when (cider-log-appender-attached-p) + (nrepl-dict-keys (cider-sync-request:log-exceptions + cider-log-framework cider-log-appender))))) + (completing-read-multiple (or prompt "Exceptions: ") table nil nil initial-input history))) + +(defun cider-log--read-framework-name (&optional prompt initial-input history) + "Read a framework name using PROMPT, INITIAL-INPUT and HISTORY." + (let ((completion-extra-properties (cider-log--completion-extra-properties '("name"))) + (frameworks (cider-sync-request:log-frameworks))) + (completing-read (or prompt "Log framework: ") + (seq-map (lambda (framework) + (list (cider-log-framework-name framework) framework)) + frameworks) + nil nil initial-input history))) + +(defun cider-log--read-level (&optional prompt initial-input history) + "Read a log level using PROMPT, INITIAL-INPUT and HISTORY." + (let ((table (when cider-log-framework (cider-log-framework-level-names cider-log-framework)))) + (completing-read (or prompt "Level: ") table nil nil initial-input history))) + +(defun cider-log--read-loggers (&optional prompt initial-input history) + "Read a list of loggers using PROMPT, INITIAL-INPUT and HISTORY." + (let ((table (when (cider-log-appender-attached-p) + (nrepl-dict-keys (cider-sync-request:log-loggers + cider-log-framework cider-log-appender))))) + (completing-read-multiple (or "Loggers: " prompt) table nil nil initial-input history))) + +(defun cider-log--read-number-N0 (&optional prompt initial-input history) + "Read a natural number (including zero) using PROMPT, INITIAL-INPUT and HISTORY." + (when-let (value (transient-read-number-N0 (or prompt "Number: ") initial-input history)) + (string-to-number value))) + +(defun cider-log--read-number-N+ (&optional prompt initial-input history) + "Read a natural number (excluding zero) using PROMPT, INITIAL-INPUT and HISTORY." + (when-let (value (transient-read-number-N+ (or prompt "Number: ") initial-input history)) + (string-to-number value))) + +(defun cider-log--read-threads (&optional prompt initial-input history) + "Read a list of threads using PROMPT, INITIAL-INPUT and HISTORY." + (let ((table (when (cider-log-appender-attached-p) + (nrepl-dict-keys (cider-sync-request:log-threads + cider-log-framework cider-log-appender))))) + (completing-read-multiple (or prompt "Threads: ") table nil nil initial-input history))) + +(defun cider-log--read-time (&optional prompt initial-input _) + "Read a time from the minibuffer using PROMPT and INITIAL-INPUT." + (cider-log--format-time (org-read-date t 'to-time nil prompt nil initial-input))) + +;; Log Framework + +(defun cider-log-framework-appender (framework id) + "Return the appender of the log FRAMEWORK with the given ID." + (seq-find (lambda (appender) (equal id (cider-log-appender-id appender))) + (cider-log-framework-appenders framework))) + +(defun cider-log-framework-appenders (framework) + "Return the appenders of the log FRAMEWORK." + (nrepl-dict-get framework "appenders")) + +(defun cider-log-framework-id (framework) + "Return the id of the log FRAMEWORK." + (nrepl-dict-get framework "id")) + +(defun cider-log-framework-javadoc-url (framework) + "Return the Javadoc URL of the log FRAMEWORK." + (nrepl-dict-get framework "javadoc-url")) + +(defun cider-log-framework-name (framework) + "Return the name of the log FRAMEWORK." + (nrepl-dict-get framework "name")) + +(defun cider-log-framework-level-names (framework) + "Return the log level names of the log FRAMEWORK." + (seq-map (lambda (level) (nrepl-dict-get level "name")) + (nrepl-dict-get framework "levels"))) + +(defun cider-log-framework-website-url (framework) + "Return the website URL of the log FRAMEWORK." + (nrepl-dict-get framework "website-url")) + +(defun cider-log-framework-display-name (framework) + "Return the display name of the log FRAMEWORK." + (cider-log--bold (cider-log-framework-name framework))) + +(defun cider-log-framework-add-appender (framework appender) + "Add the APPENDER to the log FRAMEWORK." + (cider-sync-request:log-add-appender framework appender)) + +(defun cider-log-framework-by-id (frameworks id) + "Find the log framework in FRAMEWORKS by ID." + (seq-find (lambda (framework) (equal id (cider-log-framework-id framework))) frameworks)) + +(defun cider-log-framework-by-name (frameworks name) + "Find the log framework in FRAMEWORKS by NAME." + (seq-find (lambda (framework) (equal name (cider-log-framework-name framework))) frameworks)) + +(defun cider-log-framework-reload (framework) + "Reload the log FRAMEWORK." + (cider-log-framework-by-id + (cider-sync-request:log-frameworks) + (cider-log-framework-id framework))) + +;; Log Appender + +(defun cider-log-appender-attached-p (&optional framework appender) + "Return non-nil if the log APPENDER is attached to FRAMEWORK, otherwise nil." + (when-let ((framework (or framework + (cider-log-framework-by-name + (cider-sync-request:log-frameworks) + cider-log-framework-name))) + (appender-id (if appender + (cider-log-appender-id appender) + cider-log-appender-id))) + (cider-log-framework-appender framework appender-id))) + +(defun cider-log-appender-consumers (appender) + "Return the consumers of the log APPENDER." + (nrepl-dict-get appender "consumers")) + +(defun cider-log-appender-id (appender) + "Return the id of the log APPENDER." + (nrepl-dict-get appender "id")) + +(defun cider-log-appender-size (appender) + "Return the size of the log APPENDER." + (nrepl-dict-get appender "size")) + +(defun cider-log-appender-threshold (appender) + "Return the threshold of the log APPENDER." + (nrepl-dict-get appender "threshold")) + +(defun cider-log-appender-filters (appender) + "Return the filters of the log APPENDER." + (nrepl-dict-get appender "filters")) + +(defun cider-log-appender-display-name (appender) + "Return the display name of the log APPENDER." + (cider-log--bold (cider-log-appender-id appender))) + +(defun cider-log-appender-consumer (appender consumer) + "Find the consumer in the log APPENDER by the id slot of CONSUMER." + (let ((id (cider-log-consumer-id consumer))) + (seq-find (lambda (consumer) (equal id (cider-log-consumer-id consumer))) + (cider-log-appender-consumers appender)))) + +(defun cider-log-appender-reload (framework appender) + "Reload the APPENDER of the log FRAMEWORK." + (when-let (framework (cider-log-framework-reload framework)) + (cider-log-framework-appender framework (cider-log-appender-id appender)))) + +;; Log Consumer + +(defun cider-log-consumer-attached-p (&optional framework appender consumer) + "Return non-nil if the CONSUMER is attached to the APPENDER of FRAMEWORK." + (when-let ((framework (or framework cider-log-framework)) + (appender (or appender cider-log-appender)) + (consumer (or consumer cider-log-consumer))) + (cider-log-consumer-reload framework appender consumer))) + +(defun cider-log-consumer-id (consumer) + "Return the id of the log CONSUMER." + (nrepl-dict-get consumer "id")) + +(defun cider-log-consumer-filters (consumer) + "Return the filters of the log CONSUMER." + (nrepl-dict-get consumer "filters")) + +(defun cider-log-consumer-buffers (consumer) + "Find all buffers in which `cider-log-consumer' is bound to CONSUMER." + (seq-filter (lambda (buffer) + (with-current-buffer buffer + (and (nrepl-dict-p cider-log-consumer) + (equal (cider-log-consumer-id consumer) + (cider-log-consumer-id cider-log-consumer))))) + (buffer-list))) + +(defun cider-log-consumer-display-name (consumer) + "Return the display name of the log CONSUMER." + (cider-log--bold (cider-log-consumer-id consumer))) + +(defun cider-log-consumer-reload (framework appender consumer) + "Reload the CONSUMER attached to APPENDER of the log FRAMEWORK." + (when-let (appender (cider-log-appender-reload framework appender)) + (cider-log-appender-consumer appender consumer))) + +(declare-function cider-log-mode "cider-log") + +(defun cider-log--consumer-add (framework appender consumer buffer) + "Add the CONSUMER to the APPENDER of FRAMEWORK and write events to BUFFER." + (cider-request:log-add-consumer + framework appender consumer + (lambda (msg) + (nrepl-dbind-response msg (cider/log-add-consumer cider/log-consumer cider/log-event status) + (cond ((member "done" status) + (with-current-buffer (get-buffer-create buffer) + (setq-local cider-log-framework framework) + (setq-local cider-log-appender appender) + (setq cider-log-consumer cider/log-add-consumer) + (switch-to-buffer buffer) + (when (and cider-log-use-logview + (not (fboundp 'logview-mode))) + (message "[CIDER Log Mode] Please install the Logview package for best results.") + (cider--display-interactive-eval-result "Please install the Logview package for best results." + 'error + (point) + 'cider-error-overlay-face)))) + ((member "cider/log-event" status) + (let* ((consumer (nrepl-dict "id" cider/log-consumer)) + (buffers (cider-log-consumer-buffers consumer))) + (when (seq-empty-p buffers) + (message "WARNING: No buffers found for %s log consumer %s of appender %s." + (cider-log-framework-display-name framework) + (cider-log-consumer-display-name consumer) + (cider-log-appender-display-name appender)) + (cider-sync-request:log-remove-consumer framework appender consumer)) + (seq-doseq (buffer buffers) + (with-current-buffer buffer + (cider-log--insert-events buffer (list cider/log-event)) + (when (and (cider-log-use-logview) + (not (logview-initialized-p))) + (let ((framework cider-log-framework) + (appender cider-log-appender) + (consumer cider-log-consumer)) + (logview--guess-submode) + (cider-log-mode) + ;; Restore buffer local vars reset by calling major mode. + (setq-local cider-log-framework framework + cider-log-appender appender + cider-log-consumer consumer)))))))))))) + +(defun cider-log--remove-current-buffer-consumer () + "Cleanup the log consumer of the current buffer." + (when-let ((framework cider-log-framework) + (appender cider-log-appender) + (consumer cider-log-consumer)) + (setq-local cider-log-consumer nil) + (when-let (consumer (cider-log-consumer-reload framework appender consumer)) + (cider-sync-request:log-remove-consumer framework appender consumer) + consumer))) + +;; Event + +(defun cider-log-event-id (event) + "Return the id of the log EVENT." + (nrepl-dict-get event "id")) + +(defun cider-log-event-exception (event) + "Return the exception of the log EVENT." + (nrepl-dict-get event "exception")) + +(defun cider-log-event--format-logback (event) + "Format the log EVENT in logview's Logback format." + (nrepl-dbind-response event (_exception level logger message thread timestamp) + (propertize (format "%s [%s] %s %s - %s\n" + (if (numberp timestamp) + (format-time-string "%F %T.%3N" (/ timestamp 1000)) + (format "%s" timestamp)) + thread + (upcase level) + logger + (if (and (stringp message) + (numberp cider-log-max-message-length)) + (substring message 0 (min (length message) cider-log-max-message-length)) + "")) + :cider-log-event event))) + +(defun cider-log-event--pretty-print (framework appender event) + "Format the log EVENT of FRAMEWORK and APPENDER." + (when-let (event (cider-sync-request:log-format-event framework appender event)) + (cider-popup-buffer cider-log-event-buffer cider-auto-select-error-buffer + 'clojure-mode 'ancillary) + (with-current-buffer cider-log-event-buffer + (let ((inhibit-read-only t)) + (erase-buffer) + (insert event) + (goto-char (point-min)))))) + +(defun cider-log-event--inspect (framework appender event) + "Inspect the log EVENT of FRAMEWORK and APPENDER." + (thread-last (cider-sync-request:log-inspect-event framework appender event) + (cider-inspector--render-value))) + +(defun cider-log--insert-events (buffer events) + "Insert the log EVENTS into BUFFER." + (with-current-buffer (get-buffer-create buffer) + (let ((windows (seq-filter (lambda (window) (= (window-point window) (point-max))) + (get-buffer-window-list buffer)))) + (save-excursion + (let ((inhibit-read-only t)) + (goto-char (point-max)) + (seq-doseq (event events) + (insert (cider-log-event--format-logback event))))) + (seq-doseq (window windows) + (set-window-point window (point-max)))))) + +(defun cider-log-event--show-stacktrace (framework appender event) + "Show the stacktrace of the log EVENT of FRAMEWORK and APPENDER." + (when (and framework appender event (cider-log-event-exception event)) + (let ((auto-select-buffer cider-auto-select-error-buffer) + (causes nil)) + (cider-request:log-analyze-stacktrace + framework appender event + (lambda (response) + (nrepl-dbind-response response (class status) + (cond (class (setq causes (cons response causes))) + (status (when causes + (cider-stacktrace-render + (cider-popup-buffer cider-error-buffer + auto-select-buffer + #'cider-stacktrace-mode + 'ancillary) + (reverse causes))))))))))) + +(defun cider-log-event-next-line (&optional n) + "Move N lines forward." + (interactive "p") + (let ((n (or n 1))) + (forward-line n) + (beginning-of-line) + (when-let ((framework cider-log-framework) + (appender cider-log-appender) + (event (cider-log-event-at-point))) + (let ((cider-auto-select-error-buffer nil)) + (save-window-excursion + (when (get-buffer-window cider-error-buffer) + (cider-log-event--show-stacktrace framework appender event)) + (when (get-buffer-window cider-inspector-buffer) + (cider-log-event--inspect framework appender event)) + (when (get-buffer-window cider-log-event-buffer) + (cider-log-event--pretty-print framework appender event))))))) + +(defun cider-log-event-previous-line (&optional n) + "Move N lines backward." + (interactive "p") + (cider-log-event-next-line (- (or n 1)))) + +(defun cider-log--set-filters (filters) + "Set the filter variables from the NREPL dict FILTERS." + (when filters + (setq cider-log--end-time-filter (nrepl-dict-get filters "end-time") + cider-log--exceptions-filter (nrepl-dict-get filters "exceptions") + cider-log--level-filter (nrepl-dict-get filters "level") + cider-log--loggers-filter (nrepl-dict-get filters "loggers") + cider-log--pattern-filter (nrepl-dict-get filters "pattern") + cider-log--start-time-filter (nrepl-dict-get filters "start-time") + cider-log--threads-filter (nrepl-dict-get filters "threads")))) + +(defun cider-log--ensure-initialized (framework &optional appender consumer) + "Ensure that the given FRAMEWORK, APPENDER and CONSUMER are initialized." + (setq cider-log-framework framework + cider-log-framework-name (cider-log-framework-name framework)) + (when appender + (setq cider-log-appender appender + cider-log-appender-id (cider-log-appender-id appender) + cider-log-appender-size (cider-log-appender-size appender) + cider-log-appender-threshold (cider-log-appender-threshold appender)) + (cider-log--set-filters (cider-log-appender-filters appender))) + (when consumer + (setq cider-log-consumer consumer) + (cider-log--set-filters (cider-log-consumer-filters appender))) + (when (and appender (not cider-log--initialized-once-p)) + (unless (cider-log-appender-reload framework appender) + (setq cider-log-appender (cider-sync-request:log-add-appender framework appender)) + (setq cider-log--initialized-once-p t)))) + +(defun cider-log-kill-buffer-hook-handler () + "Called from `kill-buffer-hook' to remove the consumer." + (when (eq 'cider-log-mode major-mode) + (when-let ((framework cider-log-framework) + (appender cider-log-appender) + (consumer cider-log-consumer)) + (cider-log--remove-current-buffer-consumer) + (message "Removed %s event consumer %s from appender %s." + (cider-log-framework-display-name framework) + (cider-log-consumer-display-name consumer) + (cider-log-appender-display-name appender))))) + +(defun cider-log-select-framework () + "Select the log framework." + (let ((frameworks (cider-sync-request:log-frameworks))) + (cond ((= 1 (length frameworks)) + (car frameworks)) + (t (let ((name (cider-log--read-framework-name))) + (cider-log-framework-by-name frameworks name)))))) + +(defun cider-log--current-framework () + "Return the log framework by the name bound to `cider-log-framework-name'." + (when cider-log-framework-name + (let ((frameworks (cider-sync-request:log-frameworks))) + (cider-log-framework-by-name frameworks cider-log-framework-name)))) + +(defun cider-log--framework () + "Return the current log framework, or select it." + (or (cider-log--current-framework) (cider-log-select-framework))) + +(defun cider-log--appender () + "Return the current log appender." + (when cider-log-appender-id + (nrepl-dict "id" cider-log-appender-id + "filters" (cider-log--filters) + "size" cider-log-appender-size + "threshold" cider-log-appender-threshold))) + +(defun cider-log--consumer () + "Return the current log consumer." + (let ((consumer (nrepl-dict "filters" (cider-log--filters)))) + (when cider-log-consumer + (nrepl-dict-put consumer "id" (cider-log-consumer-id cider-log-consumer))) + consumer)) + +(defun cider-log--event-options () + "Return the current log consumer." + (nrepl-dict "filters" (cider-log--filters) + "limit" cider-log-pagination-limit + "offset" cider-log-pagination-offset)) + +(defun cider-log--filters () + "Return the log event filters." + (nrepl-dict + "end-time" cider-log--end-time-filter + "exceptions" cider-log--exceptions-filter + "level" cider-log--level-filter + "loggers" cider-log--loggers-filter + "pattern" cider-log--pattern-filter + "start-time" cider-log--start-time-filter + "threads" cider-log--threads-filter)) + +(defun cider-log-event-at-point () + "Return the log event at point." + (get-text-property (point) :cider-log-event)) + +;;;###autoload (autoload 'cider-log-info "cider-log-info" "Show the Cider log current log buffer, framework, appender and consumer." t) +(defun cider-log-info () + "Show the current log buffer, framework, appender and consumer." + (interactive) + (message "%s" + (string-join + (list (when cider-log-buffer + (format "Buffer: %s" (cider-log--bold cider-log-buffer))) + (when cider-log-framework-name + (format "Framework: %s" (cider-log--bold cider-log-framework-name))) + (when cider-log-appender-id + (format "Appender: %s" (cider-log--bold cider-log-appender-id))) + (when-let (id (and cider-log-consumer (cider-log-consumer-id cider-log-consumer))) + (format "Consumer: %s" (cider-log--bold id)))) + " "))) + +;; Major mode + +(defvar cider-log-mode-map + (let ((map (make-sparse-keymap)) + (parent (if (cider-log-use-logview) + logview-mode-map + special-mode-map))) + (set-keymap-parent map parent) + (define-key map (kbd "C-c M-l a") #'cider-log-appender) + (define-key map (kbd "C-c M-l c") #'cider-log-consumer) + (define-key map (kbd "C-c M-l e") #'cider-log-event) + (define-key map (kbd "C-c M-l f") #'cider-log-framework) + (define-key map (kbd "C-c M-l i") #'cider-log-info) + (define-key map (kbd "C-c M-l l") #'cider-log) + (define-key map (kbd "E") 'cider-log-show-stacktrace) + (define-key map (kbd "F") 'cider-log-print-event) + (define-key map (kbd "I") 'cider-log-inspect-event) + (define-key map (kbd "RET") 'cider-log-inspect-event) + (define-key map (kbd "n") 'cider-log-event-next-line) + (define-key map (kbd "p") 'cider-log-event-previous-line) + map) + "The Cider log stream mode key map.") + +(defun cider-log--setup-mode () + "Setup CIDER log mode." + (use-local-map cider-log-mode-map) + (setq-local electric-indent-chars nil) + (setq-local logview-show-ellipses nil) + (setq-local sesman-system 'CIDER) + (setq-local truncate-lines t) + (when (fboundp 'evil-set-initial-state) + (evil-set-initial-state 'cider-log-mode 'emacs))) + +(defvar cider-log--mode-doc + "Major mode for inspecting Clojure log events. + +CIDER Log Mode allows you to capture, debug, inspect and view log events +emitted by Java logging frameworks. The captured log events can be +searched, streamed to the client, pretty printed and are integrated with +the CIDER Inspector and the CIDER stacktrace mode. + +\\{cider-log-mode-map}") + +(if (cider-log-use-logview) + (define-derived-mode cider-log-mode logview-mode "Cider Log" cider-log--mode-doc + (cider-log--setup-mode)) + (define-derived-mode cider-log-mode special-mode "Cider Log" cider-log--mode-doc + (cider-log--setup-mode))) + +;; Transient Lisp Variable + +(defclass cider-log--lisp-variable (transient-lisp-variable) ()) + +(cl-defmethod transient-init-value ((obj cider-log--lisp-variable)) + "Set the initial value of the object OBJ." + (let* ((prefix-value (oref transient--prefix value)) + (value (cdr (assoc (oref obj variable) prefix-value))) + (new-value (if (assoc (oref obj variable) prefix-value) + value + (symbol-value (oref obj variable))))) + (funcall (oref obj set-value) + (oref obj variable) + (oset obj value new-value)))) + +(cl-defmethod transient-infix-set ((obj cider-log--lisp-variable) value) + "Set the value of infix object OBJ to VALUE." + (funcall (oref obj set-value) + (oref obj variable) + (oset obj value value))) + +(cl-defmethod transient-infix-value ((obj cider-log--lisp-variable)) + "Return the value of the suffix object OBJ." + (cons (oref obj variable) (oref obj value))) + +(cl-defmethod transient-format-value ((obj cider-log--lisp-variable)) + "Format OBJ's value for display and return the result." + (propertize (prin1-to-string (oref obj value)) + 'face 'transient-value)) + +(cl-defmethod transient-format-value ((obj cider-log--lisp-variable)) + "Format OBJ's value for display and return the result." + (cider-log--format-value (oref obj value))) + +;; Transient options + +(transient-define-infix cider-log--appender-size-option () + :always-read t + :argument "--size=" + :class 'cider-log--lisp-variable + :description "Appender size" + :key "=s" + :prompt "Size: " + :reader #'cider-log--read-number-N+ + :variable 'cider-log-appender-size) + +(transient-define-infix cider-log--appender-threshold-option () + :always-read t + :argument "--threshold=" + :class 'cider-log--lisp-variable + :description "Appender threshold" + :key "=t" + :prompt "Threshold: " + :reader #'cider-log--read-number-N+ + :variable 'cider-log-appender-threshold) + +(transient-define-infix cider-log--buffer-option () + :always-read t + :class 'cider-log--lisp-variable + :description "Buffer" + :key "=b" + :prompt "Log buffer: " + :reader #'cider-log--read-buffer + :variable 'cider-log-buffer) + +(transient-define-infix cider-log--end-time-option () + :argument "--end-time=" + :class 'cider-log--lisp-variable + :description "Filter by end time" + :key "-e" + :prompt "End time: " + :reader #'cider-log--read-time + :variable 'cider-log--end-time-filter) + +(transient-define-infix cider-log--exceptions-option () + :argument "--exceptions=" + :class 'cider-log--lisp-variable + :description "Filter by exceptions" + :key "-E" + :multi-value t + :prompt "Exceptions: " + :reader #'cider-log--read-exceptions + :variable 'cider-log--exceptions-filter) + +(transient-define-infix cider-log--level-option () + :argument "--level=" + :class 'cider-log--lisp-variable + :description "Filter by level" + :key "-l" + :prompt "Log Level: " + :reader #'cider-log--read-level + :variable 'cider-log--level-filter) + +(transient-define-infix cider-log--limit-option () + :always-read t + :argument "--limit=" + :class 'cider-log--lisp-variable + :description "Limit" + :key "=l" + :prompt "Limit: " + :reader #'cider-log--read-number-N+ + :variable 'cider-log-pagination-limit) + +(transient-define-infix cider-log--logger-option () + :argument "--loggers=" + :class 'cider-log--lisp-variable + :description "Filter by loggers" + :key "-L" + :multi-value t + :prompt "Loggers: " + :reader #'cider-log--read-loggers + :variable 'cider-log--loggers-filter) + +(transient-define-infix cider-log--offset-option () + :always-read t + :argument "--offset=" + :class 'cider-log--lisp-variable + :description "Offset" + :key "=o" + :prompt "Offset: " + :reader #'cider-log--read-number-N0 + :variable 'cider-log-pagination-offset) + +(transient-define-infix cider-log--pattern-option () + :argument "--pattern=" + :class 'cider-log--lisp-variable + :description "Filter by regex pattern" + :key "-r" + :prompt "Regex pattern: " + :reader #'read-string + :variable 'cider-log--pattern-filter) + +(transient-define-infix cider-log--start-time-option () + :argument "--start-time=" + :class 'cider-log--lisp-variable + :description "Filter by start time" + :key "-s" + :prompt "Start time: " + :reader #'cider-log--read-time + :variable 'cider-log--start-time-filter) + +(transient-define-infix cider-log--threads-option () + :argument "--threads=" + :class 'cider-log--lisp-variable + :description "Filter by threads" + :key "-t" + :multi-value t + :prompt "Threads: " + :reader #'cider-log--read-threads + :variable 'cider-log--threads-filter) + +;; Framework actions + +(transient-define-suffix cider-log-show-frameworks () + "Show the available log frameworks in a buffer." + :description "Show frameworks in a buffer" + (interactive) + (let ((frameworks (cider-sync-request:log-frameworks))) + (with-current-buffer (cider-popup-buffer cider-log-frameworks-buffer + cider-log-auto-select-frameworks-buffer) + (read-only-mode -1) + (insert (with-temp-buffer + (insert (propertize (cider-propertize "Cider Log Frameworks" 'ns) 'ns t) "\n\n") + (dolist (framework frameworks) + (insert (propertize (cider-propertize (cider-log-framework-name framework) 'ns) 'ns t) "\n\n") + (insert (format " Website ......... %s\n" (cider-log-framework-website-url framework))) + (insert (format " Javadocs ........ %s\n" (cider-log-framework-javadoc-url framework))) + (insert (format " Levels .......... %s\n" (string-join (cider-log-framework-level-names framework) ", "))) + (newline)) + (buffer-string))) + (read-only-mode 1) + (goto-char (point-min))))) + +(transient-define-suffix cider-log-browse-javadocs (framework) + "Browse the Javadoc of the log FRAMEWORK." + :description "Browse Java documentation" + (interactive (list (cider-log--framework))) + (browse-url (or (cider-log-framework-javadoc-url framework) + (user-error (format "The %s framework does not have Javadocs." + (cider-log-framework-name framework)))))) + +(transient-define-suffix cider-log-browse-website (framework) + "Browse the website of the log FRAMEWORK." + :description "Browse website" + (interactive (list (cider-log--framework))) + (browse-url (or (cider-log-framework-website-url framework) + (user-error (format "The %s framework does not have a website." + (cider-log-framework-name framework)))))) + +(transient-define-suffix cider-log-set-framework (framework-name) + "Set the current log framework to FRAMEWORK-NAME." + :description #'cider-log--description-set-framework + (interactive (list (cider-log--read-framework-name))) + (setq cider-log-framework-name framework-name)) + +(transient-define-suffix cider-log-set-buffer (buffer) + "Set the current log buffer to BUFFER." + :description #'cider-log--description-set-buffer + (interactive (list (cider-log--read-buffer))) + (setq cider-log-buffer buffer)) + +;; Appender actions + +(transient-define-suffix cider-log-clear-appender (framework appender) + "Clear the log events of the APPENDER of FRAMEWORK." + :description "Clear log appender" + :inapt-if-not #'cider-log-appender-attached-p + (interactive (list (cider-log--framework) (cider-log--appender))) + (cider-sync-request:log-clear framework appender) + (message "Cleared the %s log appender of the %s framework." + (cider-log-appender-display-name appender) + (cider-log-framework-display-name framework))) + +(transient-define-suffix cider-log-kill-appender (framework appender) + "Remove the log APPENDER from FRAMEWORK." + :description "Kill log appender" + :inapt-if-not #'cider-log-appender-attached-p + (interactive (list (cider-log--framework) (cider-log--appender))) + (cider-sync-request:log-remove-appender framework appender) + (setq-local cider-log-consumer nil) + (message "Log appender %s removed from the %s framework." + (cider-log-framework-display-name framework) + (cider-log-appender-display-name appender))) + +(transient-define-suffix cider-log--do-add-appender (framework appender) + "Add the APPENDER to the log FRAMEWORK." + :description "Add log appender" + :inapt-if #'cider-log-appender-attached-p + (interactive (list (cider-log--framework) (cider-log--appender))) + (setq cider-log-appender (cider-sync-request:log-add-appender framework appender)) + (message "Log appender %s added to the %s framework." + (cider-log-appender-display-name appender) + (cider-log-framework-display-name framework))) + +(transient-define-suffix cider-log--do-update-appender (framework appender) + "Update the APPENDER of the log FRAMEWORK." + :description "Update log appender" + :inapt-if-not #'cider-log-appender-attached-p + (interactive (list (cider-log--framework) (cider-log--appender))) + (setq cider-log-appender (cider-sync-request:log-update-appender framework appender)) + (message "Updated log appender %s of the %s framework." + (cider-log-appender-display-name appender) + (cider-log-framework-display-name framework))) + +;; Consumer actions + +(transient-define-suffix cider-log--do-add-consumer (framework appender consumer buffer) + "Add the CONSUMER to the APPENDER of the log FRAMEWORK and write events to BUFFER." + :description "Add log consumer" + :inapt-if #'cider-log-consumer-attached-p + (interactive (list (cider-log--framework) + (cider-log--appender) + (cider-log--consumer) + (current-buffer))) + (cider-log--consumer-add framework appender consumer buffer)) + +(transient-define-suffix cider-log-kill-consumer (framework appender consumer) + "Remove the CONSUMER listening to the APPENDER of the log FRAMEWORK." + :description "Kill log consumer" + :inapt-if-not #'cider-log-consumer-attached-p + (interactive (list (cider-log--framework) (cider-log--appender) (cider-log--consumer))) + (cider-sync-request:log-remove-consumer framework appender consumer) + (setq-local cider-log-consumer nil) + (message "Removed %s log consumer %s for appender %s." + (cider-log-framework-display-name framework) + (cider-log-consumer-display-name consumer) + (cider-log-appender-display-name appender))) + +(transient-define-suffix cider-log--do-update-consumer (framework appender consumer) + "Update the CONSUMER listening to the APPENDER of the log FRAMEWORK." + :description "Update log consumer" + :inapt-if-not #'cider-log-consumer-attached-p + (interactive (list (cider-log--framework) + (cider-log--appender) + (cider-log--consumer))) + (setq cider-log-consumer (cider-sync-request:log-update-consumer framework appender consumer)) + (message "Updated %s log consumer %s for appender %s." + (cider-log-framework-display-name framework) + (cider-log-consumer-display-name consumer) + (cider-log-appender-display-name appender))) + +;; Event actions + +(transient-define-suffix cider-log-show-stacktrace (framework appender event) + "Show the stacktrace of the log EVENT of FRAMEWORK and APPENDER." + :description "Show log event stacktrace" + :if #'cider-log-event-at-point + :inapt-if-not (lambda () + (when-let (event (cider-log-event-at-point)) + (cider-log-event-exception event))) + (interactive (list (cider-log--framework) (cider-log--appender) (cider-log-event-at-point))) + (cider-log-event--show-stacktrace framework appender event)) + +(transient-define-suffix cider-log-print-event (framework appender event) + "Format the log EVENT of FRAMEWORK and APPENDER." + :description "Pretty print log event at point" + :if #'cider-log-event-at-point + (interactive (list (cider-log--framework) (cider-log--appender) (cider-log-event-at-point))) + (if event + (cider-log-event--pretty-print framework appender event) + (user-error "No log event found at point"))) + +(transient-define-suffix cider-log-inspect-event (framework appender event) + "Inspect the log EVENT of FRAMEWORK and APPENDER." + :description "Inspect log event at point" + :if #'cider-log-event-at-point + (interactive (list (cider-log--framework) (cider-log--appender) (cider-log-event-at-point))) + (cider-log-event--inspect framework appender event)) + +(transient-define-suffix cider-log-clear-event-buffer (buffer) + "Clear the Cider log events in BUFFER." + :description #'cider-log--description-clear-events-buffer + :inapt-if-not #'cider-log-buffer-clear-p + (interactive (list cider-log-buffer)) + (when (get-buffer buffer) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (erase-buffer))))) + +(defun cider-log--switch-to-buffer (buffer) + "Switch to the Cider log event BUFFER." + (when (get-buffer-create buffer) + (switch-to-buffer-other-window buffer) + (get-buffer buffer))) + +(transient-define-suffix cider-log-switch-to-buffer (buffer) + "Switch to the Cider log event BUFFER." + :description "Switch to the log event buffer" + (interactive (list cider-log-buffer)) + (cider-log--switch-to-buffer buffer)) + +(transient-define-suffix cider-log--do-search-events (framework appender filters) + "Search the log events of FRAMEWORK and APPENDER which match FILTERS." + :description "Search log events" + :inapt-if-not #'cider-log-appender-attached-p + (interactive (list (cider-log--framework) (cider-log--appender) (cider-log--filters))) + (with-current-buffer (get-buffer-create cider-log-buffer) + (let ((consumer (nrepl-dict "filters" (cider-log--filters))) + (inhibit-read-only t)) + (cider-log--remove-current-buffer-consumer) + (erase-buffer) + (let ((events (cider-sync-request:log-search + framework appender + :filters filters + :limit cider-log-pagination-limit + :offset cider-log-pagination-offset))) + (seq-doseq (event (nreverse events)) + (insert (cider-log-event--format-logback event))) + (cider-log-mode) + (setq-local cider-log-framework framework) + (setq-local cider-log-appender appender) + (when (seq-empty-p events) + (message "No log events found.")) + (cider-log--consumer-add framework appender consumer (current-buffer)))))) + +;; Log Framework Transient + +;;;###autoload (autoload 'cider-log-framework "cider-log" "Show the Cider log framework menu." t) +(transient-define-prefix cider-log-framework (framework) + "Show the Cider log framework menu." + [["Cider Log Framework\n\nActions:" + ("a" cider-log-show-frameworks) + ("b" cider-log-set-buffer) + ("j" cider-log-browse-javadocs) + ("s" cider-log-set-framework) + ("w" cider-log-browse-website)]] + (interactive (list (cider-log--framework))) + (cider-log--ensure-initialized framework) + (transient-setup 'cider-log-framework)) + +;; Log Appender Transients + +(defun cider-log--appender-interactive-list () + "Return the interactive arguments for a appender transient." + (let ((framework (cider-log--current-framework))) + (list framework (cider-log-framework-appender framework cider-log-appender-id)))) + +(transient-define-prefix cider-log-add-appender (framework appender) + "Show the menu to add a Cider log appender." + :history-key 'cider-log-appender + ["Cider Log Appender\n\nSettings:" + (cider-log--appender-size-option) + (cider-log--appender-threshold-option)] + ["Filters:" + (cider-log--end-time-option) + (cider-log--exceptions-option) + (cider-log--level-option) + (cider-log--logger-option) + (cider-log--pattern-option) + (cider-log--start-time-option) + (cider-log--threads-option)] + ["Actions" + ("a" cider-log--do-add-appender)] + (interactive (cider-log--appender-interactive-list)) + (cider-log--ensure-initialized framework appender) + (transient-setup 'cider-log-add-appender)) + +(transient-define-prefix cider-log-update-appender (framework appender) + "Show the menu to update a Cider log appender." + :history-key 'cider-log-appender + ["Cider Log Appender\n\nSettings:" + (cider-log--appender-size-option) + (cider-log--appender-threshold-option)] + ["Filters:" + (cider-log--end-time-option) + (cider-log--exceptions-option) + (cider-log--level-option) + (cider-log--logger-option) + (cider-log--pattern-option) + (cider-log--start-time-option) + (cider-log--threads-option)] + ["Actions" + ("u" cider-log--do-update-appender)] + (interactive (cider-log--appender-interactive-list)) + (cider-log--ensure-initialized framework appender) + (transient-setup 'cider-log-update-appender)) + +;;;###autoload (autoload 'cider-log-appender "cider-log" "Show the Cider log appender menu." t) +(transient-define-prefix cider-log-appender (framework appender) + "Show the Cider log appender menu." + :history-key 'cider-log-appender + ["Cider Log Appender\n\nSettings:" + (cider-log--appender-size-option) + (cider-log--appender-threshold-option)] + ["Filters:" + (cider-log--end-time-option) + (cider-log--exceptions-option) + (cider-log--level-option) + (cider-log--logger-option) + (cider-log--pattern-option) + (cider-log--start-time-option) + (cider-log--threads-option)] + ["Actions" + ("a" cider-log--do-add-appender) + ("c" cider-log-clear-appender) + ("k" cider-log-kill-appender) + ("u" cider-log--do-update-appender)] + (interactive (cider-log--appender-interactive-list)) + (cider-log--ensure-initialized framework appender) + (transient-setup 'cider-log-appender)) + +;; Log Consumer Transient Menu + +(defun cider-log--consumer-interactive-list () + "Return the interactive arguments for a consumer transient." + (let* ((framework (cider-log--current-framework)) + (appender (cider-log-framework-appender framework cider-log-appender-id))) + (list framework appender + (if (and appender cider-log-consumer) + (seq-find (lambda (consumer) + (equal (cider-log-consumer-id cider-log-consumer) + (cider-log-consumer-id consumer))) + (cider-log-appender-consumers appender)) + (nrepl-dict "filters" (cider-log--filters)))))) + +(transient-define-prefix cider-log-add-consumer (framework appender consumer) + "Show the menu to add a Cider log consumer." + :history-key 'cider-log-consumer + ["Cider Log Consumer\n\nFilters:" + (cider-log--end-time-option) + (cider-log--exceptions-option) + (cider-log--level-option) + (cider-log--logger-option) + (cider-log--pattern-option) + (cider-log--start-time-option) + (cider-log--threads-option)] + ["Actions" + ("a" cider-log--do-add-consumer)] + (interactive (cider-log--consumer-interactive-list)) + (cider-log--ensure-initialized framework appender consumer) + (transient-setup 'cider-log-add-consumer)) + +(transient-define-prefix cider-log-update-consumer (framework appender consumer) + "Show the menu to update a Cider log consumer." + :history-key 'cider-log-consumer + ["Cider Log Consumer\n\nFilters:" + (cider-log--end-time-option) + (cider-log--exceptions-option) + (cider-log--level-option) + (cider-log--logger-option) + (cider-log--pattern-option) + (cider-log--start-time-option) + (cider-log--threads-option)] + ["Actions" + ("u" cider-log--do-update-consumer)] + (interactive (cider-log--consumer-interactive-list)) + (cider-log--ensure-initialized framework appender consumer) + (transient-setup 'cider-log-update-consumer)) + +;;;###autoload (autoload 'cider-log-consumer "cider-log" "Show the Cider log consumer menu." t) +(transient-define-prefix cider-log-consumer (framework appender consumer) + "Show the Cider log consumer menu." + :history-key 'cider-log-consumer + ["Cider Log Consumer\n\nFilters:" + (cider-log--end-time-option) + (cider-log--exceptions-option) + (cider-log--level-option) + (cider-log--logger-option) + (cider-log--pattern-option) + (cider-log--start-time-option) + (cider-log--threads-option)] + ["Actions" + ("a" cider-log--do-add-consumer) + ("k" cider-log-kill-consumer) + ("u" cider-log--do-update-consumer)] + (interactive (cider-log--consumer-interactive-list)) + (cider-log--ensure-initialized framework appender consumer) + (transient-setup 'cider-log-consumer)) + +;; Log Event Transient Menu + +(transient-define-prefix cider-log-event-search (framework appender) + "Search the search log events menu." + :history-key 'cider-log-event + ["Cider Log Event\n\nPagination:" + (cider-log--limit-option) + (cider-log--offset-option)] + ["Filters:" + (cider-log--end-time-option) + (cider-log--exceptions-option) + (cider-log--level-option) + (cider-log--logger-option) + (cider-log--pattern-option) + (cider-log--start-time-option) + (cider-log--threads-option)] + ["Actions" + ("s" cider-log--do-search-events)] + (interactive (list (cider-log--framework) (cider-log--appender))) + (cider-log--ensure-initialized framework appender) + (transient-setup 'cider-log-event-search)) + +;;;###autoload (autoload 'cider-log-event "cider-log" "Show the Cider log event menu." t) +(transient-define-prefix cider-log-event (framework appender) + "Show the Cider log event menu." + :history-key 'cider-log-event + ["Cider Log Event\n\nPagination:" + (cider-log--limit-option) + (cider-log--offset-option)] + ["Filters:" + (cider-log--end-time-option) + (cider-log--exceptions-option) + (cider-log--level-option) + (cider-log--logger-option) + (cider-log--pattern-option) + (cider-log--start-time-option) + (cider-log--threads-option)] + ["Actions" + ("c" cider-log-clear-event-buffer) + ("e" cider-log-show-stacktrace) + ("i" cider-log-inspect-event) + ("p" cider-log-print-event) + ("s" cider-log--do-search-events)] + (interactive (list (cider-log--framework) (cider-log--appender))) + (cider-log--ensure-initialized framework appender) + (transient-setup 'cider-log-event)) + +;;;###autoload +(defun cider-log-show () + "Ensures the *cider-log* buffer is visible, +setting up a framework, appender and consumer if necessary. + +Honors the `cider-log-framework-name' customization variable. + +This function is offered as an alternative to workflows +based on `transient-mode'." + (interactive) + (cider-current-repl nil 'ensure) + (let ((framework (cider-log--framework)) + (appender (cider-log--appender)) + (new-default-directory (buffer-local-value 'default-directory (current-buffer)))) + (with-current-buffer (cider-log--switch-to-buffer cider-log-buffer) + (setq-local default-directory new-default-directory) ;; for Sesman + (cider-log--ensure-initialized framework appender) + (unless cider-log-consumer + (apply #'cider-log--ensure-initialized (cider-log--consumer-interactive-list)) + (call-interactively 'cider-log--do-add-consumer))))) + +;; Main Transient Menu + +;;;###autoload (autoload 'cider-log "cider-log" "Show the Cider log menu." t) +(transient-define-prefix cider-log (framework appender) + "Show the Cider log menu." + [["Framework Actions" + ("fa" cider-log-show-frameworks) + ("fs" cider-log-set-framework) + ("fb" cider-log-set-buffer) + ("fj" cider-log-browse-javadocs) + ("fw" cider-log-browse-website)] + ["Appender Actions" + ("aa" "Add log appender" cider-log-add-appender + :inapt-if cider-log-appender-attached-p) + ("ac" cider-log-clear-appender) + ("ak" cider-log-kill-appender) + ("am" "Manage appender" cider-log-appender) + ("au" "Update log appender" cider-log-update-appender + :inapt-if-not cider-log-appender-attached-p)] + ["Consumer Actions" + ("ca" "Add log consumer" cider-log-add-consumer + :inapt-if cider-log-consumer-attached-p) + ("ck" cider-log-kill-consumer) + ("cm" "Manage consumer" cider-log-consumer) + ("cu" "Update log consumer" cider-log-update-consumer + :inapt-if-not cider-log-consumer-attached-p)] + ["Event Actions" + ("eb" cider-log-switch-to-buffer) + ("ec" cider-log-clear-event-buffer) + ("ee" cider-log-show-stacktrace) + ("ei" cider-log-inspect-event) + ("ep" cider-log-print-event) + ("es" "Search log events" cider-log-event-search + :inapt-if-not cider-log-appender-attached-p)]] + (interactive (list (cider-log--framework) (cider-log--appender))) + (cider-log--ensure-initialized framework appender) + (transient-setup 'cider-log)) + +(add-hook 'kill-buffer-hook #'cider-log-kill-buffer-hook-handler) + +(provide 'cider-log) + +;;; cider-log.el ends here diff --git a/elpa/cider-20241203.1607/cider-macroexpansion.el b/elpa/cider-20241203.1607/cider-macroexpansion.el new file mode 100644 index 00000000..e445c433 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-macroexpansion.el @@ -0,0 +1,204 @@ +;;; cider-macroexpansion.el --- Macro expansion support -*- lexical-binding: t -*- + +;; Copyright © 2012-2024 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Macro expansion support. + +;;; Code: + +(require 'cider-mode) +(require 'subr-x) + +(defconst cider-macroexpansion-buffer "*cider-macroexpansion*") + +(defcustom cider-macroexpansion-display-namespaces 'tidy + "Determines if namespaces are displayed in the macroexpansion buffer. +Possible values are: + + 'qualified ;=> Vars are fully-qualified in the expansion + 'none ;=> Vars are displayed without namespace qualification + 'tidy ;=> Vars that are :refer-ed or defined in the current namespace are + displayed with their simple name, non-referred vars from other + namespaces are referred using the alias for that namespace (if + defined), other vars are displayed fully qualified." + :type '(choice (const :tag "Suppress namespaces" none) + (const :tag "Show fully-qualified namespaces" qualified) + (const :tag "Show namespace aliases" tidy)) + :group 'cider + :package-version '(cider . "0.7.0")) + +(defcustom cider-macroexpansion-print-metadata nil + "Determines if metadata is included in macroexpansion results." + :type 'boolean + :group 'cider + :package-version '(cider . "0.9.0")) + +(defun cider-sync-request:macroexpand (expander expr &optional display-namespaces) + "Macroexpand, using EXPANDER, the given EXPR. +The default for DISPLAY-NAMESPACES is taken from +`cider-macroexpansion-display-namespaces'." + (cider-ensure-op-supported "macroexpand") + (let ((result (thread-first `("op" "macroexpand" + "expander" ,expander + "code" ,expr + "ns" ,(cider-current-ns) + "display-namespaces" ,(or display-namespaces + (symbol-name cider-macroexpansion-display-namespaces))) + (nconc (when cider-macroexpansion-print-metadata + '("print-meta" "true"))) + (cider-nrepl-send-sync-request)))) + (nrepl-dbind-response result (expansion status) + (if (member "macroexpand-error" status) + (user-error "Macroexpansion failed. Check *cider-error* for more details") + expansion)))) + +(defun cider-macroexpand-undo (&optional arg) + "Undo the last macroexpansion, using `undo-only'. +ARG is passed along to `undo-only'." + (interactive) + (let ((inhibit-read-only t)) + (undo-only arg))) + +(defvar cider-last-macroexpand-expression nil + "Specify the last macroexpansion performed. +This variable specifies both what was expanded and the expander.") + +(defun cider-macroexpand-expr (expander expr) + "Macroexpand, use EXPANDER, the given EXPR." + (when-let* ((expansion (cider-sync-request:macroexpand expander expr))) + (setq cider-last-macroexpand-expression expr) + (cider-initialize-macroexpansion-buffer expansion (cider-current-ns)))) + +(defun cider-macroexpand-expr-inplace (expander) + "Substitute the form preceding point with its macroexpansion using EXPANDER." + (interactive) + (let* ((expansion (cider-sync-request:macroexpand expander (cider-last-sexp))) + (bounds (cons (save-excursion (clojure-backward-logical-sexp 1) (point)) (point)))) + (cider-redraw-macroexpansion-buffer + expansion (current-buffer) (car bounds) (cdr bounds)))) + +(defun cider-macroexpand-again () + "Repeat the last macroexpansion." + (interactive) + (cider-initialize-macroexpansion-buffer cider-last-macroexpand-expression (cider-current-ns))) + +;;;###autoload +(defun cider-macroexpand-1 (&optional prefix) + "Invoke \\=`macroexpand-1\\=` on the expression preceding point. +If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of +\\=`macroexpand-1\\=`." + (interactive "P") + (let ((expander (if prefix "macroexpand" "macroexpand-1"))) + (cider-macroexpand-expr expander (cider-last-sexp)))) + +(defun cider-macroexpand-1-inplace (&optional prefix) + "Perform inplace \\=`macroexpand-1\\=` on the expression preceding point. +If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of +\\=`macroexpand-1\\=`." + (interactive "P") + (let ((expander (if prefix "macroexpand" "macroexpand-1"))) + (cider-macroexpand-expr-inplace expander))) + +;;;###autoload +(defun cider-macroexpand-all () + "Invoke \\=`macroexpand-all\\=` on the expression preceding point." + (interactive) + (cider-macroexpand-expr "macroexpand-all" (cider-last-sexp))) + +(defun cider-macroexpand-all-inplace () + "Perform inplace \\=`macroexpand-all\\=` on the expression preceding point." + (interactive) + (cider-macroexpand-expr-inplace "macroexpand-all")) + +(defun cider-initialize-macroexpansion-buffer (expansion ns) + "Create a new Macroexpansion buffer with EXPANSION and namespace NS." + (pop-to-buffer (cider-create-macroexpansion-buffer)) + (setq cider-buffer-ns ns) + (setq buffer-undo-list nil) + (let ((inhibit-read-only t) + (buffer-undo-list t)) + (erase-buffer) + (insert (format "%s" expansion)) + (goto-char (point-max)) + (font-lock-ensure))) + +(defun cider-redraw-macroexpansion-buffer (expansion buffer start end) + "Redraw the macroexpansion with new EXPANSION. +Text in BUFFER from START to END is replaced with new expansion, +and point is placed after the expanded form." + (with-current-buffer buffer + (let ((buffer-read-only nil)) + (goto-char start) + (delete-region start end) + (insert (format "%s" expansion)) + (goto-char start) + (indent-sexp) + (forward-sexp)))) + +(declare-function cider-mode "cider-mode") + +(defun cider-create-macroexpansion-buffer () + "Create a new macroexpansion buffer." + (with-current-buffer (cider-popup-buffer cider-macroexpansion-buffer 'select 'clojure-mode 'ancillary) + (cider-mode -1) + (cider-macroexpansion-mode 1) + (current-buffer))) + +(declare-function cider-find-var "cider-find") + +(defvar cider-macroexpansion-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "g") #'cider-macroexpand-again) + (define-key map (kbd "q") #'cider-popup-buffer-quit-function) + (define-key map (kbd "d") #'cider-doc) + (define-key map (kbd "j") #'cider-javadoc) + (define-key map (kbd ".") #'cider-find-var) + (define-key map (kbd "m") #'cider-macroexpand-1-inplace) + (define-key map (kbd "a") #'cider-macroexpand-all-inplace) + (define-key map (kbd "u") #'cider-macroexpand-undo) + (define-key map [remap undo] #'cider-macroexpand-undo) + (easy-menu-define cider-macroexpansion-mode-menu map + "Menu for CIDER's doc mode" + '("Macroexpansion" + ["Restart expansion" cider-macroexpand-again] + ["Macroexpand-1" cider-macroexpand-1-inplace] + ["Macroexpand-all" cider-macroexpand-all-inplace] + ["Macroexpand-undo" cider-macroexpand-undo] + ["Go to source" cider-find-var] + ["Go to doc" cider-doc] + ["Go to Javadoc" cider-docview-javadoc] + ["Quit" cider-popup-buffer-quit-function])) + map)) + +(define-minor-mode cider-macroexpansion-mode + "Minor mode for CIDER macroexpansion." + :lighter " Macroexpand") + +(provide 'cider-macroexpansion) + +;;; cider-macroexpansion.el ends here diff --git a/elpa/cider-20241203.1607/cider-mode.el b/elpa/cider-20241203.1607/cider-mode.el new file mode 100644 index 00000000..780a77ca --- /dev/null +++ b/elpa/cider-20241203.1607/cider-mode.el @@ -0,0 +1,1125 @@ +;;; cider-mode.el --- Minor mode for REPL interactions -*- lexical-binding: t -*- + +;; Copyright © 2012-2024 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Minor mode for REPL interactions. + +;;; Code: + +(require 'clojure-mode) +(require 'cider-eval) +(require 'cider-test) ; required only for the menu +(require 'cider-eldoc) +(require 'cider-resolve) +(require 'cider-doc) ; required only for the menu +(require 'cider-profile) ; required only for the menu +(require 'cider-completion) +(require 'cider-completion-context) +(require 'cider-inspector) +(require 'cider-find) +(require 'cider-xref-backend) +(require 'subr-x) + +(defcustom cider-mode-line-show-connection t + "If the mode-line lighter should detail the connection." + :group 'cider + :type 'boolean + :package-version '(cider "0.10.0")) + +(defun cider--modeline-info () + "Return info for the cider mode modeline. +Info contains the connection type, project name and host:port endpoint." + (if-let* ((current-connection (ignore-errors (cider-current-repl)))) + (with-current-buffer current-connection + (concat + (symbol-name cider-repl-type) + (when cider-mode-line-show-connection + (format ":%s@%s:%s" + (or (cider--project-name nrepl-project-dir) "") + (pcase (plist-get nrepl-endpoint :host) + ("localhost" "") + (x x)) + (plist-get nrepl-endpoint :port))))) + "not connected")) + +;;;###autoload +(defcustom cider-mode-line + '(:eval (format " cider[%s]" (cider--modeline-info))) + "Mode line lighter for cider mode. + +The value of this variable is a mode line template as in +`mode-line-format'. See Info Node `(elisp)Mode Line Format' for details +about mode line templates. + +Customize this variable to change how cider mode displays its status in the +mode line. The default value displays the current connection. Set this +variable to nil to disable the mode line entirely." + :group 'cider + :type 'sexp + :risky t + :package-version '(cider "0.7.0")) + + +;;; Switching between REPL & source buffers + +(defun cider--switch-to-repl-buffer (repl-buffer &optional set-namespace) + "Select the REPL-BUFFER, when possible in an existing window. +When SET-NAMESPACE is t, sets the namespace in the REPL buffer to +that of the namespace in the Clojure source buffer." + (let ((buffer (current-buffer))) + ;; first we switch to the REPL buffer + (if cider-repl-display-in-current-window + (pop-to-buffer-same-window repl-buffer) + (pop-to-buffer repl-buffer)) + ;; then if necessary we update its namespace + (when set-namespace + (cider-repl-set-ns (with-current-buffer buffer (cider-current-ns)))) + (goto-char (point-max)))) + +(defun cider-switch-to-repl-buffer (&optional set-namespace) + "Switch to current REPL buffer, when possible in an existing window. +The type of the REPL is inferred from the mode of current buffer. With a +prefix arg SET-NAMESPACE sets the namespace in the REPL buffer to that of +the namespace in the Clojure source buffer" + (interactive "P") + (cider--switch-to-repl-buffer + (cider-current-repl nil 'ensure) + set-namespace)) + +(declare-function cider-load-buffer "cider-eval") + +(defun cider-load-buffer-and-switch-to-repl-buffer (&optional set-namespace) + "Load the current buffer into the matching REPL buffer and switch to it. +When SET-NAMESPACE is true, we'll also set the REPL's ns to match that of the +Clojure buffer." + (interactive "P") + (cider-load-buffer) + (cider-switch-to-repl-buffer set-namespace)) + +(defun cider-switch-to-last-clojure-buffer () + "Switch to the last Clojure buffer. +The default keybinding for this command is +the same as variable `cider-switch-to-repl-buffer', +so that it is very convenient to jump between a +Clojure buffer and the REPL buffer." + (interactive) + (if (derived-mode-p 'cider-repl-mode) + (let* ((a-buf) + (the-buf (let ((repl-type (cider-repl-type-for-buffer))) + (seq-find (lambda (b) + (unless (with-current-buffer b (derived-mode-p 'cider-repl-mode)) + (when-let* ((type (cider-repl-type-for-buffer b))) + (unless a-buf + (setq a-buf b)) + (or (eq type 'multi) + (eq type repl-type))))) + (buffer-list))))) + (if-let* ((buf (or the-buf a-buf))) + (if cider-repl-display-in-current-window + (pop-to-buffer-same-window buf) + (pop-to-buffer buf)) + (user-error "No Clojure buffer found"))) + (user-error "Not in a CIDER REPL buffer"))) + +(defun cider-find-and-clear-repl-output (&optional clear-repl) + "Find the current REPL buffer and clear it. +With a prefix argument CLEAR-REPL the command clears the entire REPL +buffer. Returns to the buffer in which the command was invoked. See also +the related commands `cider-repl-clear-buffer' and +`cider-repl-clear-output'." + (interactive "P") + (let ((origin-buffer (current-buffer))) + (switch-to-buffer (cider-current-repl nil 'ensure)) + (if clear-repl + (cider-repl-clear-buffer) + (cider-repl-clear-output)) + (switch-to-buffer origin-buffer))) + +;;; cider-run +(defvar cider--namespace-history nil + "History of user input for namespace prompts.") + +(defun cider--var-namespace (var) + "Return the namespace of VAR. +VAR is a fully qualified Clojure variable name as a string." + (replace-regexp-in-string "\\(?:#'\\)?\\(.*\\)/.*" "\\1" var)) + +(defun cider-run (&optional function) + "Run -main or FUNCTION, prompting for its namespace if necessary. +With a prefix argument, prompt for function to run instead of -main." + (interactive (list (when current-prefix-arg (read-string "Function name: ")))) + (cider-ensure-connected) + (let ((name (or function "-main"))) + (when-let* ((response (cider-nrepl-send-sync-request + `("op" "ns-list-vars-by-name" + "name" ,name)))) + (if-let* ((vars (split-string (substring (nrepl-dict-get response "var-list") 1 -1)))) + (cider-interactive-eval + (if (= (length vars) 1) + (concat "(" (car vars) ")") + (let* ((completions (mapcar #'cider--var-namespace vars)) + (def (or (car cider--namespace-history) + (car completions)))) + (format "(#'%s/%s)" + (completing-read (format "Namespace (%s): " def) + completions nil t nil + 'cider--namespace-history def) + name)))) + (user-error "No %s var defined in any namespace" (cider-propertize name 'fn)))))) + +;;; Insert (and eval) in REPL functionality +(defvar cider-insert-commands-map + (let ((map (define-prefix-command 'cider-insert-commands-map))) + ;; single key bindings defined last for display in menu + (define-key map (kbd "e") #'cider-insert-last-sexp-in-repl) + (define-key map (kbd "d") #'cider-insert-defun-in-repl) + (define-key map (kbd "r") #'cider-insert-region-in-repl) + (define-key map (kbd "n") #'cider-insert-ns-form-in-repl) + + ;; duplicates with C- for convenience + (define-key map (kbd "C-e") #'cider-insert-last-sexp-in-repl) + (define-key map (kbd "C-d") #'cider-insert-defun-in-repl) + (define-key map (kbd "C-r") #'cider-insert-region-in-repl) + (define-key map (kbd "C-n") #'cider-insert-ns-form-in-repl) + map)) + +(defcustom cider-switch-to-repl-on-insert t + "Whether to switch to the REPL when inserting a form into the REPL." + :type 'boolean + :group 'cider + :package-version '(cider . "0.21.0")) + +(defcustom cider-invert-insert-eval-p nil + "Whether to invert the behavior of evaling. +Default behavior when inserting is to NOT eval the form and only eval with +a prefix. This allows to invert this so that default behavior is to insert +and eval and the prefix is required to prevent evaluation." + :type 'boolean + :group 'cider + :package-version '(cider . "0.18.0")) + +(defun cider-insert-in-repl (form eval) + "Insert FORM in the REPL buffer and switch to it. +If EVAL is non-nil the form will also be evaluated. Use +`cider-invert-insert-eval-p' to invert this behavior." + (while (string-match "\\`[ \t\n\r]+\\|[ \t\n\r]+\\'" form) + (setq form (replace-match "" t t form))) + (when cider-switch-to-repl-on-insert + (cider-switch-to-repl-buffer)) + (let ((repl (cider-current-repl))) + (with-selected-window (or (get-buffer-window repl t) + (selected-window)) + (with-current-buffer repl + (goto-char (point-max)) + (let ((beg (point))) + (insert form) + (indent-region beg (point)) + (font-lock-ensure beg (point))) + (when (if cider-invert-insert-eval-p + (not eval) + eval) + (cider-repl-return)) + (goto-char (point-max)))))) + +(defun cider-insert-last-sexp-in-repl (&optional arg) + "Insert the expression preceding point in the REPL buffer. +If invoked with a prefix ARG eval the expression after inserting it." + (interactive "P") + (cider-insert-in-repl (cider-last-sexp) arg)) + +(defun cider-insert-defun-in-repl (&optional arg) + "Insert the top level form at point in the REPL buffer. +If invoked with a prefix ARG eval the expression after inserting it." + (interactive "P") + (cider-insert-in-repl (cider-defun-at-point) arg)) + +(defun cider-insert-region-in-repl (start end &optional arg) + "Insert the current region in the REPL buffer. +START and END represent the region's boundaries. +If invoked with a prefix ARG eval the expression after inserting it." + (interactive "rP") + (cider-insert-in-repl + (buffer-substring-no-properties start end) arg)) + +(defun cider-insert-ns-form-in-repl (&optional arg) + "Insert the current buffer's ns form in the REPL buffer. +If invoked with a prefix ARG eval the expression after inserting it." + (interactive "P") + (cider-insert-in-repl (cider-ns-form) arg)) + + + +;;; The menu-bar +(defconst cider-mode-menu + `("CIDER" + ["Start or connect to any REPL" cider + :help "A simple wrapper around all commands for starting/connecting to a REPL."] + ("Clojure" + ["Start a Clojure REPL" cider-jack-in + :help "Starts an nREPL server and connects a Clojure REPL to it."] + ["Connect to a Clojure REPL" cider-connect + :help "Connects to a REPL that's already running."]) + ("ClojureScript" + ["Start a ClojureScript REPL" cider-jack-in-cljs + :help "Starts an nREPL server and connects a ClojureScript REPL to it."] + ["Connect to a ClojureScript REPL" cider-connect-clojurescript + :help "Connects to a ClojureScript REPL that's already running."] + ["Create a ClojureScript REPL from a Clojure REPL" cider-jack-in-sibling-clojurescript]) + "--" + ["Quit" cider-quit :active (cider-connected-p)] + ["Restart" cider-restart :active (cider-connected-p)] + "--" + ["Connection info" cider-describe-connection + :active (cider-connected-p)] + ["Select any CIDER buffer" cider-selector] + "--" + ["Configure CIDER" (customize-group 'cider)] + "--" + ["A sip of CIDER" cider-drink-a-sip] + ["View user manual" cider-view-manual] + ["View quick reference card" cider-view-refcard] + ["Report a bug" cider-report-bug] + ["Version info" cider-version] + "--" + ["Close ancillary buffers" cider-close-ancillary-buffers + :active (seq-remove #'null cider-ancillary-buffers)] + ("nREPL" :active (cider-connected-p) + ["List nREPL middleware" cider-list-nrepl-middleware] + ["Describe nREPL session" cider-describe-nrepl-session] + ["Toggle message logging" nrepl-toggle-message-logging])) + "Menu for CIDER mode.") + +(defconst cider-mode-eval-menu + '("CIDER Eval" :visible (cider-connected-p) + ["Eval top-level sexp" cider-eval-defun-at-point] + ["Eval top-level sexp to point" cider-eval-defun-up-to-point] + ["Eval top-level sexp to comment" cider-eval-defun-to-comment] + ["Eval top-level sexp and pretty-print to comment" cider-pprint-eval-defun-to-comment] + "--" + ["Eval current list" cider-eval-list-at-point] + ["Eval current sexp" cider-eval-sexp-at-point] + ["Eval and tap current sexp" cider-tap-sexp-at-point] + ["Eval current sexp to point" cider-eval-sexp-up-to-point] + ["Eval current sexp in context" cider-eval-sexp-at-point-in-context] + "--" + ["Eval last sexp" cider-eval-last-sexp] + ["Eval and tap last sexp" cider-tap-last-sexp] + ["Eval last sexp in context" cider-eval-last-sexp-in-context] + ["Eval last sexp and insert" cider-eval-print-last-sexp + :keys "\\[universal-argument] \\[cider-eval-last-sexp]"] + ["Eval last sexp in popup buffer" cider-pprint-eval-last-sexp] + ["Eval last sexp and replace" cider-eval-last-sexp-and-replace] + ["Eval last sexp to REPL" cider-eval-last-sexp-to-repl] + ["Eval last sexp and pretty-print to REPL" cider-pprint-eval-last-sexp-to-repl] + ["Eval last sexp and pretty-print to comment" cider-pprint-eval-last-sexp-to-comment] + "--" + ["Eval selected region if active, otherwise top-level sexp" cider-eval-dwim] + ["Eval selected region" cider-eval-region] + ["Eval ns form" cider-eval-ns-form] + "--" + ["Interrupt evaluation" cider-interrupt] + "--" + ["Insert last sexp in REPL" cider-insert-last-sexp-in-repl] + ["Insert last sexp in REPL and eval" (cider-insert-last-sexp-in-repl t) + :keys "\\[universal-argument] \\[cider-insert-last-sexp-in-repl]"] + ["Insert top-level sexp in REPL" cider-insert-defun-in-repl] + ["Insert region in REPL" cider-insert-region-in-repl] + ["Insert ns form in REPL" cider-insert-ns-form-in-repl] + "--" + ["Load this buffer" cider-load-buffer] + ["Load this buffer and switch to REPL" cider-load-buffer-and-switch-to-repl-buffer] + ["Load another file" cider-load-file] + ["Recursively load all files in directory" cider-load-all-files] + ["Load all project files" cider-load-all-project-ns] + ["Refresh loaded code" cider-ns-refresh] + ["Require and reload" cider-ns-reload] + ["Require and reload all" cider-ns-reload-all] + ["Run project (-main function)" cider-run]) + "Menu for CIDER mode eval commands.") + +(defconst cider-mode-interactions-menu + `("CIDER Interactions" :visible (cider-connected-p) + ["Complete symbol" complete-symbol] + "--" + ("REPL" + ["Set REPL to this ns" cider-repl-set-ns] + ["Switch to REPL" cider-switch-to-repl-buffer] + ["REPL Pretty Print" cider-repl-toggle-pretty-printing + :style toggle :selected cider-repl-use-pretty-printing] + ["Clear latest output" cider-find-and-clear-repl-output] + ["Clear all output" (cider-find-and-clear-repl-output t) + :keys "\\[universal-argument] \\[cider-find-and-clear-repl-output]"] + "--" + ["Configure the REPL" (customize-group 'cider-repl)]) + ,cider-doc-menu + ("Find (jump to)" + ["Find definition" cider-find-var] + ["Find namespace" cider-find-ns] + ["Find resource" cider-find-resource] + ["Find keyword" cider-find-keyword] + ["Go back" cider-pop-back]) + ("Xref" + ["Find fn references" cider-xref-fn-refs] + ["Find fn references and select" cider-xref-fn-refs-select] + ["Find fn dependencies" cider-xref-fn-defs] + ["Find fn dependencies and select" cider-xref-fn-defs-select]) + ("Browse" + ["Browse namespace" cider-browse-ns] + ["Browse all namespaces" cider-browse-ns-all] + ["Browse spec" cider-browse-spec] + ["Browse all specs" cider-browse-spec-all] + ["Browse REPL input history" cider-repl-history] + ["Browse classpath" cider-classpath] + ["Browse classpath entry" cider-open-classpath-entry]) + ("Format" + ["Format EDN last sexp" cider-format-edn-last-sexp] + ["Format EDN region" cider-format-edn-region] + ["Format EDN buffer" cider-format-edn-buffer]) + ("Macroexpand" + ["Macroexpand-1" cider-macroexpand-1] + ["Macroexpand-all" cider-macroexpand-all]) + ,cider-test-menu + ("Debug" + ["Inspect" cider-inspect] + ["Toggle var tracing" cider-toggle-trace-var] + ["Toggle ns tracing" cider-toggle-trace-ns] + "--" + ["Debug top-level form" cider-debug-defun-at-point + :keys "\\[universal-argument] \\[cider-eval-defun-at-point]"] + ["List instrumented defs" cider-browse-instrumented-defs] + "--" + ["Configure the Debugger" (customize-group 'cider-debug)]) + ,cider-profile-menu + ("Misc" + ["Clojure Cheatsheet" cider-cheatsheet] + ["Flush completion cache" cider-completion-flush-caches])) + "Menu for CIDER interactions.") + + +(declare-function cider-ns-refresh "cider-ns") +(declare-function cider-ns-reload "cider-ns") +(declare-function cider-ns-reload-all "cider-ns") +(declare-function cider-browse-ns "cider-browse-ns") +(declare-function cider-eval-ns-form "cider-eval") +(declare-function cider-repl-set-ns "cider-repl") +(declare-function cider-find-ns "cider-find") + +(defvar cider-ns-map + (let ((map (define-prefix-command 'cider-ns-map))) + (define-key map (kbd "b") #'cider-browse-ns) + (define-key map (kbd "M-b") #'cider-browse-ns) + (define-key map (kbd "e") #'cider-eval-ns-form) + (define-key map (kbd "M-e") #'cider-eval-ns-form) + (define-key map (kbd "f") #'cider-find-ns) + (define-key map (kbd "M-f") #'cider-find-ns) + (define-key map (kbd "n") #'cider-repl-set-ns) + (define-key map (kbd "M-n") #'cider-repl-set-ns) + (define-key map (kbd "r") #'cider-ns-refresh) + (define-key map (kbd "M-r") #'cider-ns-refresh) + (define-key map (kbd "l") #'cider-ns-reload) + (define-key map (kbd "M-l") #'cider-ns-reload-all) + map) + "CIDER NS keymap.") + +;; Those declares are needed, because we autoload all those commands when first +;; used. That optimizes CIDER's initial load time. +(declare-function cider-macroexpand-1 "cider-macroexpansion") +(declare-function cider-macroexpand-all "cider-macroexpansion") +(declare-function cider-selector "cider-selector") +(declare-function cider-toggle-trace-ns "cider-tracing") +(declare-function cider-toggle-trace-var "cider-tracing") +(declare-function cider-find-resource "cider-find") +(declare-function cider-find-keyword "cider-find") +(declare-function cider-find-var "cider-find") +(declare-function cider-find-dwim-at-mouse "cider-find") +(declare-function cider-xref-fn-refs "cider-xref") +(declare-function cider-xref-fn-refs-select "cider-xref") +(declare-function cider-xref-fn-deps "cider-xref") +(declare-function cider-xref-fn-deps-select "cider-xref") + +(defconst cider--has-many-mouse-buttons (not (memq window-system '(mac ns))) + "Non-nil if system binds forward and back buttons to and . + +As it stands Emacs fires these events on and on 'x' and +'w32'systems while on macOS it presents them on and .") + +(defcustom cider-use-xref t + "Enable xref integration." + :type 'boolean + :safe #'booleanp + :group 'cider + :version '(cider . "1.2.0")) + +(defcustom cider-xref-fn-depth -90 + "The depth to use when adding the CIDER xref function to the relevant hook. +By convention this is a number between -100 and 100, lower numbers indicating a +higher precedence." + :type 'integer + :group 'cider + :version '(cider . "1.2.0")) + +(defconst cider-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-d") 'cider-doc-map) + (unless cider-use-xref + (define-key map (kbd "M-.") #'cider-find-var) + (define-key map (kbd "M-,") #'cider-pop-back)) + (define-key map (kbd (if cider--has-many-mouse-buttons "" "")) #'xref-pop-marker-stack) + (define-key map (kbd (if cider--has-many-mouse-buttons "" "")) #'cider-find-dwim-at-mouse) + (define-key map (kbd "C-c C-.") #'cider-find-ns) + (define-key map (kbd "C-c C-:") #'cider-find-keyword) + (define-key map (kbd "C-c M-.") #'cider-find-resource) + (define-key map (kbd "M-TAB") #'complete-symbol) + (define-key map (kbd "C-M-x") #'cider-eval-defun-at-point) + (define-key map (kbd "C-c C-c") #'cider-eval-defun-at-point) + (define-key map (kbd "C-x C-e") #'cider-eval-last-sexp) + (define-key map (kbd "C-c C-e") #'cider-eval-last-sexp) + (define-key map (kbd "C-c C-p") #'cider-pprint-eval-last-sexp) + (define-key map (kbd "C-c C-f") #'cider-pprint-eval-defun-at-point) + (define-key map (kbd "C-c C-v") 'cider-eval-commands-map) + (define-key map (kbd "C-c C-j") 'cider-insert-commands-map) + (define-key map (kbd "C-c M-;") #'cider-eval-defun-to-comment) + (define-key map (kbd "C-c M-e") #'cider-eval-last-sexp-to-repl) + (define-key map (kbd "C-c M-p") #'cider-insert-last-sexp-in-repl) + (define-key map (kbd "C-c M-:") #'cider-read-and-eval) + (define-key map (kbd "C-c C-u") #'cider-undef) + (define-key map (kbd "C-c C-M-u") #'cider-undef-all) + (define-key map (kbd "C-c C-m") #'cider-macroexpand-1) + (define-key map (kbd "C-c M-m") #'cider-macroexpand-all) + (define-key map (kbd "C-c M-n") 'cider-ns-map) + (define-key map (kbd "C-c M-i") #'cider-inspect) + (define-key map (kbd "C-c M-t v") #'cider-toggle-trace-var) + (define-key map (kbd "C-c M-t n") #'cider-toggle-trace-ns) + (define-key map (kbd "C-c C-z") #'cider-switch-to-repl-buffer) + (define-key map (kbd "C-c M-z") #'cider-load-buffer-and-switch-to-repl-buffer) + (define-key map (kbd "C-c C-o") #'cider-find-and-clear-repl-output) + (define-key map (kbd "C-c C-k") #'cider-load-buffer) + (define-key map (kbd "C-c C-l") #'cider-load-file) + (define-key map (kbd "C-c C-M-l") #'cider-load-all-files) + (define-key map (kbd "C-c C-b") #'cider-interrupt) + (define-key map (kbd "C-c ,") 'cider-test-commands-map) + (define-key map (kbd "C-c C-t") 'cider-test-commands-map) + (define-key map (kbd "C-c M-s") #'cider-selector) + (define-key map (kbd "C-c M-d") #'cider-describe-connection) + (define-key map (kbd "C-c C-=") 'cider-profile-map) + (define-key map (kbd "C-c C-? r") #'cider-xref-fn-refs) + (define-key map (kbd "C-c C-? C-r") #'cider-xref-fn-refs-select) + (define-key map (kbd "C-c C-? d") #'cider-xref-fn-deps) + (define-key map (kbd "C-c C-? C-d") #'cider-xref-fn-deps-select) + (define-key map (kbd "C-c C-q") #'cider-quit) + (define-key map (kbd "C-c M-r") #'cider-restart) + ;; NOTE: all cider-log* vars are autoloaded. Please do not add a require. + (define-key map (kbd "C-c M-l a") #'cider-log-appender) + (define-key map (kbd "C-c M-l c") #'cider-log-consumer) + (define-key map (kbd "C-c M-l e") #'cider-log-event) + (define-key map (kbd "C-c M-l s") #'cider-log-show) + (define-key map (kbd "C-c M-l f") #'cider-log-framework) + (define-key map (kbd "C-c M-l i") #'cider-log-info) + (define-key map (kbd "C-c M-l l") #'cider-log) + (dolist (variable '(cider-mode-interactions-menu + cider-mode-eval-menu + cider-mode-menu)) + (easy-menu-do-define (intern (format "%s-open" variable)) + map + (get variable 'variable-documentation) + (cider--menu-add-help-strings (symbol-value variable)))) + map)) + +;;;###autoload +(defun cider--setup-menu-for-clojure-major-mode (mode-map) + "Setup a Cider menu for a Clojure major mode's MODE-MAP. + +This menu works as an easy entry-point into CIDER. Even if cider.el isn't +loaded yet, this will be shown in Clojure buffers next to the Clojure menu." + (easy-menu-define cider-clojure-mode-menu-open mode-map + "Menu for Clojure mode. + This is displayed in `clojure-mode' and `clojure-ts-mode' buffers, + if `cider-mode' is not active." + `("CIDER" :visible (not cider-mode) + ["Start a Clojure REPL" cider-jack-in-clj + :help "Starts an nREPL server and connects a Clojure REPL to it."] + ["Connect to a Clojure REPL" cider-connect-clj + :help "Connects to a REPL that's already running."] + ["Start a ClojureScript REPL" cider-jack-in-cljs + :help "Starts an nREPL server and connects a ClojureScript REPL to it."] + ["Connect to a ClojureScript REPL" cider-connect-cljs + :help "Connects to a ClojureScript REPL that's already running."] + ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clj&cljs + :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL."] + "--" + ["View user manual" cider-view-manual]))) + +;;;###autoload +(with-eval-after-load 'clojure-mode + (cider--setup-menu-for-clojure-major-mode clojure-mode-map)) + +;;;###autoload +(with-eval-after-load 'clojure-ts-mode + (cider--setup-menu-for-clojure-major-mode + (with-suppressed-warnings ((free-vars clojure-ts-mode-map)) + clojure-ts-mode-map))) + +;;; Dynamic indentation +(defcustom cider-dynamic-indentation t + "Whether CIDER should aid Clojure(Script) indentation. +If non-nil, CIDER uses runtime information (such as the \":style/indent\" +metadata) to improve standard `clojure-mode' indentation. +If nil, CIDER won't interfere with `clojure-mode's indentation. + +Toggling this variable only takes effect after a file is closed and +re-visited." + :type 'boolean + :package-version '(cider . "0.11.0") + :group 'cider) + +(defun cider--get-symbol-indent (symbol-name) + "Return the indent metadata for SYMBOL-NAME in the current namespace." + (let* ((ns (let ((clojure-cache-ns t)) ; we force ns caching here for performance reasons + ;; silence bytecode warning of unused lexical var + (ignore clojure-cache-ns) + (cider-current-ns)))) + (if-let* ((meta (cider-resolve-var ns symbol-name)) + (indent (or (nrepl-dict-get meta "style/indent") + (nrepl-dict-get meta "indent")))) + (let ((format (format ":indent metadata on ‘%s’ is unreadable! \nERROR: %%s" + symbol-name))) + (with-demoted-errors format + (cider--deep-vector-to-list (read indent)))) + ;; There's no indent metadata, but there might be a clojure-mode + ;; indent-spec with fully-qualified namespace. + (when (string-match cider-resolve--prefix-regexp symbol-name) + (when-let* ((sym (intern-soft (replace-match (save-match-data + (cider-resolve-alias ns (match-string 1 symbol-name))) + t t symbol-name 1)))) + (get sym 'clojure-indent-function)))))) + + +;;; Dynamic font locking +(defcustom cider-font-lock-dynamically '(macro core deprecated) + "Specifies how much dynamic font-locking CIDER should use. +Dynamic font-locking this refers to applying syntax highlighting to vars +defined in the currently active nREPL connection. This is done in addition +to `clojure-mode's usual (static) font-lock, so even if you set this +variable to nil you'll still see basic syntax highlighting. + +The value is a list of symbols, each one indicates a different type of var +that should be font-locked: + `macro' (default): Any defined macro gets the `font-lock-keyword-face'. + `function': Any defined function gets the `font-lock-function-face'. + `var': Any non-local var gets the `font-lock-variable-name-face'. + `deprecated' (default): Any deprecated var gets the `cider-deprecated-face' + face. + `core' (default): Any symbol from clojure.core/cljs.core. The selected face will depend on type. + Note that while rendering `core', all types of vars (`macro', `function', `var', `deprecated') + will be honored, regardless of the user's customization value. + +The value can also be t, which means to font-lock as much as possible." + :type '(choice (set :tag "Fine-tune font-locking" + (const :tag "Any defined macro" macro) + (const :tag "Any defined function" function) + (const :tag "Any defined var" var) + (const :tag "Any defined deprecated" deprecated) + (const :tag "Any symbol from clojure.core" core)) + (const :tag "Font-lock as much as possible" t)) + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-font-lock-reader-conditionals t + "Apply font-locking to unused reader conditional expressions. +The result depends on the buffer CIDER connection type." + :type 'boolean + :group 'cider + :package-version '(cider . "0.15.0")) + +(defface cider-deprecated-face + '((((background light)) :background "light goldenrod") + (((background dark)) :background "#432")) + "Face used on deprecated vars." + :group 'cider) + +(defface cider-instrumented-face + '((((type graphic)) :box (:color "#c00" :line-width -1)) + (t :underline t :background "#800")) + "Face used to mark code being debugged." + :group 'cider-debug + :group 'cider + :package-version '(cider . "0.10.0")) + +(defface cider-traced-face + '((((type graphic)) :box (:color "cyan" :line-width -1)) + (t :underline t :background "#066")) + "Face used to mark code being traced." + :group 'cider + :package-version '(cider . "0.11.0")) + +(defface cider-reader-conditional-face + '((t (:inherit font-lock-comment-face))) + "Face used to mark unused reader conditional expressions." + :group 'cider + :package-version '(cider . "0.15.0")) + +(defconst cider-reader-conditionals-regexp "\\(?:#\\?@?[[:space:]\n]*(\\)" + "Regexp for matching reader conditionals with a non-capturing group. +Starts from the reader macro characters to the opening parentheses.") + +(defvar cider--reader-conditionals-match-data (list nil nil) + "Reusable list for `match-data` in reader conditionals font lock matchers.") + +(defun cider--search-reader-conditionals (limit) + "Matcher for finding reader conditionals. +Search is done with the given LIMIT." + (when (and cider-font-lock-reader-conditionals + (cider-connected-p)) + (when (search-forward-regexp cider-reader-conditionals-regexp limit t) + (let ((start (match-beginning 0)) + (state (syntax-ppss))) + (if (or (nth 3 state) (nth 4 state)) ; inside string or comment? + (cider--search-reader-conditionals limit) + (when (<= (point) limit) + (ignore-errors + (let ((md (match-data nil cider--reader-conditionals-match-data))) + (setf (nth 0 md) start) + (setf (nth 1 md) (point)) + (set-match-data md) + t)))))))) + +(defun cider--anchored-search-suppressed-forms-internal (repl-types limit) + "Helper function for `cider--anchored-search-suppressed-forms`. +REPL-TYPES is a list of strings repl-type strings. LIMIT is the same as +the LIMIT in `cider--anchored-search-suppressed-forms`" + (when (= (length repl-types) 1) + (let ((type (car repl-types)) + (expr (read (current-buffer))) + (start (save-excursion (backward-sexp) (point)))) + (when (<= (point) limit) + (forward-sexp) + (if (not (string-equal (symbol-name expr) (concat ":" type))) + (ignore-errors + (cl-assert (<= (point) limit)) + (let ((md (match-data nil cider--reader-conditionals-match-data))) + (setf (nth 0 md) start) + (setf (nth 1 md) (point)) + (set-match-data md) + t)) + (cider--anchored-search-suppressed-forms-internal repl-types limit)))))) + +(defun cider--anchored-search-suppressed-forms (limit) + "Matcher for finding unused reader conditional expressions. +An unused reader conditional expression is an expression for a platform +that does not match the CIDER connection for the buffer. Search is done +with the given LIMIT." + (let ((repl-types (seq-uniq (seq-map + (lambda (repl) + (symbol-name (cider-repl-type repl))) + (cider-repls)))) + (result 'retry)) + (while (and (eq result 'retry) (<= (point) limit)) + (condition-case condition + (setq result + (cider--anchored-search-suppressed-forms-internal + repl-types limit)) + (invalid-read-syntax + (setq result 'retry)) + (wrong-type-argument + (setq result 'retry)) + (scan-error + (setq result 'retry)) + (end-of-file + (setq result nil)) + (error + (setq result nil) + (message + "Error during fontification while searching for forms: %S" + condition)))) + (if (eq result 'retry) (setq result nil)) + result)) + +(defconst cider--reader-conditionals-font-lock-keywords + '((cider--search-reader-conditionals + (cider--anchored-search-suppressed-forms + (save-excursion + (let* ((state (syntax-ppss)) + (list-pt (nth 1 state))) + (when list-pt + (goto-char list-pt) + (forward-list) + (backward-char) + (point)))) + nil + (0 'cider-reader-conditional-face t)))) + "Font Lock keywords for unused reader conditionals in CIDER mode.") + +(defun cider--unless-local-match (value) + "Return VALUE, unless `match-string' is a local var." + (unless (or (get-text-property (point) 'cider-block-dynamic-font-lock) + (member (match-string 0) + (get-text-property (point) 'cider-locals))) + value)) + +(defun cider--compile-font-lock-keywords (symbols-plist core-plist) + "Return a list of font-lock rules for symbols in SYMBOLS-PLIST, CORE-PLIST." + (let ((cider-font-lock-dynamically (if (eq cider-font-lock-dynamically t) + '(function var macro core deprecated) + cider-font-lock-dynamically)) + deprecated enlightened + macros functions vars instrumented traced) + (cl-labels ((handle-plist + (plist) + ;; Note that (memq 'function cider-font-lock-dynamically) and similar statements are evaluated differently + ;; for `core' - they're always truthy for `core' (see related core-handling code some lines below): + (let ((do-function (memq 'function cider-font-lock-dynamically)) + (do-var (memq 'var cider-font-lock-dynamically)) + (do-macro (memq 'macro cider-font-lock-dynamically)) + (do-deprecated (memq 'deprecated cider-font-lock-dynamically))) + (while plist + (let ((sym (pop plist)) + (meta (pop plist))) + (pcase (nrepl-dict-get meta "cider/instrumented") + (`nil nil) + (`"\"breakpoint-if-interesting\"" + (push sym instrumented)) + (`"\"light-form\"" + (push sym enlightened))) + ;; The ::traced keywords can be inlined by MrAnderson, so + ;; we catch that case too. + ;; FIXME: This matches values too, not just keys. + (when (seq-find (lambda (k) (and (stringp k) + (string-match (rx "orchard.trace/traced" eos) k))) + meta) + (push sym traced)) + (when (and do-deprecated (nrepl-dict-get meta "deprecated")) + (push sym deprecated)) + (let ((is-macro (nrepl-dict-get meta "macro")) + (is-function (or (nrepl-dict-get meta "fn") + (nrepl-dict-get meta "arglists")))) + (cond ((and do-macro is-macro) + (push sym macros)) + ((and do-function is-function) + (push sym functions)) + ((and do-var (not is-function) (not is-macro)) + (push sym vars))))))))) + ;; For core members, we override `cider-font-lock-dynamically', since all core members should get the same treatment: + (when (memq 'core cider-font-lock-dynamically) + (let ((cider-font-lock-dynamically '(function var macro core deprecated))) + (handle-plist core-plist))) + (handle-plist symbols-plist)) + `( + ,@(when macros + `((,(concat (rx (or "(" "#'")) ; Can't take the value of macros. + "\\(" (regexp-opt macros 'symbols) "\\)") + 1 (cider--unless-local-match font-lock-keyword-face)))) + ,@(when functions + `((,(regexp-opt functions 'symbols) 0 + (cider--unless-local-match font-lock-function-name-face)))) + ,@(when vars + `((,(regexp-opt vars 'symbols) 0 + (cider--unless-local-match font-lock-variable-name-face)))) + ,@(when deprecated + `((,(regexp-opt deprecated 'symbols) 0 + (cider--unless-local-match 'cider-deprecated-face) append))) + ,@(when enlightened + `((,(regexp-opt enlightened 'symbols) 0 + (cider--unless-local-match 'cider-enlightened-face) append))) + ,@(when instrumented + `((,(regexp-opt instrumented 'symbols) 0 + (cider--unless-local-match 'cider-instrumented-face) append))) + ,@(when traced + `((,(regexp-opt traced 'symbols) 0 + (cider--unless-local-match 'cider-traced-face) append)))))) + +(defconst cider--static-font-lock-keywords + (eval-when-compile + `((,(regexp-opt '("#break" "#dbg" "#light") 'symbols) 0 font-lock-warning-face))) + "Default expressions to highlight in CIDER mode.") + +(defvar-local cider--dynamic-font-lock-keywords nil) + +(defun cider-refresh-dynamic-font-lock (&optional ns) + "Ensure that the current buffer has up-to-date font-lock rules. +NS defaults to `cider-current-ns', and it can also be a dict describing the +namespace itself." + (interactive) + (when (and cider-font-lock-dynamically + font-lock-mode) + (font-lock-remove-keywords nil cider--dynamic-font-lock-keywords) + (when-let* ((ns (or ns (cider-current-ns))) + (symbols (cider-resolve-ns-symbols ns))) + (setq-local cider--dynamic-font-lock-keywords + (cider--compile-font-lock-keywords + symbols (cider-resolve-ns-symbols (cider-resolve-core-ns)))) + (font-lock-add-keywords nil cider--dynamic-font-lock-keywords 'end)) + (font-lock-flush))) + + +;;; Detecting local variables +(defun cider--read-locals-from-next-sexp () + "Return a list of all locals inside the next logical sexp." + (save-excursion + (ignore-errors + (clojure-forward-logical-sexp 1) + (let ((out nil) + (end (point))) + (forward-sexp -1) + ;; FIXME: This returns locals found inside the :or clause of a + ;; destructuring map. + (while (search-forward-regexp "\\_<[^:&]\\(\\sw\\|\\s_\\)*\\_>" end 'noerror) + (push (match-string-no-properties 0) out)) + out)))) + +(defun cider--read-locals-from-bindings-vector () + "Return a list of all locals inside the next bindings vector." + (save-excursion + (ignore-errors + (cider-start-of-next-sexp) + (when (eq (char-after) ?\[) + (forward-char 1) + (let ((out nil)) + (setq out (append (cider--read-locals-from-next-sexp) out)) + (while (ignore-errors (clojure-forward-logical-sexp 3) + (unless (eobp) + (forward-sexp -1) + t)) + (setq out (append (cider--read-locals-from-next-sexp) out))) + out))))) + +(defun cider--read-locals-from-arglist () + "Return a list of all locals in current form's arglist(s)." + (let ((out nil)) + (save-excursion + (ignore-errors + (cider-start-of-next-sexp) + ;; Named fn + (when (looking-at-p "\\s_\\|\\sw") + (cider-start-of-next-sexp 1)) + ;; Docstring + (when (eq (char-after) ?\") + (cider-start-of-next-sexp 1)) + ;; Attribute map + (when (eq (char-after) ?{) + (cider-start-of-next-sexp 1)) + ;; The arglist + (pcase (char-after) + (?\[ (setq out (cider--read-locals-from-next-sexp))) + ;; FIXME: This returns false positives. It takes all arglists of a + ;; function and returns all args it finds. The logic should be changed + ;; so that each arglist applies to its own scope. + (?\( (ignore-errors + (while (eq (char-after) ?\() + (save-excursion + (forward-char 1) + (setq out (append (cider--read-locals-from-next-sexp) out))) + (cider-start-of-next-sexp 1))))))) + out)) + +(defun cider--parse-and-apply-locals (end &optional outer-locals) + "Figure out local variables between point and END. +A list of these variables is set as the `cider-locals' text property over +the code where they are in scope. +Optional argument OUTER-LOCALS is used to specify local variables defined +before point." + (while (search-forward-regexp "(\\(ns\\_>\\|def\\|fn\\|for\\b\\|loop\\b\\|with-\\|do[a-z]+\\|\\([a-z]+-\\)?let\\b\\)" + end 'noerror) + (goto-char (match-beginning 0)) + (let ((sym (match-string 1)) + (sexp-end (save-excursion + (or (ignore-errors (forward-sexp 1) + (point)) + end)))) + ;; #1324: Don't do dynamic font-lock in `ns' forms, they are special + ;; macros where nothing is evaluated, so we'd get a lot of false + ;; positives. + (if (equal sym "ns") + (add-text-properties (point) sexp-end '(cider-block-dynamic-font-lock t)) + (forward-char 1) + (forward-sexp 1) + (let ((locals (append outer-locals + (pcase sym + ((or "fn" "def" "") (cider--read-locals-from-arglist)) + (_ (cider--read-locals-from-bindings-vector)))))) + (add-text-properties (point) sexp-end (list 'cider-locals locals)) + (clojure-forward-logical-sexp 1) + (cider--parse-and-apply-locals sexp-end locals))) + (goto-char sexp-end)))) + +(defun cider--update-locals-for-region (beg end) + "Update the `cider-locals' text property for region from BEG to END." + (save-excursion + (goto-char beg) + ;; If the inside of a `ns' form changed, reparse it from the start. + (when (and (not (bobp)) + (get-text-property (1- (point)) 'cider-block-dynamic-font-lock)) + (ignore-errors (beginning-of-defun-raw))) + (save-excursion + ;; Move up until we reach a sexp that encloses the entire region (or + ;; a top-level sexp), and set that as the new BEG. + (goto-char end) + (while (and (or (> (point) beg) + (not (eq (char-after) ?\())) + (condition-case nil + (progn (backward-up-list) t) + (scan-error nil)))) + (setq beg (min beg (point))) + ;; If there are locals above the current sexp, reapply them to the + ;; current sexp. + (let ((locals-above (when (> beg (point-min)) + (get-text-property (1- beg) 'cider-locals)))) + (condition-case nil + (clojure-forward-logical-sexp 1) + (error (goto-char end))) + (add-text-properties beg (point) `(cider-locals ,locals-above)) + ;; Extend the region being font-locked to include whole sexps. + (setq end (max end (point))) + (goto-char beg) + (ignore-errors + (cider--parse-and-apply-locals end locals-above)))))) + +(defun cider--docview-as-string (sym info) + "Return a string of what would be displayed by `cider-docview-render'. +SYM and INFO is passed to `cider-docview-render'" + (with-temp-buffer + (cider-docview-render (current-buffer) sym info :compact :for-tooltip) ;; :compact because we don't want huge tooltips - especially for Java + (goto-char (point-max)) + (forward-line -1) + (replace-regexp-in-string + "[`']" "\\\\=\\&" + (buffer-substring-no-properties (point-min) (1- (point)))))) + +(defcustom cider-use-tooltips t + "If non-nil, CIDER displays mouse-over tooltips. +It does this as well as the `help-echo' mechanism." + :group 'cider + :type 'boolean + :package-version '(cider "0.12.0")) + +(defvar cider--debug-mode-response) +(defvar cider--debug-mode) + +(defun cider--help-echo (_ obj pos) + "Return the help-echo string for OBJ at POS. +See \(info \"(elisp) Special Properties\")" + (while-no-input + (when (and (bufferp obj) + (cider-connected-p) + cider-use-tooltips + (not (eq help-at-pt-display-when-idle t))) + (with-current-buffer obj + (ignore-errors + (save-excursion + (goto-char pos) + (when-let* ((sym (cider-symbol-at-point))) + (if (member sym (get-text-property (point) 'cider-locals)) + (concat (format "`%s' is a local" sym) + (when cider--debug-mode + (let* ((locals (nrepl-dict-get cider--debug-mode-response "locals")) + (local-val (cadr (assoc sym locals)))) + (format " with value:\n%s" local-val)))) + (let* ((info (cider-sync-request:info sym nil nil (cider-completion-get-context t))) + (candidates (nrepl-dict-get info "candidates"))) + (if candidates + (concat "There were ambiguities resolving this symbol:\n\n" + (mapconcat (lambda (x) (cider--docview-as-string sym x)) + candidates + (concat "\n\n" (make-string 60 ?-) "\n\n"))) + (cider--docview-as-string sym info))))))))))) + +(defun cider--wrap-fontify-locals (func) + "Return a function that will call FUNC after parsing local variables. +The local variables are stored in a list under the `cider-locals' text +property." + (lambda (beg end &rest rest) + (with-silent-modifications + (remove-text-properties beg end '(cider-locals nil cider-block-dynamic-font-lock nil)) + (when cider-use-tooltips + (add-text-properties beg end '(help-echo cider--help-echo))) + (when cider-font-lock-dynamically + (cider--update-locals-for-region beg end))) + (apply func beg end rest))) + + +;;; Minor-mode definition + +(if (and (> emacs-major-version 28) + (not (boundp 'x-gtk-use-system-tooltips))) + ;; The x-gtk prefix has been dropped in Emacs 29 + (defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips) + (defvar x-gtk-use-system-tooltips)) + +;;;###autoload +(define-minor-mode cider-mode + "Minor mode for REPL interaction from a Clojure buffer. + +\\{cider-mode-map}" + :init-value nil + :lighter cider-mode-line + :keymap cider-mode-map + (if cider-mode + (progn + (setq-local sesman-system 'CIDER) + (cider-eldoc-setup) + (add-hook 'completion-at-point-functions #'cider-complete-at-point nil t) + (font-lock-add-keywords nil cider--static-font-lock-keywords) + (cider-refresh-dynamic-font-lock) + (font-lock-add-keywords nil cider--reader-conditionals-font-lock-keywords) + ;; `font-lock-mode' might get enabled after `cider-mode'. + (add-hook 'font-lock-mode-hook #'cider-refresh-dynamic-font-lock nil 'local) + (setq-local font-lock-fontify-region-function + (cider--wrap-fontify-locals font-lock-fontify-region-function)) + ;; GTK tooltips look bad, and we have no control over the face. + (setq-local x-gtk-use-system-tooltips nil) + ;; `tooltip' has variable-width by default, which looks terrible. + (set-face-attribute 'tooltip nil :inherit 'unspecified) + (when cider-dynamic-indentation + (setq-local clojure-get-indent-function #'cider--get-symbol-indent)) + (setq-local clojure-expected-ns-function #'cider-expected-ns) + (when cider-use-xref + (add-hook 'xref-backend-functions #'cider--xref-backend cider-xref-fn-depth 'local)) + (setq next-error-function #'cider-jump-to-compilation-error)) + ;; Mode cleanup + (mapc #'kill-local-variable '(next-error-function + x-gtk-use-system-tooltips + font-lock-fontify-region-function + clojure-get-indent-function)) + (remove-hook 'completion-at-point-functions #'cider-complete-at-point t) + (when cider-use-xref + (remove-hook 'xref-backend-functions #'cider--xref-backend 'local)) + (remove-hook 'font-lock-mode-hook #'cider-refresh-dynamic-font-lock 'local) + (font-lock-add-keywords nil cider--reader-conditionals-font-lock-keywords) + (font-lock-remove-keywords nil cider--dynamic-font-lock-keywords) + (font-lock-remove-keywords nil cider--static-font-lock-keywords) + (font-lock-flush) + (remove-hook 'completion-at-point-functions #'cider-complete-at-point t))) + +(defun cider-set-buffer-ns (ns) + "Set this buffer's namespace to NS and refresh font-locking." + (setq-local cider-buffer-ns ns) + (when (or cider-mode (derived-mode-p 'cider-repl-mode)) + (cider-refresh-dynamic-font-lock ns))) + +(provide 'cider-mode) + +;;; cider-mode.el ends here diff --git a/elpa/cider-20241203.1607/cider-ns.el b/elpa/cider-20241203.1607/cider-ns.el new file mode 100644 index 00000000..70e06d0b --- /dev/null +++ b/elpa/cider-20241203.1607/cider-ns.el @@ -0,0 +1,336 @@ +;;; cider-ns.el --- Namespace manipulation functionality -*- lexical-binding: t -*- + +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Bozhidar Batsov +;; Artur Malabarba + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Smart code refresh functionality based on ideas from: +;; http://thinkrelevance.com/blog/2013/06/04/clojure-workflow-reloaded +;; +;; Note that refresh with clojure.tools.namespace.repl is a smarter way to +;; reload code: the traditional way to reload Clojure code without restarting +;; the JVM is (require ... :reload) or an editor/IDE feature that does the same +;; thing. +;; +;; This has several problems: +;; +;; If you modify two namespaces which depend on each other, you must remember to +;; reload them in the correct order to avoid compilation errors. +;; +;; If you remove definitions from a source file and then reload it, those +;; definitions are still available in memory. If other code depends on those +;; definitions, it will continue to work but will break the next time you +;; restart the JVM. +;; +;; If the reloaded namespace contains defmulti, you must also reload all of the +;; associated defmethod expressions. +;; +;; If the reloaded namespace contains defprotocol, you must also reload any +;; records or types implementing that protocol and replace any existing +;; instances of those records/types with new instances. +;; +;; If the reloaded namespace contains macros, you must also reload any +;; namespaces which use those macros. +;; +;; If the running program contains functions which close over values in the +;; reloaded namespace, those closed-over values are not updated (This is common +;; in web applications which construct the "handler stack" as a composition of +;; functions.) + +;;; Code: + +(require 'map) +(require 'seq) +(require 'subr-x) + +(require 'cider-client) +(require 'cider-eval) +(require 'cider-popup) +(require 'cider-stacktrace) +(require 'cider-util) + +(defcustom cider-ns-save-files-on-refresh 'prompt + "Controls whether to prompt to save files before refreshing. +If nil, files are not saved. +If 'prompt, the user is prompted to save files if they have been modified. +If t, save the files without confirmation." + :type '(choice (const prompt :tag "Prompt to save files if they have been modified") + (const nil :tag "Don't save the files") + (const t :tag "Save the files without confirmation")) + :group 'cider + :package-version '(cider . "0.15.0")) + +(defcustom cider-ns-save-files-on-refresh-modes '(clojure-mode clojure-ts-mode) + "Controls which files might be saved before refreshing. +If a list of modes, any buffers visiting files on the classpath whose major +mode is derived from any of the modes might be saved. +If t, all buffers visiting files on the classpath might be saved." + :type '(choice listp + (const t)) + :group 'cider + :package-version '(cider . "0.21.0")) + +(defconst cider-ns-refresh-log-buffer "*cider-ns-refresh-log*") + +(defcustom cider-ns-refresh-show-log-buffer nil + "Controls when to display the refresh log buffer. +If non-nil, the log buffer will be displayed every time `cider-ns-refresh' is +called. If nil, the log buffer will still be written to, but will never be +displayed automatically. Instead, the most relevant information will be +displayed in the echo area." + :type '(choice (const :tag "always" t) + (const :tag "never" nil)) + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-ns-refresh-before-fn nil + "Clojure function for `cider-ns-refresh' to call before reloading. +If nil, nothing will be invoked before reloading. Must be a +namespace-qualified function of zero arity. Any thrown exception will +prevent reloading from occurring." + :type 'string + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-ns-refresh-after-fn nil + "Clojure function for `cider-ns-refresh' to call after reloading. +If nil, nothing will be invoked after reloading. Must be a +namespace-qualified function of zero arity." + :type 'string + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-ns-code-reload-tool 'tools.namespace + "Which tool to use for ns refresh. +Current options: tools.namespace and clj-reload." + :group 'cider + :type '(choice (const :tag "tools.namespace https://github.com/clojure/tools.namespace" tools.namespace) + (const :tag "clj-reload https://github.com/tonsky/clj-reload" clj-reload)) + :package-version '(cider . "1.14.0")) + +(defun cider-ns--present-error (error) + "Render the `ERROR' stacktrace, +and jump to the adequate file/line location, +presenting the error message as an overlay." + (let* ((buf) + (jump-args (seq-some (lambda (cause-dict) ;; a dict representing an exception cause + (nrepl-dbind-response cause-dict (file-url line column) + (when (and file-url + ;; jars are unlikely sources of user errors, so we favor the next `cause-dict': + (not (string-prefix-p "jar:" file-url)) + line) + (setq buf (cider--find-buffer-for-file file-url)) + (list buf (cons line column))))) + error))) + (when jump-args + (apply #'cider-jump-to jump-args) + (when-let ((message (seq-some (lambda (cause-dict) + (nrepl-dbind-response cause-dict (message) + message)) + ;; `reverse' the causes as the first one typically is a CompilerException, which the second one is the actual exception: + (reverse error)))) + (with-current-buffer buf + (let ((cider-result-use-clojure-font-lock nil) + (trimmed-err (funcall cider-inline-error-message-function message))) + (cider--display-interactive-eval-result trimmed-err + 'error + (save-excursion + (end-of-defun) + (point)) + 'cider-error-overlay-face))))) + (cider--render-stacktrace-causes error) + ;; Select the window displaying the 'culprit' buffer so that the user can immediately fix it, + ;; as most times the displayed stacktrace doesn't need much inspection: + (when buf + (select-window (get-buffer-window buf))))) + +(defun cider-ns-refresh--handle-response (response log-buffer) + "Refresh LOG-BUFFER with RESPONSE." + (nrepl-dbind-response response (out err reloading progress status error error-ns after before) + (cl-flet* ((log (message &optional face) + (cider-emit-into-popup-buffer log-buffer message face t)) + + (log-echo (message &optional face) + (log message face) + (unless cider-ns-refresh-show-log-buffer + (let ((message-truncate-lines t)) + (message "cider-ns-refresh: %s" message))))) + (cond + (out + (log out)) + + (err + (log err 'font-lock-warning-face)) + + ((member "invoking-before" status) + (log-echo (format "Calling %s\n" before) 'font-lock-string-face)) + + ((member "invoked-before" status) + (log-echo (format "Successfully called %s\n" before) 'font-lock-string-face)) + + ((member "invoked-not-resolved" status) + (log-echo "Could not resolve refresh function\n" 'font-lock-string-face)) + + (reloading + (log-echo (format "Reloading %s\n" reloading) 'font-lock-string-face)) + + (progress + (log-echo progress 'font-lock-string-face)) + + ((member "reloading" (nrepl-dict-keys response)) + (log-echo "Nothing to reload\n" 'font-lock-string-face)) + + ((member "ok" status) + (log-echo "Reloading successful\n" 'font-lock-string-face)) + + (error-ns + (log-echo (format "Error reloading %s\n" error-ns) 'font-lock-warning-face)) + + ((member "invoking-after" status) + (log-echo (format "Calling %s\n" after) 'font-lock-string-face)) + + ((member "invoked-after" status) + (log-echo (format "Successfully called %s\n" after) 'font-lock-string-face)))) + + (with-selected-window (or (get-buffer-window cider-ns-refresh-log-buffer) + (selected-window)) + (with-current-buffer cider-ns-refresh-log-buffer + (goto-char (point-max)))) + + (when (and (member "error" status) + error) + (cider-ns--present-error error)))) + +(defun cider-ns-refresh--save-modified-buffers () + "Ensure any relevant modified buffers are saved before refreshing. +Its behavior is controlled by `cider-ns-save-files-on-refresh' and +`cider-ns-save-files-on-refresh-modes'." + (when cider-ns-save-files-on-refresh + (let ((dirs (seq-filter #'file-directory-p + (cider-classpath-entries)))) + (save-some-buffers + (not (eq cider-ns-save-files-on-refresh 'prompt)) + (lambda () + (and (seq-some #'derived-mode-p cider-ns-save-files-on-refresh-modes) + (seq-some (lambda (dir) + (file-in-directory-p buffer-file-name dir)) + dirs))))))) + +(defun cider-ns--reload-op (op-name) + "Return the reload operation to use. +Based on OP-NAME and the value of cider-ns-code-reload-tool defcustom." + (list "op" + (if (eq cider-ns-code-reload-tool 'tools.namespace) + (cond ((string= op-name "reload") "refresh") + ((string= op-name "reload-all") "refresh-all") + ((string= op-name "reload-clear") "refresh-clear")) + + (cond ((string= op-name "reload") "cider.clj-reload/reload") + ((string= op-name "reload-all") "cider.clj-reload/reload-all") + ((string= op-name "reload-clear") "cider.clj-reload/reload-clear"))))) + +;;;###autoload +(defun cider-ns-reload (&optional prompt) + "Send a (require 'ns :reload) to the REPL. + +With an argument PROMPT, it prompts for a namespace name. This is the +Clojure out of the box reloading experience and does not rely on +org.clojure/tools.namespace. See Commentary of this file for a longer list +of differences. From the Clojure doc: \":reload forces loading of all the +identified libs even if they are already loaded\"." + (interactive "P") + (when-let ((ns (if prompt + (string-remove-prefix "'" (read-from-minibuffer "Namespace: " (cider-get-ns-name))) + (cider-get-ns-name)))) + (cider-interactive-eval (format "(require '%s :reload)" ns)))) + +;;;###autoload +(defun cider-ns-reload-all (&optional prompt) + "Send a (require 'ns :reload-all) to the REPL. + +With an argument PROMPT, it prompts for a namespace name. This is the +Clojure out of the box reloading experience and does not rely on +org.clojure/tools.namespace. See Commentary of this file for a longer list +of differences. From the Clojure doc: \":reload-all implies :reload and +also forces loading of all libs that the identified libs directly or +indirectly load via require\"." + (interactive "P") + (when-let ((ns (if prompt + (string-remove-prefix "'" (read-from-minibuffer "Namespace: " (cider-get-ns-name))) + (cider-get-ns-name)))) + (cider-interactive-eval (format "(require '%s :reload-all)" ns)))) + +;;;###autoload +(defun cider-ns-refresh (&optional mode) + "Reload modified and unloaded namespaces, using the Reloaded Workflow. +Uses the configured 'refresh dirs' \(defaults to the classpath dirs). + +With a single prefix argument, or if MODE is `refresh-all', reload all +namespaces on the classpath dirs unconditionally. + +With a double prefix argument, or if MODE is `clear', clear the state of +the namespace tracker before reloading. This is useful for recovering from +some classes of error (for example, those caused by circular dependencies) +that a normal reload would not otherwise recover from. The trade-off of +clearing is that stale code from any deleted files may not be completely +unloaded. + +With a negative prefix argument, or if MODE is `inhibit-fns', prevent any +refresh functions (defined in `cider-ns-refresh-before-fn' and +`cider-ns-refresh-after-fn') from being invoked." + (interactive "p") + (cider-ensure-connected) + (cider-ensure-op-supported "refresh") + (cider-ensure-op-supported "cider.clj-reload/reload") + (cider-ns-refresh--save-modified-buffers) + (let ((clear? (member mode '(clear 16))) + (all? (member mode '(refresh-all 4))) + (inhibit-refresh-fns (member mode '(inhibit-fns -1)))) + (cider-map-repls :clj + (lambda (conn) + ;; Inside the lambda, so the buffer is not created if we error out. + (let ((log-buffer (or (get-buffer cider-ns-refresh-log-buffer) + (cider-make-popup-buffer cider-ns-refresh-log-buffer)))) + (when cider-ns-refresh-show-log-buffer + (cider-popup-buffer-display log-buffer)) + (when inhibit-refresh-fns + (cider-emit-into-popup-buffer log-buffer + "inhibiting refresh functions\n" + nil + t)) + (when clear? + (cider-nrepl-send-sync-request (cider-ns--reload-op "reload-clear") conn)) + (cider-nrepl-send-request + (thread-last + (map-merge 'list + `(,(cider-ns--reload-op (if all? "reload-all" "reload"))) + (cider--nrepl-print-request-map fill-column) + (when (and (not inhibit-refresh-fns) cider-ns-refresh-before-fn) + `(("before" ,cider-ns-refresh-before-fn))) + (when (and (not inhibit-refresh-fns) cider-ns-refresh-after-fn) + `(("after" ,cider-ns-refresh-after-fn)))) + (seq-mapcat #'identity)) + (lambda (response) + (cider-ns-refresh--handle-response response log-buffer)) + conn)))))) + +(provide 'cider-ns) +;;; cider-ns.el ends here diff --git a/elpa/cider-20241203.1607/cider-overlays.el b/elpa/cider-20241203.1607/cider-overlays.el new file mode 100644 index 00000000..511f89a1 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-overlays.el @@ -0,0 +1,368 @@ +;;; cider-overlays.el --- Managing CIDER overlays -*- lexical-binding: t; -*- + +;; Copyright © 2015-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors + +;; Author: Artur Malabarba + +;; 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 . + +;;; Commentary: + +;; Use `cider--make-overlay' to place a generic overlay at point. Or use +;; `cider--make-result-overlay' to place an interactive eval result overlay at +;; the end of a specified line. + +;;; Code: + +(require 'cider-common) +(require 'subr-x) +(require 'cl-lib) + + +;;; Customization +(defface cider-result-overlay-face + '((((class color) (background light)) + :background "grey90" :box (:line-width -1 :color "yellow")) + (((class color) (background dark)) + :background "grey10" :box (:line-width -1 :color "black"))) + "Face used to display evaluation results at the end of line. +If `cider-overlays-use-font-lock' is non-nil, this face is +applied with lower priority than the syntax highlighting." + :group 'cider + :package-version '(cider "0.9.1")) + +(defface cider-error-overlay-face + '((((class color) (background light)) + :background "orange red" + :extend t) + (((class color) (background dark)) + :background "firebrick" + :extend t)) + "Like `cider-result-overlay-face', but for evaluation errors." + :group 'cider + :package-version '(cider "0.25.0")) + +(defcustom cider-result-use-clojure-font-lock t + "If non-nil, interactive eval results are font-locked as Clojure code." + :group 'cider + :type 'boolean + :package-version '(cider . "0.10.0")) + +(defcustom cider-overlays-use-font-lock t + "If non-nil, results overlays are font-locked as Clojure code. +If nil, apply `cider-result-overlay-face' to the entire overlay instead of +font-locking it." + :group 'cider + :type 'boolean + :package-version '(cider . "0.10.0")) + +(defcustom cider-use-overlays 'both + "Whether to display evaluation results with overlays. +If t, use overlays determined by `cider-result-overlay-position'. +If `errors-only', use overlays determined by `cider-result-overlay-position', +but only for error messages - other messages will be displayed on the echo area. +If nil, display on the echo area. +If `both', display on both places. + +Only applies to evaluation commands. To configure the debugger overlays, +see `cider-debug-use-overlays'." + :type '(choice (const :tag "Display using overlays" t) + (const :tag "Display in echo area" nil) + (const :tag "Both" both)) + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-result-overlay-position 'at-eol + "Where to display result overlays for inline evaluation and the debugger. +If 'at-eol, display at the end of the line. +If 'at-point, display at the end of the respective sexp." + :group 'cider + :type ''(choice (const :tag "End of line" at-eol) + (const :tag "End of sexp" at-point)) + :package-version '(cider . "0.23.0")) + +(defcustom cider-eval-result-prefix "=> " + "The prefix displayed in the minibuffer before a result value." + :type 'string + :group 'cider + :package-version '(cider . "0.5.0")) + +(defcustom cider-eval-result-duration 'command + "Duration, in seconds, of CIDER's eval-result overlays. +If nil, overlays last indefinitely. +If the symbol `command', they're erased after the next command. +If the symbol `change', they last until the next change to the buffer. +Also see `cider-use-overlays'." + :type '(choice (integer :tag "Duration in seconds") + (const :tag "Until next command" command) + (const :tag "Until next buffer change" change) + (const :tag "Last indefinitely" nil)) + :group 'cider + :package-version '(cider . "0.10.0")) + + +;;; Overlay logic +(defun cider--delete-overlay (ov &rest _) + "Safely delete overlay OV. +Never throws errors, and can be used in an overlay's modification-hooks." + (ignore-errors (delete-overlay ov))) + +(defun cider--make-overlay (l r type &rest props) + "Place an overlay between L and R and return it. +TYPE is a symbol put on the overlay's category property. It is used to +easily remove all overlays from a region with: + (remove-overlays start end 'category TYPE) +PROPS is a plist of properties and values to add to the overlay." + (let ((o (make-overlay l (or r l) (current-buffer)))) + (overlay-put o 'category type) + (overlay-put o 'cider-temporary t) + (while props (overlay-put o (pop props) (pop props))) + (push #'cider--delete-overlay (overlay-get o 'modification-hooks)) + o)) + +(defun cider--remove-result-overlay (&rest _) + "Remove result overlay from current buffer. +This function also removes itself from `post-command-hook' and +`after-change-functions'." + (let ((hook (pcase cider-eval-result-duration + (`command 'post-command-hook) + (`change 'after-change-functions)))) + (remove-hook hook #'cider--remove-result-overlay 'local)) + (remove-overlays nil nil 'category 'result)) + +(defun cider--remove-result-overlay-after-command () + "Add `cider--remove-result-overlay' locally to `post-command-hook'. +This function also removes itself from `post-command-hook'." + (remove-hook 'post-command-hook #'cider--remove-result-overlay-after-command 'local) + (add-hook 'post-command-hook #'cider--remove-result-overlay nil 'local)) + +(defface cider-fringe-good-face + '((((class color) (background light)) :foreground "lightgreen") + (((class color) (background dark)) :foreground "darkgreen")) + "Face used on the fringe indicator for successful evaluation." + :group 'cider) + +(defconst cider--fringe-overlay-good + (propertize " " 'display '(left-fringe empty-line cider-fringe-good-face)) + "The before-string property that adds a green indicator on the fringe.") + +(defcustom cider-use-fringe-indicators t + "Whether to display evaluation indicators on the left fringe." + :safe #'booleanp + :group 'cider + :type 'boolean + :package-version '(cider . "0.13.0")) + +(defun cider--make-fringe-overlay (&optional end) + "Place an eval indicator at the fringe before a sexp. +END is the position where the sexp ends, and defaults to point." + (when cider-use-fringe-indicators + (with-current-buffer (if (markerp end) + (marker-buffer end) + (current-buffer)) + (save-excursion + (if end + (goto-char end) + (setq end (point))) + (clojure-forward-logical-sexp -1) + ;; Create the green-circle overlay. + (cider--make-overlay (point) end 'cider-fringe-indicator + 'before-string cider--fringe-overlay-good))))) + +(cl-defun cider--make-result-overlay (value &rest props &key where duration (type 'result) + (format (concat " " cider-eval-result-prefix "%s ")) + (prepend-face 'cider-result-overlay-face) + &allow-other-keys) + "Place an overlay displaying VALUE at the position determined by WHERE. +VALUE is used as the overlay's after-string property, meaning it is +displayed at the end of the overlay. +Return nil if the overlay was not placed or if it might not be visible, and +return the overlay otherwise. + +Return the overlay if it was placed successfully, and nil if it failed. + +This function takes some optional keyword arguments: + + If WHERE is a number or a marker, apply the overlay as determined by + `cider-result-overlay-position'. If it is a cons cell, the car and cdr + determine the start and end of the overlay. + DURATION takes the same possible values as the + `cider-eval-result-duration' variable. + TYPE is passed to `cider--make-overlay' (defaults to `result'). + FORMAT is a string passed to `format'. It should have + exactly one %s construct (for VALUE). + +All arguments beyond these (PROPS) are properties to be used on the +overlay." + (declare (indent 1)) + (while (keywordp (car props)) + (setq props (cdr (cdr props)))) + ;; If the marker points to a dead buffer, don't do anything. + (let ((buffer (cond + ((markerp where) (marker-buffer where)) + ((markerp (car-safe where)) (marker-buffer (car where))) + (t (current-buffer))))) + (with-current-buffer buffer + (save-excursion + (when (number-or-marker-p where) + (goto-char where)) + ;; Make sure the overlay is actually at the end of the sexp. + (skip-chars-backward "\r\n[:blank:]") + (let* ((beg (if (consp where) + (car where) + (save-excursion + (clojure-backward-logical-sexp 1) + (point)))) + (end (if (consp where) + (cdr where) + (pcase cider-result-overlay-position + ('at-eol (line-end-position)) + ('at-point (point))))) + ;; Specify `default' face, otherwise unformatted text will + ;; inherit the face of the following text. + (display-string (format (propertize format 'face 'default) value)) + (o nil)) + ;; Remove any overlay at the position we're creating a new one, if it + ;; exists. + (remove-overlays beg end 'category type) + (funcall (if cider-overlays-use-font-lock + #'font-lock-prepend-text-property + #'put-text-property) + 0 (length display-string) + 'face prepend-face + display-string) + ;; If the display spans multiple lines or is very long, display it at + ;; the beginning of the next line. + (when (or (string-match "\n." display-string) + (> (string-width display-string) + (- (window-width) (current-column)))) + (setq display-string (concat " \n" display-string))) + ;; Put the cursor property only once we're done manipulating the + ;; string, since we want it to be at the first char. + (put-text-property 0 1 'cursor 0 display-string) + (when (> (string-width display-string) (* 3 (window-width))) + (setq display-string + (concat (substring display-string 0 (* 3 (window-width))) + (substitute-command-keys + "...\nResult truncated. Type `\\[cider-inspect-last-result]' to inspect it.")))) + ;; Create the result overlay. + (setq o (apply #'cider--make-overlay + beg end type + 'after-string display-string + props)) + (pcase duration + ((pred numberp) (run-at-time duration nil #'cider--delete-overlay o)) + (`command + ;; Since the previous overlay was already removed above, we should + ;; remove the hook to remove all overlays after this function + ;; ends. Otherwise, we would inadvertently remove the newly created + ;; overlay too. + (remove-hook 'post-command-hook 'cider--remove-result-overlay 'local) + ;; If inside a command-loop, tell `cider--remove-result-overlay' + ;; to only remove after the *next* command. + (if this-command + (add-hook 'post-command-hook + #'cider--remove-result-overlay-after-command + nil 'local) + (cider--remove-result-overlay-after-command))) + (`change + (add-hook 'after-change-functions + #'cider--remove-result-overlay + nil 'local))) + (when-let* ((win (get-buffer-window buffer))) + ;; Left edge is visible. + (when (and (<= (window-start win) (point) (window-end win)) + ;; Right edge is visible. This is a little conservative + ;; if the overlay contains line breaks. + (or (< (+ (current-column) (string-width value)) + (window-width win)) + (not truncate-lines))) + o))))))) + + +;;; Displaying eval result +(defun cider--display-interactive-eval-result (value value-type &optional point overlay-face) + "Display the result VALUE of an interactive eval operation. +VALUE is syntax-highlighted and displayed in the echo area. +VALUE-TYPE is one of: `value', `error'. +OVERLAY-FACE is the face applied to the overlay, which defaults to +`cider-result-overlay-face' if nil. +If POINT and `cider-use-overlays' are non-nil, it is also displayed in an +overlay at the end of the line containing POINT. +Note that, while POINT can be a number, it's preferable to be a marker, as +that will better handle some corner cases where the original buffer is not +focused." + (cl-assert (symbolp value-type)) ;; We assert because for avoiding confusion with the optional args. + (let* ((value (string-trim-right value)) + (font-value (if cider-result-use-clojure-font-lock + (cider-font-lock-as-clojure value) + value)) + (used-overlay (when (and point + cider-use-overlays + (if (equal 'error value-type) + t + (not (equal 'errors-only cider-use-overlays)))) + (cider--make-result-overlay font-value + :where point + :duration cider-eval-result-duration + :prepend-face (or overlay-face 'cider-result-overlay-face)))) + (msg (format "%s%s" cider-eval-result-prefix font-value)) + (max-msg-length (* (floor (* (frame-height) max-mini-window-height)) + (frame-width))) + (msg (if (> (string-width msg) max-msg-length) + (format "%s..." (substring msg 0 (- max-msg-length 3))) + msg))) + (message + "%s" + (propertize msg + ;; The following hides the message from the echo-area, but + ;; displays it in the Messages buffer. We only hide the message + ;; if the user wants to AND if the overlay succeeded. + 'invisible (and used-overlay + (not (eq cider-use-overlays 'both))))))) + + +;;; Fragile buttons +(defface cider-fragile-button-face + '((((type graphic)) + :box (:line-width 3 :style released-button) + :inherit font-lock-warning-face) + (t :inverse-video t)) + "Face for buttons that vanish when clicked." + :package-version '(cider . "0.12.0") + :group 'cider) + +(define-button-type 'cider-fragile + 'action #'cider--overlay-destroy + 'follow-link t + 'face nil + 'modification-hooks '(cider--overlay-destroy) + 'help-echo "RET: delete this.") + +(defun cider--overlay-destroy (ov &rest r) + "Delete overlay OV and its underlying text. +If any other arguments are given (collected in R), only actually do anything +if the first one is non-nil. This is so it works in `modification-hooks'." + (unless (and r (not (car r))) + (let ((inhibit-modification-hooks t) + (beg (copy-marker (overlay-start ov))) + (end (copy-marker (overlay-end ov)))) + (delete-overlay ov) + (delete-region beg end) + (goto-char beg) + (when (= (char-after) (char-before) ?\n) + (delete-char 1))))) + +(provide 'cider-overlays) +;;; cider-overlays.el ends here diff --git a/elpa/cider-20241203.1607/cider-pkg.el b/elpa/cider-20241203.1607/cider-pkg.el new file mode 100644 index 00000000..31d48dbf --- /dev/null +++ b/elpa/cider-20241203.1607/cider-pkg.el @@ -0,0 +1,22 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "cider" "20241203.1607" + "Clojure Interactive Development Environment that Rocks." + '((emacs "26") + (clojure-mode "5.19") + (parseedn "1.2.1") + (queue "0.2") + (spinner "1.7") + (seq "2.22") + (sesman "0.3.2") + (transient "0.4.1")) + :url "https://github.com/clojure-emacs/cider" + :commit "588c5790f0c09f5c09076885e11a73eaef70c262" + :revdesc "588c5790f0c0" + :keywords '("languages" "clojure" "cider") + :authors '(("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")) + :maintainers '(("Bozhidar Batsov" . "bozhidar@batsov.dev"))) diff --git a/elpa/cider-20241203.1607/cider-popup.el b/elpa/cider-20241203.1607/cider-popup.el new file mode 100644 index 00000000..0f0e43e0 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-popup.el @@ -0,0 +1,158 @@ +;;; cider-popup.el --- Creating and quitting popup buffers -*- lexical-binding: t; -*- + +;; Copyright © 2015-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors + +;; Author: Artur Malabarba + +;; 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 . + +;;; Commentary: + +;; Common functionality for dealing with popup buffers. + +;;; Code: + +(require 'subr-x) + +(define-minor-mode cider-popup-buffer-mode + "Mode for CIDER popup buffers." + :lighter (" cider-tmp") + :keymap '(("q" . cider-popup-buffer-quit-function))) + +(defvar-local cider-popup-buffer-quit-function #'cider-popup-buffer-quit + "The function that is used to quit a temporary popup buffer.") + +(defun cider-popup-buffer-quit-function (&optional kill-buffer-p) + "Wrapper to invoke the function `cider-popup-buffer-quit-function'. +KILL-BUFFER-P is passed along." + (interactive) + (funcall cider-popup-buffer-quit-function kill-buffer-p)) + +(defun cider-popup-buffer (name &optional select mode ancillary) + "Create new popup buffer called NAME. +If SELECT is non-nil, select the newly created window. +If major MODE is non-nil, enable it for the popup buffer. +If ANCILLARY is non-nil, the buffer is added to `cider-ancillary-buffers' +and automatically removed when killed." + (thread-first (cider-make-popup-buffer name mode ancillary) + (buffer-name) + (cider-popup-buffer-display select))) + +(defun cider-popup-buffer-display (buffer-name &optional select) + "Display the buffer identified by BUFFER-NAME. +If SELECT is non-nil, select the buffer. + +You can customize how the window will be chosen/created +by adding BUFFER-NAME to the `special-display-buffer-names' list." + (let ((buffer-name (if (bufferp buffer-name) ;; ensure buffer-name is a string + (buffer-name buffer-name) + buffer-name))) + ;; if `buffer-name' belongs to `special-display-buffer-names', + ;; delegate to that mechanism the displaying of the buffer, + ;; otherwise the displaying would happen twice (ance through `special-display-buffer-names', + ;; another time through `cider-popup-buffer-display'): + (if (and (boundp 'special-display-buffer-names) + (seq-find (lambda (entry) + ;; entry can be either a list or a string + (equal (if (listp entry) (car entry) entry) buffer-name)) + special-display-buffer-names)) + (progn + (display-buffer buffer-name) + (when select + (when-let ((window (get-buffer-window buffer-name))) + (select-window window)))) + (let ((window (get-buffer-window buffer-name 'visible))) + (when window + (with-current-buffer buffer-name + (set-window-point window (point)))) + ;; If the buffer we are popping up is already displayed in the selected + ;; window, the below `inhibit-same-window' logic will cause it to be + ;; displayed twice - so we early out in this case. Note that we must check + ;; `selected-window', as async request handlers are executed in the context + ;; of the current connection buffer (i.e. `current-buffer' is dynamically + ;; bound to that). + (unless (eq window (selected-window)) + ;; Non nil `inhibit-same-window' ensures that current window is not covered + ;; Non nil `inhibit-switch-frame' ensures that the other frame is not selected + ;; if that's where the buffer is being shown. + (funcall (if select #'pop-to-buffer #'display-buffer) + buffer-name `(nil . ((inhibit-same-window . + ;; A non-nil value prevents the same window from being used for display: + ,pop-up-windows) + (reusable-frames . + ;; choose any visible frame + visible))))))) + (get-buffer buffer-name))) + +(defun cider-popup-buffer-quit (&optional kill) + "Quit the current (temp) window. +Bury its buffer using `quit-restore-window'. +If prefix argument KILL is non-nil, kill the buffer instead of burying it." + (interactive) + (quit-restore-window (selected-window) (if kill 'kill 'append))) + +(defvar-local cider-popup-output-marker nil) + +(defvar cider-ancillary-buffers nil + "A list ancillary buffers created by the various CIDER commands. +We track them mostly to be able to clean them up on quit.") + +(defun cider-make-popup-buffer (name &optional mode ancillary) + "Create a temporary buffer called NAME using major MODE (if specified). +If ANCILLARY is non-nil, the buffer is added to `cider-ancillary-buffers' +and automatically removed when killed." + (with-current-buffer (get-buffer-create name) + (kill-all-local-variables) + (setq buffer-read-only nil) + (erase-buffer) + (when mode + (funcall mode)) + (cider-popup-buffer-mode 1) + (setq cider-popup-output-marker (point-marker)) + (setq buffer-read-only t) + (when ancillary + (add-to-list 'cider-ancillary-buffers name) + (add-hook 'kill-buffer-hook + (lambda () + (setq cider-ancillary-buffers + (remove name cider-ancillary-buffers))) + nil 'local)) + (current-buffer))) + +(defun cider-emit-into-popup-buffer (buffer value &optional face inhibit-indent) + "Emit into BUFFER the provided VALUE optionally using FACE. +Indent emitted value (usually a sexp) unless INHIBIT-INDENT is specified +and non-nil." + ;; Long string output renders Emacs unresponsive and users might intentionally + ;; kill the frozen popup buffer. Therefore, we don't re-create the buffer and + ;; silently ignore the output. + (when (buffer-live-p buffer) + (with-current-buffer buffer + (let ((inhibit-read-only t) + (buffer-undo-list t) + (moving (= (point) cider-popup-output-marker))) + (save-excursion + (goto-char cider-popup-output-marker) + (let ((value-str (format "%s" value))) + (when face + (add-face-text-property 0 (length value-str) face nil value-str)) + (insert value-str)) + (unless inhibit-indent + (indent-sexp)) + (set-marker cider-popup-output-marker (point))) + (when moving (goto-char cider-popup-output-marker)))))) + +(provide 'cider-popup) + +;;; cider-popup.el ends here diff --git a/elpa/cider-20241203.1607/cider-profile.el b/elpa/cider-20241203.1607/cider-profile.el new file mode 100644 index 00000000..792d4b54 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-profile.el @@ -0,0 +1,216 @@ +;;; cider-profile.el --- CIDER support for profiling -*- lexical-binding: t; -*- + +;; Copyright © 2014-2024 Edwin Watkeys and CIDER contributors + +;; Author: Edwin Watkeys +;; Juan E. Maya + +;; 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 . + +;;; Commentary: + +;; Provides coarse-grained interactive profiling support. +;; Based on earlier work by Edwin Watkeys (https://github.com/thunknyc/nrepl-profile). + +;;; Code: + +(require 'cider-client) +(require 'cider-popup) +(require 'cider-eval) + +(defconst cider-profile-buffer "*cider-profile*") + +(defvar cider-profile-map + (let ((map (define-prefix-command 'cider-profile-map))) + (define-key map (kbd "t") #'cider-profile-toggle) + (define-key map (kbd "C-t") #'cider-profile-toggle) + (define-key map (kbd "c") #'cider-profile-clear) + (define-key map (kbd "C-c") #'cider-profile-clear) + (define-key map (kbd "S") #'cider-profile-summary) + (define-key map (kbd "C-S") #'cider-profile-summary) + (define-key map (kbd "s") #'cider-profile-var-summary) + (define-key map (kbd "C-s") #'cider-profile-var-summary) + (define-key map (kbd "n") #'cider-profile-ns-toggle) + (define-key map (kbd "C-n") #'cider-profile-ns-toggle) + (define-key map (kbd "v") #'cider-profile-var-profiled-p) + (define-key map (kbd "C-v") #'cider-profile-var-profiled-p) + (define-key map (kbd "+") #'cider-profile-samples) + (define-key map (kbd "C-+") #'cider-profile-samples) + map) + "CIDER profiler keymap.") + +(defconst cider-profile-menu + '("Profile" + ["Toggle var profiling" cider-profile-toggle] + ["Toggle namespace profiling" cider-profile-ns-toggle] + "--" + ["Display var profiling status" cider-profile-var-profiled-p] + ["Display max sample count" cider-profile-samples] + ["Display var summary" cider-profile-var-summary] + ["Display summary" cider-profile-summary] + ["Clear data" cider-profile-clear]) + "CIDER profiling submenu.") + +(defun cider-profile--make-response-handler (handler &optional buffer) + "Make a response handler using value handler HANDLER for connection BUFFER. + +Optional argument BUFFER defaults to current buffer." + (nrepl-make-response-handler + (or buffer (current-buffer)) handler nil nil nil)) + +;;;###autoload +(defun cider-profile-samples (&optional query) + "Displays current max-sample-count. +If optional QUERY is specified, set max-sample-count and display new value." + (interactive "P") + (cider-ensure-op-supported "set-max-samples") + (cider-ensure-op-supported "get-max-samples") + (if (not (null query)) + (cider-nrepl-send-request + (let ((max-samples (if (numberp query) query '()))) + (message "query: %s" max-samples) + `("op" "set-max-samples" "max-samples" ,max-samples)) + (cider-profile--make-response-handler + (lambda (_buffer value) + (let ((value (if (zerop (length value)) "unlimited" value))) + (message "max-sample-count is now %s" value))))) + (cider-nrepl-send-request + '("op" "get-max-samples") + (cider-profile--make-response-handler + (lambda (_buffer value) + (let ((value (if (zerop (length value)) "unlimited" value))) + (message "max-sample-count is now %s" value)))))) + query) + +;;;###autoload +(defun cider-profile-var-profiled-p (query) + "Displays the profiling status of var under point. +Prompts for var if none under point or QUERY is present." + (interactive "P") + (cider-ensure-op-supported "is-var-profiled") + (cider-read-symbol-name + "Report profiling status for var: " + (lambda (sym) + (let ((ns (cider-current-ns))) + (cider-nrepl-send-request + `("op" "is-var-profiled" + "ns" ,ns + "sym" ,sym) + (cider-profile--make-response-handler + (lambda (_buffer value) + (pcase value + ("profiled" (message "Profiling is currently enabled for %s/%s" ns sym)) + ("unprofiled" (message "Profiling is currently disabled for %s/%s" ns sym)) + ("unbound" (message "%s/%s is unbound" ns sym))))))))) + query) + +;;;###autoload +(defun cider-profile-ns-toggle (&optional query) + "Toggle profiling for the ns associated with optional QUERY. + +If optional argument QUERY is non-nil, prompt for ns. Otherwise use +current ns." + (interactive "P") + (cider-ensure-op-supported "toggle-profile-ns") + (let ((ns (if query + (completing-read "Toggle profiling for ns: " + (cider-sync-request:ns-list)) + (cider-current-ns)))) + (cider-nrepl-send-request + `("op" "toggle-profile-ns" + "ns" ,ns) + (cider-profile--make-response-handler + (lambda (_buffer value) + (pcase value + ("profiled" (message "Profiling enabled for %s" ns)) + ("unprofiled" (message "Profiling disabled for %s" ns))))))) + query) + +;;;###autoload +(defun cider-profile-toggle (query) + "Toggle profiling for the given QUERY. +Defaults to the symbol at point. +With prefix arg or no symbol at point, prompts for a var." + (interactive "P") + (cider-ensure-op-supported "toggle-profile") + (cider-read-symbol-name + "Toggle profiling for var: " + (lambda (sym) + (let ((ns (cider-current-ns))) + (cider-nrepl-send-request + `("op" "toggle-profile" + "ns" ,ns + "sym" ,sym) + (cider-profile--make-response-handler + (lambda (_buffer value) + (pcase value + ("profiled" (message "Profiling enabled for %s/%s" ns sym)) + ("unprofiled" (message "Profiling disabled for %s/%s" ns sym)) + ("unbound" (message "%s/%s is unbound" ns sym))))))))) + query) + +(defun cider-profile-display-stats (stats-response) + "Displays the STATS-RESPONSE on `cider-profile-buffer`." + (let ((table (nrepl-dict-get stats-response "err"))) + (if cider-profile-buffer + (let ((buffer (cider-make-popup-buffer cider-profile-buffer))) + (with-current-buffer buffer + (let ((inhibit-read-only t)) (insert table))) + (display-buffer buffer) + (let ((window (get-buffer-window buffer))) + (set-window-point window 0) + (select-window window) + (fit-window-to-buffer window))) + (cider-emit-interactive-eval-err-output table)))) + +;;;###autoload +(defun cider-profile-summary () + "Display a summary of currently collected profile data." + (interactive) + (cider-ensure-op-supported "profile-summary") + (cider-profile-display-stats + (cider-nrepl-send-sync-request '("op" "profile-summary")))) + +;;;###autoload +(defun cider-profile-var-summary (query) + "Display profile data for var under point QUERY. +Defaults to the symbol at point. With prefix arg or no symbol at point, +prompts for a var." + (interactive "P") + (cider-ensure-op-supported "profile-var-summary") + (cider-read-symbol-name + "Profile-summary for var: " + (lambda (sym) + (cider-profile-display-stats + (cider-nrepl-send-sync-request + `("op" "profile-var-summary" + "ns" ,(cider-current-ns) + "sym" ,sym))))) + query) + +;;;###autoload +(defun cider-profile-clear () + "Clear any collected profile data." + (interactive) + (cider-ensure-op-supported "clear-profile") + (cider-nrepl-send-request + '("op" "clear-profile") + (cider-profile--make-response-handler + (lambda (_buffer value) + (when (equal value "cleared") + (message "Cleared profile data")))))) + +(provide 'cider-profile) + +;;; cider-profile.el ends here diff --git a/elpa/cider-20241203.1607/cider-repl-history.el b/elpa/cider-20241203.1607/cider-repl-history.el new file mode 100644 index 00000000..ec19298a --- /dev/null +++ b/elpa/cider-20241203.1607/cider-repl-history.el @@ -0,0 +1,721 @@ +;;; cider-repl-history.el --- REPL input history browser -*- lexical-binding: t; -*- + +;; Copyright (c) 2017-2024 John Valente and browse-kill-ring authors + +;; 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 . + +;; This file is not part of GNU Emacs. + +;; Based heavily on browse-kill-ring +;; https://github.com/browse-kill-ring/browse-kill-ring + +;;; Commentary: + +;; REPL input history browser for CIDER. + +;; Allows you to browse the full input history for your REPL buffer, and +;; insert previous commands at the prompt. + +;;; Code: + +(require 'cl-lib) +(require 'cider-popup) +(require 'clojure-mode) +(require 'derived) +(require 'pulse) +(require 'sesman) + +(defconst cider-repl-history-buffer "*cider-repl-history*") + +(defgroup cider-repl-history nil + "A package for browsing and inserting the items in the CIDER command history." + :prefix "cider-repl-history-" + :group 'cider) + +(defvar cider-repl-history-display-styles + '((separated . cider-repl-history-insert-as-separated) + (one-line . cider-repl-history-insert-as-one-line))) + +(defcustom cider-repl-history-display-style 'separated + "How to display the CIDER command history items. + +If `one-line', then replace newlines with \"\\n\" for display. + +If `separated', then display `cider-repl-history-separator' between +entries." + :type '(choice (const :tag "One line" one-line) + (const :tag "Separated" separated)) + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-quit-action 'quit-window + "What action to take when `cider-repl-history-quit' is called. + +If `bury-buffer', then simply bury the *cider-repl-history* buffer, but keep +the window. + +If `bury-and-delete-window', then bury the buffer, and (if there is +more than one window) delete the window. + +If `delete-and-restore', then restore the window configuration to what it was +before `cider-repl-history' was called, and kill the *cider-repl-history* +buffer. + +If `quit-window', then restore the window configuration to what +it was before `cider-repl-history' was called, and bury *cider-repl-history*. +This is the default. + +If `kill-and-delete-window', then kill the *cider-repl-history* buffer, and +delete the window on close. + +Otherwise, it should be a function to call." + ;; Note, if you use one of the non-"delete" options, after you "quit", + ;; the *cider-repl-history* buffer is still available. If you are using + ;; `cider-repl-history-show-preview', and you switch to *cider-repl-history* (i.e., + ;; with C-x b), it will not give the preview unless and until you "update" + ;; the *cider-repl-history* buffer. + ;; + ;; This really should not be an issue, because there's no reason to "switch" + ;; back to the buffer. If you want to get it back, you can just do C-c M-p + ;; from the REPL buffer. + + ;; If you get in this situation and find it annoying, you can either disable + ;; the preview, or set `cider-repl-history-quit-action' to 'delete-and-restore. + ;; Then you will simply not have the *cider-repl-history* buffer after you quit, + ;; and it won't be an issue. + + :type '(choice (const :tag "Bury buffer" + :value bury-buffer) + (const :tag "Bury buffer and delete window" + :value bury-and-delete-window) + (const :tag "Delete window" + :value delete-and-restore) + (const :tag "Save and restore" + :value quit-window) + (const :tag "Kill buffer and delete window" + :value kill-and-delete-window) + function) + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-resize-window nil + "Whether to resize the `cider-repl-history' window to fit its contents. +Value is either t, meaning yes, or a cons pair of integers, + (MAXIMUM . MINIMUM) for the size of the window. MAXIMUM defaults to +the window size chosen by `pop-to-buffer'; MINIMUM defaults to +`window-min-height'." + :type '(choice (const :tag "No" nil) + (const :tag "Yes" t) + (cons (integer :tag "Maximum") (integer :tag "Minimum"))) + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-separator ";;;;;;;;;;" + "The string separating entries in the `separated' style. +See `cider-repl-history-display-style'." + ;; The (default) separator is a Clojure comment, to preserve fontification + ;; in the buffer. + :type 'string + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-recenter nil + "If non-nil, then always keep the current entry at the top of the window." + :type 'boolean + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-highlight-current-entry nil + "If non-nil, highlight the currently selected command history entry." + :type 'boolean + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-highlight-inserted-item nil + "If non-nil, then temporarily highlight the inserted command history entry. +The value selected controls how the inserted item is highlighted, +possible values are `solid' (highlight the inserted text for a +fixed period of time), or `pulse' (fade out the highlighting gradually). +Setting this variable to the value t will select the default +highlighting style, which currently `pulse'. + +The variable `cider-repl-history-inserted-item-face' contains the +face used for highlighting." + :type '(choice (const nil) (const t) (const solid) (const pulse)) + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-separator-face 'bold + "The face in which to highlight the `cider-repl-history-separator'." + :type 'face + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-current-entry-face 'highlight + "The face in which to highlight the command history current entry." + :type 'face + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-inserted-item-face 'highlight + "The face in which to highlight the inserted item." + :type 'face + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-maximum-display-length nil + "Whether or not to limit the length of displayed items. + +If this variable is an integer, the display of the command history will be +limited to that many characters. +Setting this variable to nil means no limit." + :type '(choice (const :tag "None" nil) + integer) + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-display-duplicates t + "If non-nil, then display duplicate items in the command history." + :type 'boolean + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-display-duplicate-highest t + "If non-nil, then display most recent duplicate items in the command history. +Only takes effect when `cider-repl-history-display-duplicates' is nil." + :type 'boolean + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-text-properties nil + "If non-nil, maintain text properties of the command history items." + :type 'boolean + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-hook nil + "A list of functions to call after `cider-repl-history'." + :type 'hook + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-show-preview nil + "If non-nil, show a preview of the inserted text in the REPL buffer. + +The REPL buffer would show a preview of what the buffer would look like +if the item under point were inserted." + + :type 'boolean + :package-version '(cider . "0.15.0")) + +(defvar cider-repl-history-repl-window nil + "The window in which chosen command history data will be inserted. +It is probably not a good idea to set this variable directly; simply +call `cider-repl-history' again.") + +(defvar cider-repl-history-repl-buffer nil + "The buffer in which chosen command history data will be inserted. +It is probably not a good idea to set this variable directly; simply +call `cider-repl-history' again.") + +(defvar cider-repl-history-preview-overlay nil + "Overlay used to preview what would happen if the user inserted the given text.") + +(defvar cider-repl-history-previous-overlay nil + "Previous overlay within *cider-repl-history* buffer.") + + +(defun cider-repl-history-get-history () + "Function to retrieve history from the REPL buffer." + (if cider-repl-history-repl-buffer + (buffer-local-value + 'cider-repl-input-history + cider-repl-history-repl-buffer) + (error "Variable `cider-repl-history-repl-buffer' not bound to a buffer"))) + +(defun cider-repl-history-resize-window () + "Resize the *cider-repl-history* window if needed. +Controlled by variable `cider-repl-history-resize-window'." + (when cider-repl-history-resize-window + (apply #'fit-window-to-buffer (selected-window) + (if (consp cider-repl-history-resize-window) + (list (car cider-repl-history-resize-window) + (or (cdr cider-repl-history-resize-window) + window-min-height)) + (list nil window-min-height))))) + +(defun cider-repl-history-read-regexp (msg use-default-p) + "Get a regular expression from the user. +Prompts with MSG; previous entry is default if USE-DEFAULT-P." + (let* ((default (car regexp-history)) + (prompt (if (and default use-default-p) + (format "%s for regexp (default `%s'): " + msg + default) + (format "%s (regexp): " msg))) + (input + (read-from-minibuffer prompt nil nil nil 'regexp-history + (if use-default-p nil default)))) + (if (equal input "") + (if use-default-p default nil) + input))) + +(defun cider-repl-history-clear-preview () + "Clear the preview, if one is present." + (interactive) + (when cider-repl-history-preview-overlay + (cl-assert (overlayp cider-repl-history-preview-overlay)) + (delete-overlay cider-repl-history-preview-overlay))) + +(defun cider-repl-history-cleanup-on-exit () + "Function called when the user is finished with `cider-repl-history'. +This function performs any cleanup that is required when the user +has finished interacting with the *cider-repl-history* buffer. For now +the only cleanup performed is to remove the preview overlay, if +it's turned on." + (cider-repl-history-clear-preview)) + +(defun cider-repl-history-quit () + "Take the action specified by `cider-repl-history-quit-action'." + (interactive) + (cider-repl-history-cleanup-on-exit) + (pcase cider-repl-history-quit-action + (`delete-and-restore + (quit-restore-window (selected-window) 'kill)) + (`quit-window + (quit-window)) + (`kill-and-delete-window + (kill-buffer (current-buffer)) + (unless (= (count-windows) 1) + (delete-window))) + (`bury-and-delete-window + (bury-buffer) + (unless (= (count-windows) 1) + (delete-window))) + (_ + (funcall cider-repl-history-quit-action)))) + +(defun cider-repl-history-preview-overlay-setup (orig-buf) + "Setup the preview overlay in ORIG-BUF." + (when cider-repl-history-show-preview + (with-current-buffer orig-buf + (let* ((will-replace (region-active-p)) + (start (if will-replace + (min (point) (mark)) + (point))) + (end (if will-replace + (max (point) (mark)) + (point)))) + (cider-repl-history-clear-preview) + (setq cider-repl-history-preview-overlay + (make-overlay start end orig-buf)) + (overlay-put cider-repl-history-preview-overlay + 'invisible t))))) + +(defun cider-repl-history-highlight-inserted (start end) + "Insert the text between START and END." + (pcase cider-repl-history-highlight-inserted-item + ((or `pulse `t) + (let ((pulse-delay .05) (pulse-iterations 10)) + (with-no-warnings + (pulse-momentary-highlight-region + start end cider-repl-history-inserted-item-face)))) + (`solid + (let ((o (make-overlay start end))) + (overlay-put o 'face cider-repl-history-inserted-item-face) + (sit-for 0.5) + (delete-overlay o))))) + +(defun cider-repl-history-insert-and-highlight (str) + "Helper function to insert STR at point, highlighting it if appropriate." + (let ((before-insert (point))) + (let (deactivate-mark) + (insert-for-yank str)) + (cider-repl-history-highlight-inserted + before-insert + (point)))) + +(defun cider-repl-history-target-overlay-at (_position &optional no-error) + "Return overlay at POSITION that has property `cider-repl-history-target'. +If no such overlay, raise an error unless NO-ERROR is true, in which +case return nil." + (let ((ovs (overlays-at (point)))) + (catch 'cider-repl-history-target-overlay-at + (dolist (ov ovs) + (when (overlay-get ov 'cider-repl-history-target) + (throw 'cider-repl-history-target-overlay-at ov))) + (unless no-error + (error "No CIDER history item here"))))) + +(defun cider-repl-history-current-string (pt &optional no-error) + "Find the string to insert into the REPL by looking for the overlay at PT. +Might error unless NO-ERROR set." + (let ((o (cider-repl-history-target-overlay-at pt t))) + (if o + (overlay-get o 'cider-repl-history-target) + (unless no-error + (error "No CIDER history item in this buffer"))))) + +(defun cider-repl-history-do-insert (_buf pt) + "Helper function to insert text from BUF at PT into the REPL buffer. +Also kills *cider-repl-history*." + ;; Note: as mentioned at the top, this file is based on browse-kill-ring, + ;; which has numerous insertion options. The functionality of + ;; browse-kill-ring allows users to insert at point, and move point to the end + ;; of the inserted text; or insert at the beginning or end of the buffer, + ;; while leaving point alone. And each of these had the option of leaving the + ;; history buffer in place, or getting rid of it. That was appropriate for a + ;; generic paste tool, but for inserting a previous command into an + ;; interpreter, I felt the only useful option would be inserting it at the end + ;; and quitting the history buffer, so that is all that's provided. + (let ((str (cider-repl-history-current-string pt))) + (cider-repl-history-quit) + (with-selected-window cider-repl-history-repl-window + (with-current-buffer cider-repl-history-repl-buffer + (let ((max (point-max))) + (if (= max (point)) + (cider-repl-history-insert-and-highlight str) + (save-excursion + (goto-char max) + (cider-repl-history-insert-and-highlight str)))))))) + +(defun cider-repl-history-insert-and-quit () + "Insert the item into the REPL buffer, and close *cider-repl-history*. + +The text is always inserted at the very bottom of the REPL buffer. If your +cursor is already at the bottom, it is advanced to the end of the inserted +text. If your cursor is somewhere else, the cursor is not moved, but the +text is still inserted at the end." + (interactive) + (cider-repl-history-do-insert (current-buffer) (point))) + +(defun cider-repl-history-mouse-insert (e) + "Insert the item at E into the REPL buffer, and close *cider-repl-history*. + +The text is always inserted at the very bottom of the REPL buffer. If your +cursor is already at the bottom, it is advanced to the end of the inserted +text. If your cursor is somewhere else, the cursor is not moved, but the +text is still inserted at the end." + (interactive "e") + (let* ((data (save-excursion + (mouse-set-point e) + (cons (current-buffer) (point)))) + (buf (car data)) + (pt (cdr data))) + (cider-repl-history-do-insert buf pt))) + +(defun cider-repl-history-clear-highlighted-entry () + "Clear the highlighted entry, when one exists." + (when cider-repl-history-previous-overlay + (cl-assert (overlayp cider-repl-history-previous-overlay) + nil "not an overlay") + (overlay-put cider-repl-history-previous-overlay 'face nil))) + +(defun cider-repl-history-update-highlighted-entry () + "Update highlighted entry, when feature is turned on." + (when cider-repl-history-highlight-current-entry + (if-let* ((current-overlay (cider-repl-history-target-overlay-at (point) t))) + (unless (equal cider-repl-history-previous-overlay current-overlay) + ;; We've changed overlay. Clear current highlighting, + ;; and highlight the new overlay. + (cl-assert (overlay-get current-overlay 'cider-repl-history-target) t) + (cider-repl-history-clear-highlighted-entry) + (setq cider-repl-history-previous-overlay current-overlay) + (overlay-put current-overlay 'face + cider-repl-history-current-entry-face)) + ;; No overlay at point. Just clear all current highlighting. + (cider-repl-history-clear-highlighted-entry)))) + +(defun cider-repl-history-forward (&optional arg) + "Move forward by ARG command history entries." + (interactive "p") + (beginning-of-line) + (while (not (zerop arg)) + (let ((o (cider-repl-history-target-overlay-at (point) t))) + (cond + ((>= arg 0) + (setq arg (1- arg)) + ;; We're on a cider-repl-history overlay, skip to the end of it. + (when o + (goto-char (overlay-end o)) + (setq o nil)) + (while (not (or o (eobp))) + (goto-char (next-overlay-change (point))) + (setq o (cider-repl-history-target-overlay-at (point) t)))) + (t + (setq arg (1+ arg)) + (when o + (goto-char (overlay-start o)) + (setq o nil)) + (while (not (or o (bobp))) + (goto-char (previous-overlay-change (point))) + (setq o (cider-repl-history-target-overlay-at (point) t))))))) + (when cider-repl-history-recenter + (recenter 1))) + +(defun cider-repl-history-previous (&optional arg) + "Move backward by ARG command history entries." + (interactive "p") + (cider-repl-history-forward (- arg))) + +(defun cider-repl-history-search-forward (regexp &optional backwards) + "Move to the next command history entry matching REGEXP from point. +If optional arg BACKWARDS is non-nil, move to the previous matching +entry." + (interactive + (list (cider-repl-history-read-regexp "Search forward" t) + current-prefix-arg)) + (let ((orig (point))) + (cider-repl-history-forward (if backwards -1 1)) + (let ((over (cider-repl-history-target-overlay-at (point) t))) + (while (and over + (not (if backwards (bobp) (eobp))) + (not (string-match regexp + (overlay-get over + 'cider-repl-history-target)))) + (cider-repl-history-forward (if backwards -1 1)) + (setq over (cider-repl-history-target-overlay-at (point) t))) + (unless (and over + (string-match regexp + (overlay-get over + 'cider-repl-history-target))) + (goto-char orig) + (message "No more command history entries matching %s" regexp))))) + +(defun cider-repl-history-search-backward (regexp) + "Move to the previous command history entry matching REGEXP from point." + (interactive + (list (cider-repl-history-read-regexp "Search backward" t))) + (cider-repl-history-search-forward regexp t)) + +(defun cider-repl-history-elide (str) + ;; FIXME: Use `truncate-string-to-width'? + "If STR is too long, abbreviate it with an ellipsis. +Otherwise, return it unchanged." + (if (and cider-repl-history-maximum-display-length + (> (length str) + cider-repl-history-maximum-display-length)) + (concat (substring str 0 (- cider-repl-history-maximum-display-length 3)) + (propertize "..." 'cider-repl-history-extra t)) + str)) + +(defmacro cider-repl-history-add-overlays-for (item &rest body) + "Add overlays for ITEM, and execute BODY." + (let ((beg (cl-gensym "cider-repl-history-add-overlays-")) + (end (cl-gensym "cider-repl-history-add-overlays-"))) + `(let ((,beg (point)) + (,end + (progn + ,@body + (point)))) + (let ((o (make-overlay ,beg ,end))) + (overlay-put o 'cider-repl-history-target ,item) + (overlay-put o 'mouse-face 'highlight))))) + +(defun cider-repl-history-insert-as-separated (items) + "Insert ITEMS into the current buffer, with separators between items." + (while items + (let* ((origitem (car items)) + (item (cider-repl-history-elide origitem)) + ) ;; (len (length item)) + (cider-repl-history-add-overlays-for origitem (insert item)) + ;; When the command history has items with read-only text property at + ;; **the end of** string, cider-repl-history-setup fails with error + ;; `Text is read-only'. So inhibit-read-only here. + ;; See http://bugs.debian.org/225082 + (let ((inhibit-read-only t)) + (insert "\n") + (when (cdr items) + (insert (propertize cider-repl-history-separator + 'cider-repl-history-extra t + 'cider-repl-history-separator t)) + (insert "\n")))) + (setq items (cdr items)))) + +(defun cider-repl-history-insert-as-one-line (items) + "Insert ITEMS into the current buffer, formatting each item as a single line. + +An explicit newline character will replace newlines so that the text retains its +spacing when it's actually inserted into the REPL buffer." + (dolist (item items) + (cider-repl-history-add-overlays-for + item + (let* ((item (cider-repl-history-elide item)) + (len (length item)) + (start 0) + (newl (propertize "\\n" 'cider-repl-history-extra t))) + (while (and (< start len) + (string-match "\n" item start)) + (insert (substring item start (match-beginning 0)) + newl) + (setq start (match-end 0))) + (insert (substring item start len)))) + (insert "\n"))) + +(defun cider-repl-history-preview-update-text (preview-text) + "Update `cider-repl-history-preview-overlay' to show `PREVIEW-TEXT`." + ;; If preview-text is nil, replacement should be nil too. + (cl-assert (overlayp cider-repl-history-preview-overlay)) + (let ((replacement (when preview-text + (propertize preview-text 'face 'highlight)))) + (overlay-put cider-repl-history-preview-overlay + 'before-string replacement))) + +(defun cider-repl-history-preview-update-by-position (&optional pt) + "Update `cider-repl-history-preview-overlay' to match item at PT. + +This function is called whenever the selection in the *cider-repl-history* +buffer is adjusted, the `cider-repl-history-preview-overlay' +is updated to preview the text of the selection at PT (or the +current point if not specified)." + (let ((new-text (cider-repl-history-current-string + (or pt (point)) t))) + (cider-repl-history-preview-update-text new-text))) + +(defun cider-repl-history-undo-other-window () + "Undo the most recent change in the other window's buffer. +You most likely want to use this command for undoing an insertion of +text from the *cider-repl-history* buffer." + (interactive) + (with-current-buffer cider-repl-history-repl-buffer + (undo))) + +(defun cider-repl-history-setup (repl-win repl-buf history-buf &optional regexp) + "Setup. +REPL-WIN and REPL-BUF are where to insert commands; +HISTORY-BUF is the history, and optional arg REGEXP is a filter." + (cider-repl-history-preview-overlay-setup repl-buf) + (with-current-buffer history-buf + (unwind-protect + (progn + (cider-repl-history-mode) + (setq buffer-read-only nil) + (when (eq 'one-line cider-repl-history-display-style) + (setq truncate-lines t)) + (let ((inhibit-read-only t)) + (erase-buffer)) + (setq cider-repl-history-repl-buffer repl-buf) + (setq cider-repl-history-repl-window repl-win) + (let* ((cider-repl-history-maximum-display-length + (if (and cider-repl-history-maximum-display-length + (<= cider-repl-history-maximum-display-length 3)) + 4 + cider-repl-history-maximum-display-length)) + (cider-command-history (cider-repl-history-get-history)) + (items (mapcar + (if cider-repl-history-text-properties + #'copy-sequence + #'substring-no-properties) + cider-command-history))) + (unless cider-repl-history-display-duplicates + ;; display highest or lowest duplicate. + ;; if `cider-repl-history-display-duplicate-highest' is t, + ;; display highest (most recent) duplicate. + (cl-delete-duplicates + items + :test #'equal + :from-end cider-repl-history-display-duplicate-highest)) + (when (stringp regexp) + (setq items (delq nil + (mapcar + #'(lambda (item) + (when (string-match regexp item) + item)) + items)))) + (funcall (or (cdr (assq cider-repl-history-display-style + cider-repl-history-display-styles)) + (error "Invalid `cider-repl-history-display-style': %s" + cider-repl-history-display-style)) + items) + (when cider-repl-history-show-preview + (cider-repl-history-preview-update-by-position (point-min)) + ;; Local post-command-hook, only happens in *cider-repl-history* + (add-hook 'post-command-hook + #'cider-repl-history-preview-update-by-position + nil t) + (add-hook 'kill-buffer-hook + #'cider-repl-history-cleanup-on-exit + nil t)) + (when cider-repl-history-highlight-current-entry + (add-hook 'post-command-hook + #'cider-repl-history-update-highlighted-entry + nil t)) + (message + (let ((entry (if (= 1 (length cider-command-history)) + "entry" + "entries"))) + (concat + (if (and (not regexp) + cider-repl-history-display-duplicates) + (format "%s %s in the command history." + (length cider-command-history) entry) + (format "%s (of %s) %s in the command history shown." + (length items) (length cider-command-history) entry)) + (substitute-command-keys + (concat " Type \\[cider-repl-history-quit] to quit. " + "\\[describe-mode] for help."))))) + (set-buffer-modified-p nil) + (goto-char (point-min)) + (cider-repl-history-forward 0) + (setq mode-name (if regexp + (concat "History [" regexp "]") + "History")) + (run-hooks 'cider-repl-history-hook))) + (setq buffer-read-only t)))) + +(defun cider-repl-history-update () + "Update the history buffer to reflect the latest state of the command history." + (interactive) + (cl-assert (eq major-mode 'cider-repl-history-mode)) + (cider-repl-history-setup cider-repl-history-repl-window + cider-repl-history-repl-buffer + (current-buffer)) + (cider-repl-history-resize-window)) + +(defun cider-repl-history-occur (regexp) + "Display all command history entries matching REGEXP." + (interactive + (list (cider-repl-history-read-regexp + "Display command history entries matching" nil))) + (cl-assert (eq major-mode 'cider-repl-history-mode)) + (cider-repl-history-setup cider-repl-history-repl-window + cider-repl-history-repl-buffer + (current-buffer) + regexp) + (cider-repl-history-resize-window)) + +(defvar cider-repl-history-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "n") #'cider-repl-history-forward) + (define-key map (kbd "p") #'cider-repl-history-previous) + (define-key map (kbd "SPC") #'cider-repl-history-insert-and-quit) + (define-key map (kbd "RET") #'cider-repl-history-insert-and-quit) + (define-key map [(mouse-2)] #'cider-repl-history-mouse-insert) + (define-key map (kbd "l") #'cider-repl-history-occur) + (define-key map (kbd "s") #'cider-repl-history-search-forward) + (define-key map (kbd "r") #'cider-repl-history-search-backward) + (define-key map (kbd "g") #'cider-repl-history-update) + (define-key map (kbd "q") #'cider-repl-history-quit) + (define-key map (kbd "U") #'cider-repl-history-undo-other-window) + (define-key map (kbd "?") #'describe-mode) + (define-key map (kbd "h") #'describe-mode) + map)) + +(put 'cider-repl-history-mode 'mode-class 'special) +(define-derived-mode cider-repl-history-mode clojure-mode "History" + "Major mode for browsing the entries in the command input history." + (setq-local sesman-system 'CIDER)) + +;;;###autoload +(defun cider-repl-history () + "Display items in the CIDER command history in another buffer." + (interactive) + (when (eq major-mode 'cider-repl-history-mode) + (user-error "Already viewing the CIDER command history")) + + (let* ((repl-win (selected-window)) + (repl-buf (window-buffer repl-win)) + (buf (get-buffer-create cider-repl-history-buffer))) + (cider-repl-history-setup repl-win repl-buf buf) + (pop-to-buffer buf) + (cider-repl-history-resize-window))) + +(provide 'cider-repl-history) + +;;; cider-repl-history.el ends here diff --git a/elpa/cider-20241203.1607/cider-repl.el b/elpa/cider-20241203.1607/cider-repl.el new file mode 100644 index 00000000..9fd17c4f --- /dev/null +++ b/elpa/cider-20241203.1607/cider-repl.el @@ -0,0 +1,2067 @@ +;;; cider-repl.el --- CIDER REPL mode interactions -*- lexical-binding: t -*- + +;; Copyright © 2012-2024 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell +;; Reid McKenzie + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; This functionality concerns `cider-repl-mode' and REPL interaction. For +;; REPL/connection life-cycle management see cider-connection.el. + +;;; Code: + +(require 'cl-lib) +(require 'easymenu) +(require 'image) +(require 'map) +(require 'seq) +(require 'subr-x) + +(require 'clojure-mode) +(require 'sesman) + +(require 'cider-client) +(require 'cider-doc) +(require 'cider-test) +(require 'cider-eldoc) ; for cider-eldoc-setup +(require 'cider-common) +(require 'cider-util) +(require 'cider-resolve) + +(declare-function cider-inspect "cider-inspector") + + +(defgroup cider-repl nil + "Interaction with the REPL." + :prefix "cider-repl-" + :group 'cider) + +(defface cider-repl-prompt-face + '((t (:inherit font-lock-keyword-face))) + "Face for the prompt in the REPL buffer.") + +(defface cider-repl-stdout-face + '((t (:inherit font-lock-string-face))) + "Face for STDOUT output in the REPL buffer.") + +(defface cider-repl-stderr-face + '((t (:inherit font-lock-warning-face))) + "Face for STDERR output in the REPL buffer." + :package-version '(cider . "0.6.0")) + +(defface cider-repl-input-face + '((t (:bold t))) + "Face for previous input in the REPL buffer.") + +(defface cider-repl-result-face + '((t ())) + "Face for the result of an evaluation in the REPL buffer.") + +(defcustom cider-repl-pop-to-buffer-on-connect t + "Controls whether to pop to the REPL buffer on connect. + +When set to nil the buffer will only be created, and not displayed. When +set to `display-only' the buffer will be displayed, but it will not become +focused. Otherwise the buffer is displayed and focused." + :type '(choice (const :tag "Create the buffer, but don't display it" nil) + (const :tag "Create and display the buffer, but don't focus it" + display-only) + (const :tag "Create, display, and focus the buffer" t))) + +(defcustom cider-repl-display-in-current-window nil + "Controls whether the REPL buffer is displayed in the current window." + :type 'boolean) + +(make-obsolete-variable 'cider-repl-scroll-on-output 'scroll-conservatively "0.21") + +(defcustom cider-repl-use-pretty-printing t + "Control whether results in the REPL are pretty-printed or not. +The REPL will use the printer specified in `cider-print-fn'. +The `cider-toggle-pretty-printing' command can be used to interactively +change the setting's value." + :type 'boolean) + +(make-obsolete-variable 'cider-repl-pretty-print-width 'cider-print-options "0.21") + +(defcustom cider-repl-use-content-types nil + "Control whether REPL results are presented using content-type information. +The `cider-repl-toggle-content-types' command can be used to interactively +change the setting's value." + :type 'boolean + :package-version '(cider . "0.17.0")) + +(defcustom cider-repl-auto-detect-type t + "Control whether to auto-detect the REPL type using track-state information. +If you disable this you'll have to manually change the REPL type between +Clojure and ClojureScript when invoking REPL type changing forms. +Use `cider-set-repl-type' to manually change the REPL type." + :type 'boolean + :safe #'booleanp + :package-version '(cider . "0.18.0")) + +(defcustom cider-repl-use-clojure-font-lock t + "Non-nil means to use Clojure mode font-locking for input and result. +Nil means that `cider-repl-input-face' and `cider-repl-result-face' +will be used." + :type 'boolean + :package-version '(cider . "0.10.0")) + +(defcustom cider-repl-require-ns-on-set nil + "Controls whether to require the ns before setting it in the REPL." + :type 'boolean + :package-version '(cider . "0.22.0")) + +(defcustom cider-repl-result-prefix "" + "The prefix displayed in the REPL before a result value. +By default there's no prefix, but you can specify something +like \"=>\" if want results to stand out more." + :type 'string + :group 'cider + :package-version '(cider . "0.5.0")) + +(defcustom cider-repl-tab-command 'cider-repl-indent-and-complete-symbol + "Select the command to be invoked by the TAB key. +The default option is `cider-repl-indent-and-complete-symbol'. If +you'd like to use the default Emacs behavior use +`indent-for-tab-command'." + :type 'symbol) + +(make-obsolete-variable 'cider-repl-print-length 'cider-print-options "0.21") +(make-obsolete-variable 'cider-repl-print-level 'cider-print-options "0.21") + +(defvar cider-repl-require-repl-utils-code + '((clj . "(when-let [requires (resolve 'clojure.main/repl-requires)] + (clojure.core/apply clojure.core/require @requires))") + (cljs . "(require '[cljs.repl :refer [apropos dir doc find-doc print-doc pst source]])"))) + +(defcustom cider-repl-init-code (list (cdr (assoc 'clj cider-repl-require-repl-utils-code))) + "Clojure code to evaluate when starting a REPL. +Will be evaluated with bindings for set!-able vars in place. + +See also `cider-repl-eval-init-code'." + :type '(list string) + :package-version '(cider . "0.21.0")) + +(defcustom cider-repl-display-help-banner t + "When non-nil a bit of help text will be displayed on REPL start." + :type 'boolean + :package-version '(cider . "0.11.0")) + +;; See https://github.com/clojure-emacs/cider/issues/3219 for more details +(defcustom cider-repl-display-output-before-window-boundaries nil + "Controls whether to display output emitted before the REPL window boundaries. + +If the prompt is on the first line of the window, then scroll the window +down by a single line to make the emitted output visible. + +That behavior is desirable, but rarely needed and it slows down printing +output a lot (e.g. 10x) that's why it's disable by default starting with +CIDER 1.7." + :type 'boolean + :package-version '(cider . "1.7.0")) + + +;;;; REPL buffer local variables +(defvar-local cider-repl-input-start-mark nil) + +(defvar-local cider-repl-prompt-start-mark nil) + +(defvar-local cider-repl-old-input-counter 0 + "Counter used to generate unique `cider-old-input' properties. +This property value must be unique to avoid having adjacent inputs be +joined together.") + +(defvar-local cider-repl-input-history '() + "History list of strings read from the REPL buffer.") + +(defvar-local cider-repl-input-history-items-added 0 + "Variable counting the items added in the current session.") + +(defvar-local cider-repl-output-start nil + "Marker for the start of output. +Currently its only purpose is to facilitate `cider-repl-clear-buffer'.") + +(defvar-local cider-repl-output-end nil + "Marker for the end of output. +Currently its only purpose is to facilitate `cider-repl-clear-buffer'.") + +(defun cider-repl-tab () + "Invoked on TAB keystrokes in `cider-repl-mode' buffers." + (interactive) + (funcall cider-repl-tab-command)) + +(defun cider-repl-reset-markers () + "Reset all REPL markers." + (dolist (markname '(cider-repl-output-start + cider-repl-output-end + cider-repl-prompt-start-mark + cider-repl-input-start-mark)) + (set markname (make-marker)) + (set-marker (symbol-value markname) (point)))) + + +;;; REPL init + +(defvar-local cider-repl-ns-cache nil + "A dict holding information about all currently loaded namespaces. +This cache is stored in the connection buffer.") + +(defvar cider-mode) +(declare-function cider-refresh-dynamic-font-lock "cider-mode") + +(defun cider-repl--state-handler (response) + "Handle server state contained in RESPONSE." + (with-demoted-errors "Error in `cider-repl--state-handler': %s" + (when (member "state" (nrepl-dict-get response "status")) + (nrepl-dbind-response response (repl-type changed-namespaces session) + (when (and repl-type + cider-repl-auto-detect-type + ;; tooling sessions always run on the JVM so they are not a valid criterion: + (not (equal session nrepl-tooling-session))) + (cider-set-repl-type repl-type)) + (when (eq (cider-maybe-intern repl-type) 'cljs) + (setq cider-repl-cljs-upgrade-pending nil)) + (unless (nrepl-dict-empty-p changed-namespaces) + (setq cider-repl-ns-cache (nrepl-dict-merge cider-repl-ns-cache changed-namespaces)) + (let ((this-repl (current-buffer))) + (dolist (b (buffer-list)) + (with-current-buffer b + (when (or cider-mode (derived-mode-p 'cider-repl-mode)) + ;; We only cider-refresh-dynamic-font-lock (and set `cider-eldoc-last-symbol') + ;; for Clojure buffers directly related to this repl + ;; (specifically, we omit 'friendly' sessions because a given buffer may be friendly to multiple repls, + ;; so we don't want a buffer to mix up font locking rules from different repls). + ;; Note that `sesman--linked-sessions' only queries for the directly linked sessions. + ;; That has the additional advantage of running very/predictably fast, since it won't run our + ;; `cider--sesman-friendly-session-p' logic, which can be slow for its non-cached path. + (when (member this-repl (car (sesman--linked-sessions 'CIDER))) + ;; Metadata changed, so signatures may have changed too. + (setq cider-eldoc-last-symbol nil) + (when-let* ((ns-dict (or (nrepl-dict-get changed-namespaces (cider-current-ns)) + (let ((ns-dict (cider-resolve--get-in (cider-current-ns)))) + (when (seq-find (lambda (ns) (nrepl-dict-get changed-namespaces ns)) + (nrepl-dict-get ns-dict "aliases")) + ns-dict))))) + (cider-refresh-dynamic-font-lock ns-dict)))))))))))) + +(defun cider-repl-require-repl-utils () + "Require standard REPL util functions into the current REPL." + (interactive) + (let* ((current-repl (cider-current-repl nil 'ensure)) + (require-code (cdr (assoc (cider-repl-type current-repl) cider-repl-require-repl-utils-code)))) + (nrepl-send-sync-request + (lax-plist-put + (nrepl--eval-request require-code (cider-current-ns)) + "inhibit-cider-middleware" "true") + current-repl))) + +(defun cider-repl-init-eval-handler (&optional callback) + "Make an nREPL evaluation handler for use during REPL init. +Run CALLBACK once the evaluation is complete." + (nrepl-make-response-handler (current-buffer) + (lambda (_buffer _value)) + (lambda (buffer out) + (cider-repl-emit-stdout buffer out)) + (lambda (buffer err) + (cider-repl-emit-stderr buffer err)) + (lambda (buffer) + (cider-repl-emit-prompt buffer) + (when callback + (funcall callback))))) + +(defun cider-repl-eval-init-code (&optional callback) + "Evaluate `cider-repl-init-code' in the current REPL. +Run CALLBACK once the evaluation is complete." + (interactive) + (let* ((request (map-merge 'hash-table + (cider--repl-request-map fill-column) + '(("inhibit-cider-middleware" "true"))))) + (cider-nrepl-request:eval + ;; Ensure we evaluate _something_ so the initial namespace is correctly set + (thread-first (or cider-repl-init-code '("nil")) + (string-join "\n")) + (cider-repl-init-eval-handler callback) + nil + (line-number-at-pos (point)) + (cider-column-number-at-pos (point)) + (thread-last + request + (map-pairs) + (seq-mapcat #'identity))))) + +(defun cider-repl-init (buffer &optional callback) + "Initialize the REPL in BUFFER. +BUFFER must be a REPL buffer with `cider-repl-mode' and a running +client process connection. CALLBACK will be run once the REPL is +fully initialized." + (when cider-repl-display-in-current-window + (add-to-list 'same-window-buffer-names (buffer-name buffer))) + (pcase cider-repl-pop-to-buffer-on-connect + (`display-only + (let ((orig-buffer (current-buffer))) + (display-buffer buffer) + ;; User popup-rules (specifically `:select nil') can cause the call to + ;; `display-buffer' to reset the current Emacs buffer to the clj/cljs + ;; buffer that the user ran `jack-in' from - we need the current-buffer + ;; to be the repl to initialize, so reset it back here to be resilient + ;; against user config + (set-buffer orig-buffer))) + ((pred identity) (pop-to-buffer buffer))) + (with-current-buffer buffer + (cider-repl--insert-banner) + (cider-repl--insert-startup-commands) + (when-let* ((window (get-buffer-window buffer t))) + (with-selected-window window + (recenter (- -1 scroll-margin)))) + (cider-repl-eval-init-code callback)) + buffer) + +(defun cider-repl--insert-banner () + "Insert the banner in the current REPL buffer." + (insert-before-markers + (propertize (cider-repl--banner) 'font-lock-face 'font-lock-comment-face)) + (when cider-repl-display-help-banner + (insert-before-markers + (propertize (cider-repl--help-banner) 'font-lock-face 'font-lock-comment-face)))) + +(defun cider-repl--insert-startup-commands () + "Insert the values from params specified in PARAM-TUPLES. +PARAM-TUPLES are tuples of (param-key description) or (param-key +description transform) where transform is called with the param-value if +present." + (cl-labels + ((emit-comment + (contents) + (insert-before-markers + (propertize + (if (string-blank-p contents) ";;\n" (concat ";; " contents "\n")) + 'font-lock-face 'font-lock-comment-face)))) + (let ((jack-in-command (plist-get cider-launch-params :jack-in-cmd)) + (cljs-repl-type (plist-get cider-launch-params :cljs-repl-type)) + (cljs-init-form (plist-get cider-launch-params :repl-init-form))) + (when jack-in-command + ;; spaces to align with the banner + (emit-comment (concat " Startup: " jack-in-command))) + (when (or cljs-repl-type cljs-init-form) + (emit-comment "") + (when cljs-repl-type + (emit-comment (concat "ClojureScript REPL type: " (symbol-name cljs-repl-type)))) + (when cljs-init-form + (emit-comment (concat "ClojureScript REPL init form: " cljs-init-form))) + (emit-comment ""))))) + +(defun cider-repl--banner () + "Generate the welcome REPL buffer banner." + (cond + ((cider--clojure-version) (cider-repl--clojure-banner)) + ((cider--babashka-version) (cider-repl--babashka-banner)) + (t (cider-repl--basic-banner)))) + +(defun cider-repl--clojure-banner () + "Generate the welcome REPL buffer banner for Clojure(Script)." + (format ";; Connected to nREPL server - nrepl://%s:%s +;; CIDER %s, nREPL %s +;; Clojure %s, Java %s +;; Docs: (doc function-name) +;; (find-doc part-of-name) +;; Source: (source function-name) +;; Javadoc: (javadoc java-object-or-class) +;; Exit: +;; Results: Stored in vars *1, *2, *3, an exception in *e; +" + (plist-get nrepl-endpoint :host) + (plist-get nrepl-endpoint :port) + (cider--version) + (cider--nrepl-version) + (cider--clojure-version) + (cider--java-version))) + +(defun cider-repl--babashka-banner () + "Generate the welcome REPL buffer banner for Babashka." + (format ";; Connected to nREPL server - nrepl://%s:%s +;; CIDER %s, babashka.nrepl %s +;; Babashka %s +;; Docs: (doc function-name) +;; (find-doc part-of-name) +;; Source: (source function-name) +;; Javadoc: (javadoc java-object-or-class) +;; Exit: +;; Results: Stored in vars *1, *2, *3, an exception in *e; +" + (plist-get nrepl-endpoint :host) + (plist-get nrepl-endpoint :port) + (cider--version) + (cider--babashka-nrepl-version) + (cider--babashka-version))) + +(defun cider-repl--basic-banner () + "Generate a basic banner with minimal info." + (format ";; Connected to nREPL server - nrepl://%s:%s +;; CIDER %s +" + (plist-get nrepl-endpoint :host) + (plist-get nrepl-endpoint :port) + (cider--version))) + +(defun cider-repl--help-banner () + "Generate the help banner." + (substitute-command-keys + ";; ====================================================================== +;; If you're new to CIDER it is highly recommended to go through its +;; user manual first. Type to view it. +;; In case you're seeing any warnings you should consult the manual's +;; \"Troubleshooting\" section. +;; +;; Here are a few tips to get you started: +;; +;; * Press <\\[describe-mode]> to see a list of the keybindings available (this +;; will work in every Emacs buffer) +;; * Press <\\[cider-repl-handle-shortcut]> to quickly invoke some REPL command +;; * Press <\\[cider-switch-to-last-clojure-buffer]> to switch between the REPL and a Clojure file +;; * Press <\\[cider-find-var]> to jump to the source of something (e.g. a var, a +;; Java method) +;; * Press <\\[cider-doc]> to view the documentation for something (e.g. +;; a var, a Java method) +;; * Print CIDER's refcard and keep it close to your keyboard. +;; +;; CIDER is super customizable - try to +;; get a feel for this. If you're thirsty for knowledge you should try +;; . +;; +;; If you think you've encountered a bug (or have some suggestions for +;; improvements) use to report it. +;; +;; Above all else - don't panic! In case of an emergency - procure +;; some (hard) cider and enjoy it responsibly! +;; +;; You can remove this message with the command. +;; You can disable it from appearing on start by setting +;; `cider-repl-display-help-banner' to nil. +;; ====================================================================== +")) + + +;;; REPL interaction + +(defun cider-repl--in-input-area-p () + "Return t if in input area." + (<= cider-repl-input-start-mark (point))) + +(defun cider-repl--current-input (&optional until-point-p) + "Return the current input as string. +The input is the region from after the last prompt to the end of +buffer. If UNTIL-POINT-P is non-nil, the input is until the current +point." + (buffer-substring-no-properties cider-repl-input-start-mark + (if until-point-p + (point) + (point-max)))) + +(defun cider-repl-previous-prompt () + "Move backward to the previous prompt." + (interactive) + (cider-repl--find-prompt t)) + +(defun cider-repl-next-prompt () + "Move forward to the next prompt." + (interactive) + (cider-repl--find-prompt)) + +(defun cider-repl--find-prompt (&optional backward) + "Find the next prompt. +If BACKWARD is non-nil look backward." + (let ((origin (point)) + (cider-repl-prompt-property 'field)) + (while (progn + (cider-search-property-change cider-repl-prompt-property backward) + (not (or (cider-end-of-proprange-p cider-repl-prompt-property) (bobp) (eobp))))) + (unless (cider-end-of-proprange-p cider-repl-prompt-property) + (goto-char origin)))) + +(defun cider-search-property-change (prop &optional backward) + "Search forward for a property change to PROP. +If BACKWARD is non-nil search backward." + (cond (backward + (goto-char (previous-single-char-property-change (point) prop))) + (t + (goto-char (next-single-char-property-change (point) prop))))) + +(defun cider-end-of-proprange-p (property) + "Return t if at the the end of a property range for PROPERTY." + (and (get-char-property (max (point-min) (1- (point))) property) + (not (get-char-property (point) property)))) + +(defun cider-repl--mark-input-start () + "Mark the input start." + (set-marker cider-repl-input-start-mark (point) (current-buffer))) + +(defun cider-repl--mark-output-start () + "Mark the output start." + (set-marker cider-repl-output-start (point)) + (set-marker cider-repl-output-end (point))) + +(defun cider-repl-mode-beginning-of-defun (&optional arg) + "Move to the beginning of defun. +If given a negative value of ARG, move to the end of defun." + (if (and arg (< arg 0)) + (cider-repl-mode-end-of-defun (- arg)) + (dotimes (_ (or arg 1)) + (cider-repl-previous-prompt)))) + +(defun cider-repl-mode-end-of-defun (&optional arg) + "Move to the end of defun. +If given a negative value of ARG, move to the beginning of defun." + (if (and arg (< arg 0)) + (cider-repl-mode-beginning-of-defun (- arg)) + (dotimes (_ (or arg 1)) + (cider-repl-next-prompt)))) + +(defun cider-repl-beginning-of-defun () + "Move to beginning of defun." + (interactive) + ;; We call `beginning-of-defun' if we're at the start of a prompt + ;; already, to trigger `cider-repl-mode-beginning-of-defun' by means + ;; of the locally bound `beginning-of-defun-function', in order to + ;; jump to the start of the previous prompt. + (if (and (not (cider-repl--at-prompt-start-p)) + (cider-repl--in-input-area-p)) + (goto-char cider-repl-input-start-mark) + (beginning-of-defun-raw))) + +(defun cider-repl-end-of-defun () + "Move to end of defun." + (interactive) + ;; C.f. `cider-repl-beginning-of-defun' + (if (and (not (= (point) (point-max))) + (cider-repl--in-input-area-p)) + (goto-char (point-max)) + (end-of-defun))) + +(defun cider-repl-bol-mark () + "Set the mark and go to the beginning of line or the prompt." + (interactive) + (unless mark-active + (set-mark (point))) + (move-beginning-of-line 1)) + +(defun cider-repl--at-prompt-start-p () + "Return t if point is at the start of prompt. +This will not work on non-current prompts." + (= (point) cider-repl-input-start-mark)) + +(defmacro cider-save-marker (marker &rest body) + "Save MARKER and execute BODY." + (declare (debug t)) + (let ((pos (make-symbol "pos"))) + `(let ((,pos (marker-position ,marker))) + (prog1 (progn . ,body) + (set-marker ,marker ,pos))))) + +(put 'cider-save-marker 'lisp-indent-function 1) + +(defun cider-repl-prompt-default (namespace) + "Return a prompt string that mentions NAMESPACE." + (format "%s> " namespace)) + +(defun cider-repl-prompt-abbreviated (namespace) + "Return a prompt string that abbreviates NAMESPACE." + (format "%s> " (cider-abbreviate-ns namespace))) + +(defun cider-repl-prompt-lastname (namespace) + "Return a prompt string with the last name in NAMESPACE." + (format "%s> " (cider-last-ns-segment namespace))) + +(defcustom cider-repl-prompt-function #'cider-repl-prompt-default + "A function that returns a prompt string. +Takes one argument, a namespace name. +For convenience, three functions are already provided for this purpose: +`cider-repl-prompt-lastname', `cider-repl-prompt-abbreviated', and +`cider-repl-prompt-default'." + :type '(choice (const :tag "Full namespace" cider-repl-prompt-default) + (const :tag "Abbreviated namespace" cider-repl-prompt-abbreviated) + (const :tag "Last name in namespace" cider-repl-prompt-lastname) + (function :tag "Custom function")) + :package-version '(cider . "0.9.0")) + +(defun cider-repl--insert-prompt (namespace) + "Insert the prompt (before markers!), taking into account NAMESPACE. +Set point after the prompt. +Return the position of the prompt beginning." + (goto-char cider-repl-input-start-mark) + (cider-save-marker cider-repl-output-start + (cider-save-marker cider-repl-output-end + (unless (bolp) (insert-before-markers "\n")) + (let ((prompt-start (point)) + (prompt (funcall cider-repl-prompt-function namespace))) + (cider-propertize-region + '(font-lock-face cider-repl-prompt-face read-only t intangible t + field cider-repl-prompt + rear-nonsticky (field read-only font-lock-face intangible)) + (insert-before-markers prompt)) + (set-marker cider-repl-prompt-start-mark prompt-start) + prompt-start)))) + +(defun cider-repl--ansi-color-apply (string) + "Like `ansi-color-apply', but does not withhold non-SGR seqs found in STRING. + +Workaround for Emacs bug#53808 whereby partial ANSI control seqs present in +the input stream may block the whole colorization process." + (let* ((result (ansi-color-apply string)) + + ;; The STRING may end with a possible incomplete ANSI control seq which + ;; the call to `ansi-color-apply' stores in the `ansi-color-context' + ;; fragment. If the fragment is not an incomplete ANSI color control + ;; sequence (aka SGR seq) though then flush it out and appended it to + ;; the result. + (fragment-flush? + (when-let (fragment (and ansi-color-context (cadr ansi-color-context))) + (save-match-data + ;; Check if fragment is indeed an SGR seq in the making. The SGR + ;; seq is defined as starting with ESC followed by [ followed by + ;; zero or more [:digit:]+; followed by one or more digits and + ;; ending with m. + (when (string-match + (rx (sequence ?\e + (? (and (or ?\[ eol) + (or (+ (any (?0 . ?9))) eol) + (* (sequence ?\; (+ (any (?0 . ?9))))) + (or ?\; eol))))) + fragment) + (let* ((sgr-end-pos (match-end 0)) + (fragment-matches-whole? (or (= sgr-end-pos 0) + (= sgr-end-pos (length fragment))))) + (when (not fragment-matches-whole?) + ;; Definitely not an partial SGR seq, flush it out of + ;; `ansi-color-context'. + t))))))) + + (if (not fragment-flush?) + result + + (progn + ;; Temporarily replace the ESC char in the fragment so that is flushed + ;; out of `ansi-color-context' by `ansi-color-apply' and append it to + ;; the result. + (aset (cadr ansi-color-context) 0 ?\0) + (let ((result-fragment (ansi-color-apply ""))) + (aset result-fragment 0 ?\e) + (concat result result-fragment)))))) + +(defvar-local cider-repl--ns-forms-plist nil + "Plist holding ns->ns-form mappings within each connection.") + +(defun cider-repl--ns-form-changed-p (ns-form connection) + "Return non-nil if NS-FORM for CONNECTION changed since last eval." + (when-let* ((ns (cider-ns-from-form ns-form))) + (not (string= ns-form + (lax-plist-get + (buffer-local-value 'cider-repl--ns-forms-plist connection) + ns))))) + +(defvar cider-repl--root-ns-highlight-template "\\_<\\(%s\\)[^$/: \t\n()]+" + "Regexp used to highlight root ns in REPL buffers.") + +(defvar-local cider-repl--root-ns-regexp nil + "Cache of root ns regexp in REPLs.") + +(defvar-local cider-repl--ns-roots nil + "List holding all past root namespaces seen during interactive eval.") + +(defun cider-repl--cache-ns-form (ns-form connection) + "Given NS-FORM cache root ns in CONNECTION." + (with-current-buffer connection + (when-let* ((ns (cider-ns-from-form ns-form))) + ;; cache ns-form + (setq cider-repl--ns-forms-plist + (lax-plist-put cider-repl--ns-forms-plist ns ns-form)) + ;; cache ns roots regexp + (when (string-match "\\([^.]+\\)" ns) + (let ((root (match-string-no-properties 1 ns))) + (unless (member root cider-repl--ns-roots) + (push root cider-repl--ns-roots) + (let ((roots (mapconcat + ;; Replace _ or - with regexp pattern to accommodate "raw" namespaces + (lambda (r) (replace-regexp-in-string "[_-]+" "[_-]+" r)) + cider-repl--ns-roots "\\|"))) + (setq cider-repl--root-ns-regexp + (format cider-repl--root-ns-highlight-template roots))))))))) + +(defvar cider-repl-spec-keywords-regexp + (concat + (regexp-opt '("In:" " val:" + " at:" "fails at:" + " spec:" "fails spec:" + " predicate:" "fails predicate:")) + "\\|^" + (regexp-opt '(":clojure.spec.alpha/spec" + ":clojure.spec.alpha/value") + "\\(")) + "Regexp matching clojure.spec `explain` keywords.") + +(defun cider-repl-highlight-spec-keywords (string) + "Highlight clojure.spec `explain` keywords in STRING. +Foreground of `clojure-keyword-face' is used for highlight." + (cider-add-face cider-repl-spec-keywords-regexp + 'clojure-keyword-face t nil string) + string) + +(defun cider-repl-highlight-current-project (string) + "Fontify project's root namespace to make stacktraces more readable. +Foreground of `cider-stacktrace-ns-face' is used to propertize matched +namespaces. STRING is REPL's output." + (cider-add-face cider-repl--root-ns-regexp 'cider-stacktrace-ns-face + t nil string) + string) + +(defun cider-repl-add-locref-help-echo (string) + "Set help-echo property of STRING to `cider-locref-help-echo'." + (put-text-property 0 (length string) 'help-echo 'cider-locref-help-echo string) + string) + +(defvar cider-repl-preoutput-hook `(,(if (< emacs-major-version 29) + 'cider-repl--ansi-color-apply + 'ansi-color-apply) + cider-repl-highlight-current-project + cider-repl-highlight-spec-keywords + cider-repl-add-locref-help-echo) + "Hook run on output string before it is inserted into the REPL buffer. +Each functions takes a string and must return a modified string. Also see +`cider-run-chained-hook'.") + +(defcustom cider-repl-buffer-size-limit nil + "The max size of the REPL buffer. +Setting this to nil removes the limit." + :group 'cider + :type 'integer + :package-version '(cider . "0.26.0")) + +(defun cider-start-of-next-prompt (point) + "Return the position of the first char of the next prompt from POINT." + (let ((next-prompt-or-input (next-single-char-property-change point 'field))) + (if (eq (get-char-property next-prompt-or-input 'field) 'cider-repl-prompt) + next-prompt-or-input + (next-single-char-property-change next-prompt-or-input 'field)))) + +(defun cider-repl-trim-top-of-buffer (buffer) + "Trims REPL output from beginning of BUFFER. +Trims by one fifth of `cider-repl-buffer-size-limit'. +Also clears remaining partial input or results." + (with-current-buffer buffer + (let* ((to-trim (ceiling (* cider-repl-buffer-size-limit 0.2))) + (start-of-next-prompt (cider-start-of-next-prompt to-trim)) + (inhibit-read-only t)) + (cider-repl--clear-region (point-min) start-of-next-prompt)))) + +(defun cider-repl-trim-buffer () + "Trim the currently visited REPL buffer partially from the top. +See also `cider-repl-clear-buffer'." + (interactive) + (if cider-repl-buffer-size-limit + (cider-repl-trim-top-of-buffer (current-buffer)) + (user-error "The variable `cider-repl-buffer-size-limit' is not set"))) + +(defun cider-repl-maybe-trim-buffer (buffer) + "Clear portion of printed output in BUFFER. +Clear the part where `cider-repl-buffer-size-limit' is exceeded." + (when (> (buffer-size) cider-repl-buffer-size-limit) + (cider-repl-trim-top-of-buffer buffer))) + +(defun cider-repl--emit-output (buffer string face) + "Using BUFFER, emit STRING as output font-locked using FACE. +Before inserting, run `cider-repl-preoutput-hook' on STRING." + (with-current-buffer buffer + (save-excursion + (cider-save-marker cider-repl-output-start + (goto-char cider-repl-output-end) + (setq string (propertize string + 'font-lock-face face + 'rear-nonsticky '(font-lock-face))) + (setq string (cider-run-chained-hook 'cider-repl-preoutput-hook string)) + (insert-before-markers string)) + (when (and (= (point) cider-repl-prompt-start-mark) + (not (bolp))) + (insert-before-markers "\n") + (set-marker cider-repl-output-end (1- (point)))))) + (when cider-repl-display-output-before-window-boundaries + ;; FIXME: The code below is super slow, that's why it's disabled by default. + (when-let* ((window (get-buffer-window buffer t))) + ;; If the prompt is on the first line of the window, then scroll the window + ;; down by a single line to make the emitted output visible. + (when (and (pos-visible-in-window-p cider-repl-prompt-start-mark window) + (< 1 cider-repl-prompt-start-mark) + (not (pos-visible-in-window-p (1- cider-repl-prompt-start-mark) window))) + (with-selected-window window + (scroll-down 1)))))) + +(defun cider-repl--emit-interactive-output (string face) + "Emit STRING as interactive output using FACE." + (cider-repl--emit-output (cider-current-repl) string face)) + +(defun cider-repl-emit-interactive-stdout (string) + "Emit STRING as interactive output." + (cider-repl--emit-interactive-output string 'cider-repl-stdout-face)) + +(defun cider-repl-emit-interactive-stderr (string) + "Emit STRING as interactive err output." + (cider-repl--emit-interactive-output string 'cider-repl-stderr-face)) + +(defun cider-repl-emit-stdout (buffer string) + "Using BUFFER, emit STRING as standard output." + (cider-repl--emit-output buffer string 'cider-repl-stdout-face)) + +(defun cider-repl-emit-stderr (buffer string) + "Using BUFFER, emit STRING as error output." + (cider-repl--emit-output buffer string 'cider-repl-stderr-face)) + +(defun cider-repl-emit-prompt (buffer) + "Emit the REPL prompt into BUFFER." + (with-current-buffer buffer + (save-excursion + (cider-repl--insert-prompt cider-buffer-ns)))) + +(defun cider-repl-emit-result (buffer string show-prefix &optional bol) + "Emit into BUFFER the result STRING and mark it as an evaluation result. +If SHOW-PREFIX is non-nil insert `cider-repl-result-prefix' at the beginning +of the line. If BOL is non-nil insert at the beginning of the line." + (with-current-buffer buffer + (save-excursion + (cider-save-marker cider-repl-output-start + (goto-char cider-repl-output-end) + (when (and bol (not (bolp))) + (insert-before-markers "\n")) + (when show-prefix + (insert-before-markers (propertize cider-repl-result-prefix 'font-lock-face 'font-lock-comment-face))) + (if cider-repl-use-clojure-font-lock + (insert-before-markers (cider-font-lock-as-clojure string)) + (cider-propertize-region + '(font-lock-face cider-repl-result-face rear-nonsticky (font-lock-face)) + (insert-before-markers string))))))) + +(defun cider-repl-newline-and-indent () + "Insert a newline, then indent the next line. +Restrict the buffer from the prompt for indentation, to avoid being +confused by strange characters (like unmatched quotes) appearing +earlier in the buffer." + (interactive) + (save-restriction + (narrow-to-region cider-repl-prompt-start-mark (point-max)) + (insert "\n") + (lisp-indent-line))) + +(defun cider-repl-indent-and-complete-symbol () + "Indent the current line and perform symbol completion. +First indent the line. If indenting doesn't move point, complete +the symbol." + (interactive) + (let ((pos (point))) + (lisp-indent-line) + (when (= pos (point)) + (if (save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t)) + (completion-at-point))))) + +(defun cider-repl-kill-input () + "Kill all text from the prompt to point." + (interactive) + (cond ((< (marker-position cider-repl-input-start-mark) (point)) + (kill-region cider-repl-input-start-mark (point))) + ((= (point) (marker-position cider-repl-input-start-mark)) + (cider-repl-delete-current-input)))) + +(defun cider-repl--input-complete-p (start end) + "Return t if the region from START to END is a complete sexp." + (save-excursion + (goto-char start) + (cond ((looking-at-p "\\s *[@'`#]?[(\"]") + (ignore-errors + (save-restriction + (narrow-to-region start end) + ;; Keep stepping over blanks and sexps until the end of + ;; buffer is reached or an error occurs. Tolerate extra + ;; close parens. + (cl-loop do (skip-chars-forward " \t\r\n)") + until (eobp) + do (forward-sexp)) + t))) + (t t)))) + +(defun cider-repl--display-image (buffer image &optional show-prefix bol) + "Insert IMAGE into BUFFER at the current point. + +For compatibility with the rest of CIDER's REPL machinery, supports +SHOW-PREFIX and BOL." + (with-current-buffer buffer + (save-excursion + (cider-save-marker cider-repl-output-start + (goto-char cider-repl-output-end) + (when (and bol (not (bolp))) + (insert-before-markers "\n")) + (when show-prefix + (insert-before-markers + (propertize cider-repl-result-prefix 'font-lock-face 'font-lock-comment-face))) + ;; The below is inlined from `insert-image' and changed to use + ;; `insert-before-markers' rather than `insert' + (let ((start (point)) + (props (nconc `(display ,image rear-nonsticky (display)) + (when (boundp 'image-map) + `(keymap ,image-map))))) + (insert-before-markers " ") + (add-text-properties start (point) props))))) + t) + +(defcustom cider-repl-image-margin 10 + "Specifies the margin to be applied to images displayed in the REPL. +Either a single number of pixels - interpreted as a symmetric margin, or +pair of numbers `(x . y)' encoding an arbitrary margin." + :type '(choice integer (vector integer integer)) + :package-version '(cider . "0.17.0")) + +(defun cider-repl--image (data type datap) + "A helper for creating images with CIDER's image options. +DATA is either the path to an image or its base64 coded data. TYPE is a +symbol indicating the image type. DATAP indicates whether the image is the +raw image data or a filename. Returns an image instance with a margin per +`cider-repl-image-margin'." + (create-image data type datap + :margin cider-repl-image-margin)) + +(defun cider-repl-handle-jpeg (_type buffer image &optional show-prefix bol) + "A handler for inserting a jpeg IMAGE into a repl BUFFER. +Part of the default `cider-repl-content-type-handler-alist'." + (cider-repl--display-image buffer + (cider-repl--image image 'jpeg t) + show-prefix bol)) + +(defun cider-repl-handle-png (_type buffer image &optional show-prefix bol) + "A handler for inserting a png IMAGE into a repl BUFFER. +Part of the default `cider-repl-content-type-handler-alist'." + (cider-repl--display-image buffer + (cider-repl--image image 'png t) + show-prefix bol)) + +(defun cider-repl-handle-svg (_type buffer image &optional show-prefix bol) + "A handler for inserting an svg IMAGE into a repl BUFFER. +Part of the default `cider-repl-content-type-handler-alist'." + (cider-repl--display-image buffer + (cider-repl--image image 'svg t) + show-prefix bol)) + +(defun cider-repl-handle-external-body (type buffer _ &optional _show-prefix _bol) + "Handler for slurping external content into BUFFER. +Handles an external-body TYPE by issuing a slurp request to fetch the content." + (if-let* ((args (cadr type)) + (access-type (nrepl-dict-get args "access-type"))) + (nrepl-send-request + (list "op" "slurp" "url" (nrepl-dict-get args access-type)) + (cider-repl-handler buffer) + (cider-current-repl))) + nil) + +(defvar cider-repl-content-type-handler-alist + `(("message/external-body" . ,#'cider-repl-handle-external-body) + ("image/jpeg" . ,#'cider-repl-handle-jpeg) + ("image/png" . ,#'cider-repl-handle-png) + ("image/svg+xml" . ,#'cider-repl-handle-svg)) + "Association list from content-types to handlers. +Handlers must be functions of two required and two optional arguments - the +REPL buffer to insert into, the value of the given content type as a raw +string, the REPL's show prefix as any and an `end-of-line' flag. + +The return value of the handler should be a flag, indicating whether or not +the REPL is ready for a prompt to be displayed. Most handlers should return +t, as the content-type response is (currently) an alternative to the +value response. However for handlers which themselves issue subsequent +nREPL ops, it may be convenient to prevent inserting a prompt.") + +(defun cider--maybe-get-state-cljs () + "Invokes `cider/get-state' when it's possible to do so." + (when-let ((conn (cider-current-repl 'cljs))) + (when (nrepl-op-supported-p "cider/get-state" conn) + (nrepl-send-request '("op" "cider/get-state") + (lambda (_response) + ;; No action is necessary: this request results in `cider-repl--state-handler` being called. + ) + conn)))) + +(defun cider--maybe-get-state-for-shadow-cljs (buffer &optional err) + "Refresh the changed namespaces metadata given BUFFER and ERR (stderr string). + +This is particularly necessary for shadow-cljs because: + +* it has a particular nREPL implementation; and +* one may have saved files (which triggers recompilation, + and therefore the need for recomputing changed namespaces) + without sending a nREPL message (this can particularly happen + if the file was edited outside Emacs)." + (with-current-buffer buffer + (when (and (eq cider-repl-type 'cljs) + (eq cider-cljs-repl-type 'shadow) + (not cider-repl-cljs-upgrade-pending) + (if err + (string-match-p "Build completed\\." err) + t)) + (cider--maybe-get-state-cljs)))) + +(defun cider--maybe-get-state-for-figwheel-main (buffer out) + "Refresh the changed namespaces metadata given BUFFER and OUT (stdout string)." + (with-current-buffer buffer + (when (and (eq cider-repl-type 'cljs) + (eq cider-cljs-repl-type 'figwheel-main) + (not cider-repl-cljs-upgrade-pending) + (string-match-p "Successfully compiled build" out)) + (cider--maybe-get-state-cljs)))) + +(defun cider--shadow-cljs-handle-stderr (buffer err) + "Refresh the changed namespaces metadata given BUFFER and ERR." + (cider--maybe-get-state-for-shadow-cljs buffer err)) + +(defun cider--shadow-cljs-handle-done (buffer) + "Refresh the changed namespaces metadata given BUFFER." + (cider--maybe-get-state-for-shadow-cljs buffer)) + +(defvar cider--repl-stdout-functions (list #'cider--maybe-get-state-for-figwheel-main) + "Functions to be invoked each time new stdout is received on a repl buffer. + +Good for, for instance, monitoring specific strings that may be logged, +and responding to them.") + +(defvar cider--repl-stderr-functions (list #'cider--shadow-cljs-handle-stderr) + "Functions to be invoked each time new stderr is received on a repl buffer. + +Good for, for instance, monitoring specific strings that may be logged, +and responding to them.") + +(defvar cider--repl-done-functions (list #'cider--shadow-cljs-handle-done) + "Functions to be invoked each time a given REPL interaction is complete.") + +(defun cider-repl-handler (buffer) + "Make an nREPL evaluation handler for the REPL BUFFER." + (let ((show-prompt t)) + (nrepl-make-response-handler + buffer + (lambda (buffer value) + (cider-repl-emit-result buffer value t)) + (lambda (buffer out) + (dolist (f cider--repl-stdout-functions) + (funcall f buffer out)) + (cider-repl-emit-stdout buffer out)) + (lambda (buffer err) + (dolist (f cider--repl-stderr-functions) + (funcall f buffer err)) + (cider-repl-emit-stderr buffer err)) + (lambda (buffer) + (when show-prompt + (cider-repl-emit-prompt buffer)) + (when cider-repl-buffer-size-limit + (cider-repl-maybe-trim-buffer buffer)) + (dolist (f cider--repl-done-functions) + (funcall f buffer))) + nrepl-err-handler + (lambda (buffer value content-type) + (if-let* ((content-attrs (cadr content-type)) + (content-type* (car content-type)) + (handler (cdr (assoc content-type* + cider-repl-content-type-handler-alist)))) + (setq show-prompt (funcall handler content-type buffer value nil t)) + (cider-repl-emit-result buffer value t t))) + (lambda (buffer warning) + (cider-repl-emit-stderr buffer warning))))) + +(defun cider--repl-request-map (right-margin) + "Map to be merged into REPL eval requests. +RIGHT-MARGIN is as in `cider--nrepl-print-request-map'." + (map-merge 'hash-table + (cider--nrepl-print-request-map right-margin) + (unless cider-repl-use-pretty-printing + '(("nrepl.middleware.print/print" "cider.nrepl.pprint/pr"))) + (when cider-repl-use-content-types + (cider--nrepl-content-type-map)))) + +(defun cider-repl--send-input (&optional newline) + "Go to the end of the input and send the current input. +If NEWLINE is true then add a newline at the end of the input." + (unless (cider-repl--in-input-area-p) + (error "No input at point")) + (let ((input (cider-repl--current-input))) + (if (string-blank-p input) + ;; don't evaluate a blank string, but erase it and emit + ;; a fresh prompt to acknowledge to the user. + (progn + (cider-repl--replace-input "") + (cider-repl-emit-prompt (current-buffer))) + ;; otherwise evaluate the input + (goto-char (point-max)) + (let ((end (point))) ; end of input, without the newline + (cider-repl--add-to-input-history input) + (when newline + (insert "\n")) + (let ((inhibit-modification-hooks t)) + (add-text-properties cider-repl-input-start-mark + (point) + `(cider-old-input + ,(cl-incf cider-repl-old-input-counter)))) + (unless cider-repl-use-clojure-font-lock + (let ((overlay (make-overlay cider-repl-input-start-mark end))) + ;; These properties are on an overlay so that they won't be taken + ;; by kill/yank. + (overlay-put overlay 'read-only t) + (overlay-put overlay 'font-lock-face 'cider-repl-input-face)))) + (let ((input-start (save-excursion (cider-repl-beginning-of-defun) (point)))) + (goto-char (point-max)) + (cider-repl--mark-input-start) + (cider-repl--mark-output-start) + (cider-nrepl-request:eval + input + (cider-repl-handler (current-buffer)) + (cider-current-ns) + (line-number-at-pos input-start) + (cider-column-number-at-pos input-start) + (thread-last + (cider--repl-request-map fill-column) + (map-pairs) + (seq-mapcat #'identity))))))) + +(defun cider-repl-return (&optional end-of-input) + "Evaluate the current input string, or insert a newline. +Send the current input only if a whole expression has been entered, +i.e. the parenthesis are matched. +When END-OF-INPUT is non-nil, send the input even if the parentheses +are not balanced." + (interactive "P") + (cond + (end-of-input + (cider-repl--send-input)) + ((and (get-text-property (point) 'cider-old-input) + (< (point) cider-repl-input-start-mark)) + (cider-repl--grab-old-input end-of-input)) + ((cider-repl--input-complete-p cider-repl-input-start-mark (point-max)) + (cider-repl--send-input t)) + (t + (cider-repl-newline-and-indent) + (message "[input not complete]")))) + +(defun cider-repl--grab-old-input (replace) + "Resend the old REPL input at point. +If REPLACE is non-nil the current input is replaced with the old +input; otherwise the new input is appended. The old input has the +text property `cider-old-input'." + (cl-multiple-value-bind (beg end) (cider-property-bounds 'cider-old-input) + (let ((old-input (buffer-substring beg end)) ;;preserve + ;;properties, they will be removed later + (offset (- (point) beg))) + ;; Append the old input or replace the current input + (cond (replace (goto-char cider-repl-input-start-mark)) + (t (goto-char (point-max)) + (unless (eq (char-before) ?\ ) + (insert " ")))) + (delete-region (point) (point-max)) + (save-excursion + (insert old-input) + (when (equal (char-before) ?\n) + (delete-char -1))) + (forward-char offset)))) + +(defun cider-repl-closing-return () + "Evaluate the current input string after closing input. +Closes all open parentheses or bracketed expressions." + (interactive) + (goto-char (point-max)) + (save-restriction + (narrow-to-region cider-repl-input-start-mark (point)) + (let ((matching-delimiter nil)) + (while (ignore-errors + (save-excursion + (backward-up-list 1) + (setq matching-delimiter (cdr (syntax-after (point))))) + t) + (insert-char matching-delimiter)))) + (cider-repl-return)) + +(defun cider-repl-toggle-pretty-printing () + "Toggle pretty-printing in the REPL." + (interactive) + (setq cider-repl-use-pretty-printing (not cider-repl-use-pretty-printing)) + (message "Pretty printing in REPL %s." + (if cider-repl-use-pretty-printing "enabled" "disabled"))) + +(defun cider-repl-toggle-content-types () + "Toggle content-type rendering in the REPL." + (interactive) + (setq cider-repl-use-content-types (not cider-repl-use-content-types)) + (message "Content-type support in REPL %s." + (if cider-repl-use-content-types "enabled" "disabled"))) + +(defun cider-repl-toggle-clojure-font-lock () + "Toggle pretty-printing in the REPL." + (interactive) + (setq cider-repl-use-clojure-font-lock (not cider-repl-use-clojure-font-lock)) + (message "Clojure font-locking in REPL %s." + (if cider-repl-use-clojure-font-lock "enabled" "disabled"))) + +(defun cider-repl-switch-to-other () + "Switch between the Clojure and ClojureScript REPLs for the current project." + (interactive) + ;; FIXME: implement cycling as session can hold more than two REPLs + (let* ((this-repl (cider-current-repl nil 'ensure)) + (other-repl (car (seq-remove (lambda (r) (eq r this-repl)) (cider-repls nil t))))) + (if other-repl + (switch-to-buffer other-repl) + (user-error "No other REPL in current session (%s)" + (car (sesman-current-session 'CIDER)))))) + +(defvar cider-repl-clear-buffer-hook) + +(defun cider-repl--clear-region (start end) + "Delete the output and its overlays between START and END." + (mapc #'delete-overlay (overlays-in start end)) + (delete-region start end)) + +(defun cider-repl-clear-buffer () + "Clear the currently visited REPL buffer completely. +See also the related commands `cider-repl-clear-output' and +`cider-find-and-clear-repl-output'." + (interactive) + (let ((inhibit-read-only t)) + (cider-repl--clear-region (point-min) cider-repl-prompt-start-mark) + (cider-repl--clear-region cider-repl-output-start cider-repl-output-end) + (when (< (point) cider-repl-input-start-mark) + (goto-char cider-repl-input-start-mark)) + (recenter t)) + (run-hooks 'cider-repl-clear-buffer-hook)) + +(defun cider-repl-clear-output (&optional clear-repl) + "Delete the output inserted since the last input. +With a prefix argument CLEAR-REPL it will clear the entire REPL buffer instead." + (interactive "P") + (if clear-repl + (cider-repl-clear-buffer) + (let ((inhibit-read-only t)) + (cider-repl--clear-region cider-repl-output-start cider-repl-output-end) + (save-excursion + (goto-char cider-repl-output-end) + (insert-before-markers + (propertize ";; output cleared\n" 'font-lock-face 'font-lock-comment-face)))))) + +(defun cider-repl-clear-banners () + "Delete the REPL banners." + (interactive) + ;; TODO: Improve the boundaries detecting logic + ;; probably it should be based on text properties + ;; the current implementation will clear warnings as well + (let ((start (point-min)) + (end (save-excursion + (goto-char (point-min)) + (cider-repl-next-prompt) + (forward-line -1) + (end-of-line) + (point)))) + (when (< start end) + (let ((inhibit-read-only t)) + (cider-repl--clear-region start (1+ end)))))) + +(defun cider-repl-clear-help-banner () + "Delete the help REPL banner." + (interactive) + ;; TODO: Improve the boundaries detecting logic + ;; probably it should be based on text properties + (let ((start (save-excursion + (goto-char (point-min)) + (search-forward ";; =") + (beginning-of-line) + (point))) + (end (save-excursion + (goto-char (point-min)) + (cider-repl-next-prompt) + (search-backward ";; =") + (end-of-line) + (point)))) + (when (< start end) + (let ((inhibit-read-only t)) + (cider-repl--clear-region start (1+ end)))))) + +(defun cider-repl-switch-ns-handler (buffer) + "Make an nREPL evaluation handler for the REPL BUFFER's ns switching." + (nrepl-make-response-handler buffer + (lambda (_buffer _value)) + (lambda (buffer out) + (cider-repl-emit-stdout buffer out)) + (lambda (buffer err) + (cider-repl-emit-stderr buffer err)) + (lambda (buffer) + (cider-repl-emit-prompt buffer)))) + +(defun cider-repl-set-ns (ns) + "Switch the namespace of the REPL buffer to NS. +If called from a cljc buffer act on both the Clojure and ClojureScript REPL +if there are more than one REPL present. If invoked in a REPL buffer the +command will prompt for the name of the namespace to switch to." + (interactive (list (if (or (derived-mode-p 'cider-repl-mode) + (null (cider-ns-form))) + (completing-read "Switch to namespace: " + (cider-sync-request:ns-list)) + (cider-current-ns)))) + (when (or (not ns) (equal ns "")) + (user-error "No namespace selected")) + (cider-map-repls :auto + (lambda (connection) + ;; NOTE: `require' and `in-ns' are special forms in ClojureScript. + ;; That's why we eval them separately instead of combining them with `do'. + (when cider-repl-require-ns-on-set + (cider-sync-tooling-eval (format "(require '%s)" ns) nil connection)) + (let ((f (if (equal 'cljs + (with-current-buffer connection + cider-repl-type)) + ;; For cljs, don't use cider-tooling-eval, because Piggieback will later change the ns (issue #3503): + #'cider-nrepl-request:eval + ;; When possible, favor cider-tooling-eval because it preserves *1, etc (commit 5f705b): + #'cider-tooling-eval))) + (funcall f (format "(in-ns '%s)" ns) + (cider-repl-switch-ns-handler connection)))))) + + +;;; Location References + +(defcustom cider-locref-regexp-alist + '((stdout-stacktrace "[ \t]\\(at \\([^$(]+\\).*(\\([^:()]+\\):\\([0-9]+\\))\\)" 1 2 3 4) + (aviso-stacktrace "^[ \t]*\\(\\([^$/ \t]+\\).*? +\\([^:]+\\): +\\([0-9]+\\)\\)" 1 2 3 4) + (print-stacktrace "\\[\\([^][$ \t]+\\).* +\\([^ \t]+\\) +\\([0-9]+\\)\\]" 0 1 2 3) + (timbre-log "\\(TRACE\\|INFO\\|DEBUG\\|WARN\\|ERROR\\) +\\(\\[\\([^:]+\\):\\([0-9]+\\)\\]\\)" 2 3 nil 4) + (cljs-message "at line \\([0-9]+\\) +\\(.*\\)$" 0 nil 2 1) + (warning "warning,? +\\(\\([^\n:]+\\):\\([0-9]+\\):[0-9]+\\)" 1 nil 2 3) + (compilation ".*compiling:(\\([^\n:)]+\\):\\([0-9]+\\):[0-9]+)" 0 nil 1 2)) + "Alist holding regular expressions for inline location references. +Each element in the alist has the form (NAME REGEXP HIGHLIGHT VAR FILE +LINE), where NAME is the identifier of the regexp, REGEXP - regexp matching +a location, HIGHLIGHT - sub-expression matching region to highlight on +mouse-over, VAR - sub-expression giving Clojure VAR to look up. FILE is +currently only used when VAR is nil and must be full resource path in that +case." + :type '(alist :key-type sexp) + :package-version '(cider. "0.16.0")) + +(defun cider--locref-at-point-1 (reg-list) + "Workhorse for getting locref at point. +REG-LIST is an entry in `cider-locref-regexp-alist'." + (beginning-of-line) + (when (re-search-forward (nth 1 reg-list) (point-at-eol) t) + (let ((ix-highlight (or (nth 2 reg-list) 0)) + (ix-var (nth 3 reg-list)) + (ix-file (nth 4 reg-list)) + (ix-line (nth 5 reg-list))) + (list + :type (car reg-list) + :highlight (cons (match-beginning ix-highlight) (match-end ix-highlight)) + :var (and ix-var + (replace-regexp-in-string "_" "-" + (match-string-no-properties ix-var) + nil t)) + :file (and ix-file (match-string-no-properties ix-file)) + :line (and ix-line (string-to-number (match-string-no-properties ix-line))))))) + +(defun cider-locref-at-point (&optional pos) + "Return a plist of components of the location reference at POS. +Limit search to current line only and return nil if no location has been +found. Returned keys are :type, :highlight, :var, :file, :line, where +:highlight is a cons of positions, :var and :file are strings or nil, :line +is a number. See `cider-locref-regexp-alist' for how to specify regexes +for locref look up." + (save-excursion + (goto-char (or pos (point))) + ;; Regexp lookup on long lines can result in significant hangs #2532. We + ;; assume that lines longer than 300 don't contain source references. + (when (< (- (point-at-eol) (point-at-bol)) 300) + (seq-some (lambda (rl) (cider--locref-at-point-1 rl)) + cider-locref-regexp-alist)))) + +(defun cider-jump-to-locref-at-point (&optional pos) + "Identify location reference at POS and navigate to it. +This function is used from help-echo property inside REPL buffers and uses +regexes from `cider-locref-regexp-alist' to infer locations at point." + (interactive) + (if-let* ((loc (cider-locref-at-point pos))) + (let* ((var (plist-get loc :var)) + (line (plist-get loc :line)) + (file (or + ;; 1) retrieve from info middleware + (when var + (or (cider-sync-request:ns-path var) + (nrepl-dict-get (cider-sync-request:info var) "file"))) + (when-let* ((file (plist-get loc :file))) + ;; 2) file detected by the regexp + (let ((file-from-regexp (if (file-name-absolute-p file) + file + ;; when not absolute, expand within the current project + (when-let* ((proj (clojure-project-dir))) + (expand-file-name file proj))))) + (or (when (file-readable-p file-from-regexp) + file-from-regexp) + ;; 3) infer ns from the abbreviated path + ;; (common in reflection warnings) + (let ((ns (cider-path-to-ns file))) + (cider-sync-request:ns-path ns)))))))) + (if file + (cider--jump-to-loc-from-info (nrepl-dict "file" file "line" line) t) + (error "No source location for %s - you may need to adjust `cider-locref-regexp-alist' to match your logging format" var))) + (user-error "No location reference at point"))) + +(defvar cider-locref-hoover-overlay + (let ((o (make-overlay 1 1))) + (overlay-put o 'category 'cider-error-hoover) + ;; (overlay-put o 'face 'highlight) + (overlay-put o 'pointer 'hand) + (overlay-put o 'mouse-face 'highlight) + (overlay-put o 'follow-link 'mouse) + (overlay-put o 'keymap + (let ((map (make-sparse-keymap))) + (define-key map [return] #'cider-jump-to-locref-at-point) + (define-key map [mouse-2] #'cider-jump-to-locref-at-point) + map)) + o) + "Overlay used during hoovering on location references in REPL buffers. +One for all REPLs.") + +(defun cider-locref-help-echo (_win buffer pos) + "Function for help-echo property in REPL buffers. +WIN, BUFFER and POS are the window, buffer and point under mouse position." + (with-current-buffer buffer + (if-let* ((hl (plist-get (cider-locref-at-point pos) :highlight))) + (move-overlay cider-locref-hoover-overlay (car hl) (cdr hl) buffer) + (delete-overlay cider-locref-hoover-overlay)) + nil)) + + +;;; History + +(defcustom cider-repl-wrap-history nil + "T to wrap history around when the end is reached." + :type 'boolean) + +;; These two vars contain the state of the last history search. We +;; only use them if `last-command' was `cider-repl--history-replace', +;; otherwise we reinitialize them. + +(defvar cider-repl-input-history-position -1 + "Newer items have smaller indices.") + +(defvar cider-repl-history-pattern nil + "The regexp most recently used for finding input history.") + +(defun cider-repl--add-to-input-history (string) + "Add STRING to the input history. +Empty strings and duplicates are ignored." + (unless (or (equal string "") + (equal string (car cider-repl-input-history))) + (push string cider-repl-input-history) + (cl-incf cider-repl-input-history-items-added))) + +(defun cider-repl-delete-current-input () + "Delete all text after the prompt." + (goto-char (point-max)) + (delete-region cider-repl-input-start-mark (point-max))) + +(defun cider-repl--replace-input (string) + "Replace the current REPL input with STRING." + (cider-repl-delete-current-input) + (insert-and-inherit string)) + +(defun cider-repl--position-in-history (start-pos direction regexp) + "Return the position of the history item starting at START-POS. +Search in DIRECTION for REGEXP. +Return -1 resp the length of the history if no item matches." + ;; Loop through the history list looking for a matching line + (let* ((step (cl-ecase direction + (forward -1) + (backward 1))) + (history cider-repl-input-history) + (len (length history))) + (cl-loop for pos = (+ start-pos step) then (+ pos step) + if (< pos 0) return -1 + if (<= len pos) return len + if (string-match-p regexp (nth pos history)) return pos))) + +(defun cider-repl--history-replace (direction &optional regexp) + "Replace the current input with the next line in DIRECTION. +DIRECTION is 'forward' or 'backward' (in the history list). +If REGEXP is non-nil, only lines matching REGEXP are considered." + (setq cider-repl-history-pattern regexp) + (let* ((min-pos -1) + (max-pos (length cider-repl-input-history)) + (pos0 (cond ((cider-history-search-in-progress-p) + cider-repl-input-history-position) + (t min-pos))) + (pos (cider-repl--position-in-history pos0 direction (or regexp ""))) + (msg nil)) + (cond ((and (< min-pos pos) (< pos max-pos)) + (cider-repl--replace-input (nth pos cider-repl-input-history)) + (setq msg (format "History item: %d" pos))) + ((not cider-repl-wrap-history) + (setq msg (cond ((= pos min-pos) "End of history") + ((= pos max-pos) "Beginning of history")))) + (cider-repl-wrap-history + (setq pos (if (= pos min-pos) max-pos min-pos)) + (setq msg "Wrapped history"))) + (when (or (<= pos min-pos) (<= max-pos pos)) + (when regexp + (setq msg (concat msg "; no matching item")))) + (message "%s%s" msg (cond ((not regexp) "") + (t (format "; current regexp: %s" regexp)))) + (setq cider-repl-input-history-position pos) + (setq this-command 'cider-repl--history-replace))) + +(defun cider-history-search-in-progress-p () + "Return t if a current history search is in progress." + (eq last-command 'cider-repl--history-replace)) + +(defun cider-terminate-history-search () + "Terminate the current history search." + (setq last-command this-command)) + +(defun cider-repl-previous-input () + "Cycle backwards through input history. +If the `last-command' was a history navigation command use the +same search pattern for this command. +Otherwise use the current input as search pattern." + (interactive) + (cider-repl--history-replace 'backward (cider-repl-history-pattern t))) + +(defun cider-repl-next-input () + "Cycle forwards through input history. +See `cider-previous-input'." + (interactive) + (cider-repl--history-replace 'forward (cider-repl-history-pattern t))) + +(defun cider-repl-forward-input () + "Cycle forwards through input history." + (interactive) + (cider-repl--history-replace 'forward (cider-repl-history-pattern))) + +(defun cider-repl-backward-input () + "Cycle backwards through input history." + (interactive) + (cider-repl--history-replace 'backward (cider-repl-history-pattern))) + +(defun cider-repl-previous-matching-input (regexp) + "Find the previous input matching REGEXP." + (interactive "sPrevious element matching (regexp): ") + (cider-terminate-history-search) + (cider-repl--history-replace 'backward regexp)) + +(defun cider-repl-next-matching-input (regexp) + "Find then next input matching REGEXP." + (interactive "sNext element matching (regexp): ") + (cider-terminate-history-search) + (cider-repl--history-replace 'forward regexp)) + +(defun cider-repl-history-pattern (&optional use-current-input) + "Return the regexp for the navigation commands. +If USE-CURRENT-INPUT is non-nil, use the current input." + (cond ((cider-history-search-in-progress-p) + cider-repl-history-pattern) + (use-current-input + (cl-assert (<= cider-repl-input-start-mark (point))) + (let ((str (cider-repl--current-input t))) + (cond ((string-match-p "^[ \n]*$" str) nil) + (t (concat "^" (regexp-quote str)))))) + (t nil))) + +;;; persistent history +(defcustom cider-repl-history-size 500 + "The maximum number of items to keep in the REPL history." + :type 'integer + :safe #'integerp) + +(defcustom cider-repl-history-file nil + "File to save the persistent REPL history to." + :type 'string + :safe #'stringp) + +(defun cider-repl--history-read-filename () + "Ask the user which file to use, defaulting `cider-repl-history-file'." + (read-file-name "Use CIDER REPL history file: " + cider-repl-history-file)) + +(defun cider-repl--history-read (filename) + "Read history from FILENAME and return it. +It does not yet set the input history." + (if (file-readable-p filename) + (with-temp-buffer + (insert-file-contents filename) + (when (> (buffer-size (current-buffer)) 0) + (read (current-buffer)))) + '())) + +(defun cider-repl-history-load (&optional filename) + "Load history from FILENAME into current session. +FILENAME defaults to the value of `cider-repl-history-file' but user +defined filenames can be used to read special history files. + +The value of `cider-repl-input-history' is set by this function." + (interactive (list (cider-repl--history-read-filename))) + (let ((f (or filename cider-repl-history-file))) + ;; TODO: probably need to set cider-repl-input-history-position as well. + ;; in a fresh connection the newest item in the list is currently + ;; not available. After sending one input, everything seems to work. + (setq cider-repl-input-history (cider-repl--history-read f)))) + +(defun cider-repl--history-write (filename) + "Write history to FILENAME. +Currently coding system for writing the contents is hardwired to +utf-8-unix." + (let* ((mhist (cider-repl--histories-merge cider-repl-input-history + cider-repl-input-history-items-added + (cider-repl--history-read filename))) + ;; newest items are at the beginning of the list, thus 0 + (hist (cl-subseq mhist 0 (min (length mhist) cider-repl-history-size)))) + (unless (file-writable-p filename) + (error (format "History file not writable: %s" filename))) + (let ((print-length nil) (print-level nil)) + (with-temp-file filename + ;; TODO: really set cs for output + ;; TODO: does cs need to be customizable? + (insert ";; -*- coding: utf-8-unix -*-\n") + (insert ";; Automatically written history of CIDER REPL session\n") + (insert ";; Edit at your own risk\n\n") + (prin1 (mapcar #'substring-no-properties hist) (current-buffer)))))) + +(defun cider-repl-history-save (&optional filename) + "Save the current REPL input history to FILENAME. +FILENAME defaults to the value of `cider-repl-history-file'." + (interactive (list (cider-repl--history-read-filename))) + (let* ((file (or filename cider-repl-history-file))) + (cider-repl--history-write file))) + +(defun cider-repl-history-just-save () + "Just save the history to `cider-repl-history-file'. +This function is meant to be used in hooks to avoid lambda +constructs." + (cider-repl-history-save cider-repl-history-file)) + +;; SLIME has different semantics and will not save any duplicates. +;; we keep track of how many items were added to the history in the +;; current session in `cider-repl--add-to-input-history' and merge only the +;; new items with the current history found in the file, which may +;; have been changed in the meantime by another session. +(defun cider-repl--histories-merge (session-hist n-added-items file-hist) + "Merge histories from SESSION-HIST adding N-ADDED-ITEMS into FILE-HIST." + (append (cl-subseq session-hist 0 n-added-items) + file-hist)) + + +;;; REPL shortcuts +(defcustom cider-repl-shortcut-dispatch-char ?\, + "Character used to distinguish REPL commands from Lisp forms." + :type '(character)) + +(defvar cider-repl-shortcuts (make-hash-table :test 'equal)) + +(defun cider-repl-add-shortcut (name handler) + "Add a REPL shortcut command, defined by NAME and HANDLER." + (puthash name handler cider-repl-shortcuts)) + +(declare-function cider-toggle-trace-ns "cider-tracing") +(declare-function cider-undef "cider-eval") +(declare-function cider-browse-ns "cider-browse-ns") +(declare-function cider-classpath "cider-classpath") +(declare-function cider-repl-history "cider-repl-history") +(declare-function cider-run "cider-mode") +(declare-function cider-ns-refresh "cider-ns") +(declare-function cider-ns-reload "cider-ns") +(declare-function cider-find-var "cider-find") +(declare-function cider-version "cider") +(declare-function cider-test-run-loaded-tests "cider-test") +(declare-function cider-test-run-project-tests "cider-test") +(cider-repl-add-shortcut "clear-output" #'cider-repl-clear-output) +(cider-repl-add-shortcut "clear" #'cider-repl-clear-buffer) +(cider-repl-add-shortcut "clear-banners" #'cider-repl-clear-banners) +(cider-repl-add-shortcut "clear-help-banner" #'cider-repl-clear-help-banner) +(cider-repl-add-shortcut "trim" #'cider-repl-trim-buffer) +(cider-repl-add-shortcut "ns" #'cider-repl-set-ns) +(cider-repl-add-shortcut "toggle-pprint" #'cider-repl-toggle-pretty-printing) +(cider-repl-add-shortcut "toggle-font-lock" #'cider-repl-toggle-clojure-font-lock) +(cider-repl-add-shortcut "toggle-content-types" #'cider-repl-toggle-content-types) +(cider-repl-add-shortcut "browse-ns" (lambda () (interactive) (cider-browse-ns (cider-current-ns)))) +(cider-repl-add-shortcut "classpath" #'cider-classpath) +(cider-repl-add-shortcut "history" #'cider-repl-history) +(cider-repl-add-shortcut "trace-ns" #'cider-toggle-trace-ns) +(cider-repl-add-shortcut "undef" #'cider-undef) +(cider-repl-add-shortcut "refresh" #'cider-ns-refresh) +(cider-repl-add-shortcut "reload" #'cider-ns-reload) +(cider-repl-add-shortcut "find-var" #'cider-find-var) +(cider-repl-add-shortcut "doc" #'cider-doc) +(cider-repl-add-shortcut "help" #'cider-repl-shortcuts-help) +(cider-repl-add-shortcut "test-ns" #'cider-test-run-ns-tests) +(cider-repl-add-shortcut "test-all" #'cider-test-run-loaded-tests) +(cider-repl-add-shortcut "test-project" #'cider-test-run-project-tests) +(cider-repl-add-shortcut "test-ns-with-filters" #'cider-test-run-ns-tests-with-filters) +(cider-repl-add-shortcut "test-all-with-filters" (lambda () (interactive) (cider-test-run-loaded-tests 'prompt-for-filters))) +(cider-repl-add-shortcut "test-project-with-filters" (lambda () (interactive) (cider-test-run-project-tests 'prompt-for-filters))) +(cider-repl-add-shortcut "test-report" #'cider-test-show-report) +(cider-repl-add-shortcut "run" #'cider-run) +(cider-repl-add-shortcut "conn-info" #'cider-describe-connection) +(cider-repl-add-shortcut "version" #'cider-version) +(cider-repl-add-shortcut "require-repl-utils" #'cider-repl-require-repl-utils) +;; So many ways to quit :-) +(cider-repl-add-shortcut "adios" #'cider-quit) +(cider-repl-add-shortcut "sayonara" #'cider-quit) +(cider-repl-add-shortcut "quit" #'cider-quit) +(cider-repl-add-shortcut "restart" #'cider-restart) + +(defconst cider-repl-shortcuts-help-buffer "*CIDER REPL Shortcuts Help*") + +(defun cider-repl-shortcuts-help () + "Display a help buffer." + (interactive) + (ignore-errors (kill-buffer cider-repl-shortcuts-help-buffer)) + (with-current-buffer (get-buffer-create cider-repl-shortcuts-help-buffer) + (insert "CIDER REPL shortcuts:\n\n") + (maphash (lambda (k v) (insert (format "%s:\n\t%s\n" k v))) cider-repl-shortcuts) + (goto-char (point-min)) + (help-mode) + (display-buffer (current-buffer) t)) + (cider-repl-handle-shortcut) + (current-buffer)) + +(defun cider-repl--available-shortcuts () + "Return the available REPL shortcuts." + (cider-util--hash-keys cider-repl-shortcuts)) + +(defun cider-repl-handle-shortcut () + "Execute a REPL shortcut." + (interactive) + (if (> (point) cider-repl-input-start-mark) + (insert (string cider-repl-shortcut-dispatch-char)) + (let ((command (completing-read "Command: " + (cider-repl--available-shortcuts)))) + (if (not (equal command "")) + (let ((command-func (gethash command cider-repl-shortcuts))) + (if command-func + (call-interactively command-func) + (error "Unknown command %S. Available commands: %s" + command-func + (mapconcat #'identity (cider-repl--available-shortcuts) ", ")))) + (error "No command selected"))))) + +(defun cider--sesman-friendly-session-p (session &optional debug) + "Check if SESSION is a friendly session, DEBUG optionally. + +The checking is done as follows: + +* If the current buffer's name equals to the value of `cider-test-report-buffer', + only accept the given session's repl if it equals `cider-test--current-repl' +* Consider if the buffer belongs to `cider-ancillary-buffers' +* Consider the buffer's filename, strip any Docker/TRAMP details from it +* Check if that filename belongs to the classpath, + or to the classpath roots (e.g. the project root dir) +* As a fallback, check if the buffer's ns form + matches any of the loaded namespaces." + (setcdr session (seq-filter #'buffer-live-p (cdr session))) + (when-let ((repl (cadr session))) + (cond + ((equal (buffer-name) + cider-test-report-buffer) + (or (not cider-test--current-repl) + (not (buffer-live-p cider-test--current-repl)) + (equal repl + cider-test--current-repl))) + + ((member (buffer-name) cider-ancillary-buffers) + t) + + (t + (when-let* ((proc (get-buffer-process repl)) + (file (file-truename (or (buffer-file-name) default-directory)))) + ;; With avfs paths look like /path/to/.avfs/path/to/some.jar#uzip/path/to/file.clj + (when (string-match-p "#uzip" file) + (let ((avfs-path (directory-file-name (expand-file-name (or (getenv "AVFSBASE") "~/.avfs/"))))) + (setq file (replace-regexp-in-string avfs-path "" file t t)))) + (when-let ((tp (cider-tramp-prefix (current-buffer)))) + (setq file (string-remove-prefix tp file))) + (when (process-live-p proc) + (let* ((classpath (or (process-get proc :cached-classpath) + (let ((cp (with-current-buffer repl + (cider-classpath-entries)))) + (process-put proc :cached-classpath cp) + cp))) + (ns-list (when (nrepl-op-supported-p "ns-list" repl) + (or (process-get proc :all-namespaces) + (let ((ns-list (with-current-buffer repl + (cider-sync-request:ns-list)))) + (process-put proc :all-namespaces ns-list) + ns-list)))) + (classpath-roots (or (process-get proc :cached-classpath-roots) + (let ((cp (thread-last classpath + (seq-filter (lambda (path) (not (string-match-p "\\.jar$" path)))) + (mapcar #'file-name-directory) + (seq-remove #'null) + (seq-uniq)))) + (process-put proc :cached-classpath-roots cp) + cp)))) + (or (seq-find (lambda (path) (string-prefix-p path file)) + classpath) + (seq-find (lambda (path) (string-prefix-p path file)) + classpath-roots) + (when-let* ((cider-path-translations (cider--all-path-translations)) + (translated (cider--translate-path file 'to-nrepl :return-all))) + (seq-find (lambda (translated-path) + (or (seq-find (lambda (path) + (string-prefix-p path translated-path)) + classpath) + (seq-find (lambda (path) + (string-prefix-p path translated-path)) + classpath-roots))) + translated)) + (when-let ((ns (condition-case nil + (substring-no-properties (cider-current-ns :no-default + ;; important - don't query the repl, + ;; avoiding a recursive invocation of `cider--sesman-friendly-session-p`: + :no-repl-check)) + (error nil)))) + ;; if the ns form matches with a ns of all runtime namespaces, we can consider the buffer to match + ;; (this is a bit lax, but also quite useful) + (with-current-buffer repl + (or (when cider-repl-ns-cache ;; may be nil on repl startup + (member ns (nrepl-dict-keys cider-repl-ns-cache))) + (member ns ns-list)))) + (when debug + (list file "was not determined to belong to classpath:" classpath "or classpath-roots:" classpath-roots)))))))))) + +(defun cider-debug-sesman-friendly-session-p () + "`message's debugging information relative to friendly sessions. + +This is useful for when one sees 'No linked CIDER sessions' +in an unexpected place." + (interactive) + (message (prin1-to-string (mapcar (lambda (session) + (cider--sesman-friendly-session-p session t)) + (sesman--all-system-sessions 'CIDER))))) + +(cl-defmethod sesman-friendly-session-p ((_system (eql CIDER)) session) + "Check if SESSION is a friendly session." + (cider--sesman-friendly-session-p session)) + + +;;;;; CIDER REPL mode +(defvar cider-repl-mode-hook nil + "Hook executed when entering `cider-repl-mode'.") + +(defvar cider-repl-mode-syntax-table + (copy-syntax-table clojure-mode-syntax-table)) + +(declare-function cider-eval-last-sexp "cider-eval") +(declare-function cider-toggle-trace-ns "cider-tracing") +(declare-function cider-toggle-trace-var "cider-tracing") +(declare-function cider-find-resource "cider-find") +(declare-function cider-find-ns "cider-find") +(declare-function cider-find-keyword "cider-find") +(declare-function cider-find-var "cider-find") +(declare-function cider-switch-to-last-clojure-buffer "cider-mode") +(declare-function cider-macroexpand-1 "cider-macroexpansion") +(declare-function cider-macroexpand-all "cider-macroexpansion") +(declare-function cider-selector "cider-selector") +(declare-function cider-jack-in-clj "cider") +(declare-function cider-jack-in-cljs "cider") +(declare-function cider-connect-clj "cider") +(declare-function cider-connect-cljs "cider") + +(defvar cider-repl-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-d") 'cider-doc-map) + (define-key map (kbd "C-c ,") 'cider-test-commands-map) + (define-key map (kbd "C-c C-t") 'cider-test-commands-map) + (define-key map (kbd "M-.") #'cider-find-var) + (define-key map (kbd "C-c C-.") #'cider-find-ns) + (define-key map (kbd "C-c C-:") #'cider-find-keyword) + (define-key map (kbd "M-,") #'cider-pop-back) + (define-key map (kbd "C-c M-.") #'cider-find-resource) + (define-key map (kbd "RET") #'cider-repl-return) + (define-key map (kbd "TAB") #'cider-repl-tab) + (define-key map (kbd "C-") #'cider-repl-closing-return) + (define-key map (kbd "C-j") #'cider-repl-newline-and-indent) + (define-key map (kbd "C-c C-o") #'cider-repl-clear-output) + (define-key map (kbd "C-c M-n") #'cider-repl-set-ns) + (define-key map (kbd "C-c C-u") #'cider-repl-kill-input) + (define-key map (kbd "C-S-a") #'cider-repl-bol-mark) + (define-key map [S-home] #'cider-repl-bol-mark) + (define-key map (kbd "C-") #'cider-repl-backward-input) + (define-key map (kbd "C-") #'cider-repl-forward-input) + (define-key map (kbd "M-p") #'cider-repl-previous-input) + (define-key map (kbd "M-n") #'cider-repl-next-input) + (define-key map (kbd "M-r") #'cider-repl-previous-matching-input) + (define-key map (kbd "M-s") #'cider-repl-next-matching-input) + (define-key map (kbd "C-c C-n") #'cider-repl-next-prompt) + (define-key map (kbd "C-c C-p") #'cider-repl-previous-prompt) + (define-key map (kbd "C-c C-b") #'cider-interrupt) + (define-key map (kbd "C-c C-c") #'cider-interrupt) + (define-key map (kbd "C-c C-m") #'cider-macroexpand-1) + (define-key map (kbd "C-c M-m") #'cider-macroexpand-all) + (define-key map (kbd "C-c C-s") #'sesman-map) + (define-key map (kbd "C-c C-z") #'cider-switch-to-last-clojure-buffer) + (define-key map (kbd "C-c M-o") #'cider-repl-switch-to-other) + (define-key map (kbd "C-c M-s") #'cider-selector) + (define-key map (kbd "C-c M-d") #'cider-describe-connection) + (define-key map (kbd "C-c C-q") #'cider-quit) + (define-key map (kbd "C-c M-r") #'cider-restart) + (define-key map (kbd "C-c M-i") #'cider-inspect) + (define-key map (kbd "C-c M-p") #'cider-repl-history) + (define-key map (kbd "C-c M-t v") #'cider-toggle-trace-var) + (define-key map (kbd "C-c M-t n") #'cider-toggle-trace-ns) + (define-key map (kbd "C-c C-x") 'cider-start-map) + (define-key map (kbd "C-x C-e") #'cider-eval-last-sexp) + (define-key map (kbd "C-c C-r") 'clojure-refactor-map) + (define-key map (kbd "C-c C-v") 'cider-eval-commands-map) + (define-key map (kbd "C-c M-j") #'cider-jack-in-clj) + (define-key map (kbd "C-c M-J") #'cider-jack-in-cljs) + (define-key map (kbd "C-c M-c") #'cider-connect-clj) + (define-key map (kbd "C-c M-C") #'cider-connect-cljs) + + (define-key map (string cider-repl-shortcut-dispatch-char) #'cider-repl-handle-shortcut) + (easy-menu-define cider-repl-mode-menu map + "Menu for CIDER's REPL mode" + `("REPL" + ["Complete symbol" complete-symbol] + "--" + ,cider-doc-menu + "--" + ("Find" + ["Find definition" cider-find-var] + ["Find namespace" cider-find-ns] + ["Find resource" cider-find-resource] + ["Find keyword" cider-find-keyword] + ["Go back" cider-pop-back]) + "--" + ["Switch to Clojure buffer" cider-switch-to-last-clojure-buffer] + ["Switch to other REPL" cider-repl-switch-to-other] + "--" + ("Macroexpand" + ["Macroexpand-1" cider-macroexpand-1] + ["Macroexpand-all" cider-macroexpand-all]) + "--" + ,cider-test-menu + "--" + ["Run project (-main function)" cider-run] + ["Inspect" cider-inspect] + ["Toggle var tracing" cider-toggle-trace-var] + ["Toggle ns tracing" cider-toggle-trace-ns] + ["Refresh loaded code" cider-ns-refresh] + "--" + ["Set REPL ns" cider-repl-set-ns] + ["Toggle pretty printing" cider-repl-toggle-pretty-printing] + ["Toggle Clojure font-lock" cider-repl-toggle-clojure-font-lock] + ["Toggle rich content types" cider-repl-toggle-content-types] + ["Require REPL utils" cider-repl-require-repl-utils] + "--" + ["Browse classpath" cider-classpath] + ["Browse classpath entry" cider-open-classpath-entry] + ["Browse namespace" cider-browse-ns] + ["Browse all namespaces" cider-browse-ns-all] + ["Browse spec" cider-browse-spec] + ["Browse all specs" cider-browse-spec-all] + "--" + ["Next prompt" cider-repl-next-prompt] + ["Previous prompt" cider-repl-previous-prompt] + ["Clear output" cider-repl-clear-output] + ["Clear buffer" cider-repl-clear-buffer] + ["Trim buffer" cider-repl-trim-buffer] + ["Clear banners" cider-repl-clear-banners] + ["Clear help banner" cider-repl-clear-help-banner] + ["Kill input" cider-repl-kill-input] + "--" + ["Interrupt evaluation" cider-interrupt] + "--" + ["Connection info" cider-describe-connection] + "--" + ["Close ancillary buffers" cider-close-ancillary-buffers] + ["Quit" cider-quit] + ["Restart" cider-restart] + "--" + ["Clojure Cheatsheet" cider-cheatsheet] + "--" + ["A sip of CIDER" cider-drink-a-sip] + ["View user manual" cider-view-manual] + ["View quick reference card" cider-view-refcard] + ["Report a bug" cider-report-bug] + ["Version info" cider-version])) + map)) + +(sesman-install-menu cider-repl-mode-map) + +(defun cider-repl-wrap-fontify-function (func) + "Return a function that will call FUNC narrowed to input region." + (lambda (beg end &rest rest) + (when (and cider-repl-input-start-mark + (> end cider-repl-input-start-mark)) + (save-restriction + (narrow-to-region cider-repl-input-start-mark (point-max)) + (let ((font-lock-dont-widen t)) + (apply func (max beg cider-repl-input-start-mark) end rest)))))) + +(declare-function cider-complete-at-point "cider-completion") +(defvar cider--static-font-lock-keywords) + +(defun cider-repl-setup-paredit () + "Override the paredit-RET binding in cider-repl-mode." + (let ((oldmap (cdr (assoc 'paredit-mode minor-mode-map-alist))) + (newmap (make-sparse-keymap))) + (set-keymap-parent newmap oldmap) + (define-key newmap (kbd "RET") nil) + (make-local-variable 'minor-mode-overriding-map-alist) + (push `(paredit-mode . ,newmap) minor-mode-overriding-map-alist))) + +(define-derived-mode cider-repl-mode fundamental-mode "REPL" + "Major mode for Clojure REPL interactions. + +\\{cider-repl-mode-map}" + (clojure-mode-variables) + (clojure-font-lock-setup) + (font-lock-add-keywords nil cider--static-font-lock-keywords) + (setq-local sesman-system 'CIDER) + (setq-local font-lock-fontify-region-function + (cider-repl-wrap-fontify-function font-lock-fontify-region-function)) + (setq-local font-lock-unfontify-region-function + (cider-repl-wrap-fontify-function font-lock-unfontify-region-function)) + (set-syntax-table cider-repl-mode-syntax-table) + (cider-eldoc-setup) + ;; At the REPL, we define beginning-of-defun and end-of-defun to be + ;; the start of the previous prompt or next prompt respectively. + ;; Notice the interplay with `cider-repl-beginning-of-defun'. + (setq-local beginning-of-defun-function #'cider-repl-mode-beginning-of-defun) + (setq-local end-of-defun-function #'cider-repl-mode-end-of-defun) + (setq-local prettify-symbols-alist clojure--prettify-symbols-alist) + ;; apply dir-local variables to REPL buffers + (hack-dir-local-variables-non-file-buffer) + (when cider-repl-history-file + (condition-case nil + (cider-repl-history-load cider-repl-history-file) + (error + (message "Malformed cider-repl-history-file: %s" cider-repl-history-file))) + (add-hook 'kill-buffer-hook #'cider-repl-history-just-save t t) + (add-hook 'kill-emacs-hook #'cider-repl-history-just-save)) + (add-hook 'completion-at-point-functions #'cider-complete-at-point nil t) + (add-hook 'paredit-mode-hook (lambda () (clojure-paredit-setup cider-repl-mode-map))) + (cider-repl-setup-paredit)) + +(provide 'cider-repl) + +;;; cider-repl.el ends here diff --git a/elpa/cider-20241203.1607/cider-resolve.el b/elpa/cider-20241203.1607/cider-resolve.el new file mode 100644 index 00000000..eaa49d63 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-resolve.el @@ -0,0 +1,130 @@ +;;; cider-resolve.el --- Resolve clojure symbols according to current nREPL connection -*- lexical-binding: t; -*- + +;; Copyright © 2015-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors + +;; Author: Artur Malabarba + +;; 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 . + +;;; Commentary: + +;; The ns cache is a dict of namespaces stored in the connection buffer. This +;; file offers functions to easily get information about variables from this +;; cache, given the variable's name and the file's namespace. This +;; functionality is similar to that offered by the `cider-var-info' function +;; (and others). The difference is that all functions in this file operate +;; without contacting the server (they still rely on an active connection +;; buffer, but no messages are actually exchanged). + +;; For this reason, the functions here are well suited for very +;; performance-sentitive operations, such as font-locking or +;; indentation. Meanwhile, operations like code-jumping are better off +;; communicating with the middleware, just in the off chance that the cache is +;; outdated. + +;; Below is a typical entry on this cache dict. Note that clojure.core symbols +;; are excluded from the refers to save space. + +;; "cider.nrepl.middleware.track-state" +;; (dict "aliases" +;; (dict "cljs" "cider.nrepl.middleware.util.cljs" +;; "misc" "cider.nrepl.middleware.util.misc" +;; "set" "clojure.set") +;; "interns" (dict a +;; "assoc-state" (dict "arglists" +;; (("response" +;; (dict "as" "msg" "keys" +;; ("session"))))) +;; "filter-core" (dict "arglists" +;; (("refers"))) +;; "make-transport" (dict "arglists" +;; (((dict "as" "msg" "keys" +;; ("transport"))))) +;; "ns-as-map" (dict "arglists" +;; (("ns"))) +;; "ns-cache" (dict) +;; "relevant-meta" (dict "arglists" +;; (("var"))) +;; "update-vals" (dict "arglists" +;; (("m" "f"))) +;; "wrap-tracker" (dict "arglists" +;; (("handler")))) +;; "refers" (dict "set-descriptor!" "#'nrepl.middleware/set-descriptor!")) + +;;; Code: + +(require 'cider-client) +(require 'nrepl-dict) +(require 'cider-util) + +(defvar cider-repl-ns-cache) + +(defun cider-resolve--get-in (&rest keys) + "Return (nrepl-dict-get-in cider-repl-ns-cache KEYS)." + (when-let* ((conn (cider-current-repl))) + (with-current-buffer conn + (nrepl-dict-get-in cider-repl-ns-cache keys)))) + +(defun cider-resolve-alias (ns alias) + "Return the namespace that ALIAS refers to in namespace NS. +If it doesn't point anywhere, returns ALIAS." + (or (cider-resolve--get-in ns "aliases" alias) + alias)) + +(defconst cider-resolve--prefix-regexp "\\`\\(?:#'\\)?\\([^/]+\\)/") + +(defun cider-resolve-var (ns var) + "Return a dict of the metadata of a clojure var VAR in namespace NS. +VAR is a string. +Return nil only if VAR cannot be resolved." + (let* ((var-ns (when (string-match cider-resolve--prefix-regexp var) + (cider-resolve-alias ns (match-string 1 var)))) + (name (replace-regexp-in-string cider-resolve--prefix-regexp "" var))) + (or + (cider-resolve--get-in (or var-ns ns) "interns" name) + (unless var-ns + ;; If the var had no prefix, it might be referred. + (if-let* ((referral (cider-resolve--get-in ns "refers" name))) + (cider-resolve-var ns referral) + ;; Or it might be from core. + (unless (equal ns "clojure.core") + (cider-resolve-var "clojure.core" name))))))) + +(defun cider-resolve-core-ns () + "Return a dict of the core namespace for current connection. +This will be clojure.core or cljs.core depending on the return value of the +function `cider-repl-type'." + (when-let* ((repl (cider-current-repl))) + (with-current-buffer repl + (cider-resolve--get-in (if (eq cider-repl-type 'cljs) + "cljs.core" + "clojure.core"))))) + +(defun cider-resolve-ns-symbols (ns) + "Return a plist of all valid symbols in NS. +Each entry's value is the metadata of the var that the symbol refers to. +NS can be the namespace name, or a dict of the namespace itself." + (when-let* ((dict (if (stringp ns) + (cider-resolve--get-in ns) + ns))) + (nrepl-dbind-response dict (interns _refers aliases) + (append (cdr interns) + (nrepl-dict-flat-map (lambda (alias namespace) + (nrepl-dict-flat-map (lambda (sym meta) + (list (concat alias "/" sym) meta)) + (cider-resolve--get-in namespace "interns"))) + aliases))))) + +(provide 'cider-resolve) +;;; cider-resolve.el ends here diff --git a/elpa/cider-20241203.1607/cider-scratch.el b/elpa/cider-20241203.1607/cider-scratch.el new file mode 100644 index 00000000..07de719c --- /dev/null +++ b/elpa/cider-20241203.1607/cider-scratch.el @@ -0,0 +1,100 @@ +;;; cider-scratch.el --- *scratch* buffer for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2014-2024 Bozhidar Batsov and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Imitate Emacs's *scratch* buffer. + +;;; Code: + +(require 'cider-eval) +(require 'clojure-mode) +(require 'easymenu) + +(defcustom cider-scratch-initial-message + ";; This buffer is for Clojure experiments and evaluation.\n +;; Press C-j to evaluate the last expression.\n +;; You can also press C-u C-j to evaluate the expression and pretty-print its result.\n\n" + "The initial message displayed in new scratch buffers." + :type 'string + :group 'cider + :package-version '(cider . "0.18.0")) + +(defvar cider-clojure-interaction-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map clojure-mode-map) + (define-key map (kbd "C-j") #'cider-eval-print-last-sexp) + (define-key map [remap paredit-newline] #'cider-eval-print-last-sexp) + (define-key map [remap paredit-C-j] #'cider-eval-print-last-sexp) + (easy-menu-define cider-clojure-interaction-mode-menu map + "Menu for Clojure Interaction mode" + '("Clojure Interaction" + (["Eval and print last sexp" #'cider-eval-print-last-sexp] + "--" + ["Reset" #'cider-scratch-reset]))) + map)) + +(defconst cider-scratch-buffer-name "*cider-scratch*") + +;;;###autoload +(defun cider-scratch () + "Go to the scratch buffer named `cider-scratch-buffer-name'." + (interactive) + (pop-to-buffer (cider-scratch-find-or-create-buffer))) + +(defun cider-scratch-find-or-create-buffer () + "Find or create the scratch buffer." + (or (get-buffer cider-scratch-buffer-name) + (cider-scratch--create-buffer))) + +(define-derived-mode cider-clojure-interaction-mode clojure-mode "Clojure Interaction" + "Major mode for typing and evaluating Clojure forms. +Like `clojure-mode' except that \\[cider-eval-print-last-sexp] evals the Lisp expression +before point, and prints its value into the buffer, advancing point. + +\\{cider-clojure-interaction-mode-map}" + (setq-local sesman-system 'CIDER)) + +(defun cider-scratch--insert-welcome-message () + "Insert the welcome message for the scratch buffer." + (insert cider-scratch-initial-message)) + +(defun cider-scratch--create-buffer () + "Create a new scratch buffer." + (with-current-buffer (get-buffer-create cider-scratch-buffer-name) + (cider-clojure-interaction-mode) + (cider-scratch--insert-welcome-message) + (current-buffer))) + +(defun cider-scratch-reset () + "Reset the current scratch buffer." + (interactive) + (erase-buffer) + (cider-scratch--insert-welcome-message)) + +(provide 'cider-scratch) + +;;; cider-scratch.el ends here diff --git a/elpa/cider-20241203.1607/cider-selector.el b/elpa/cider-20241203.1607/cider-selector.el new file mode 100644 index 00000000..ec4a6503 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-selector.el @@ -0,0 +1,177 @@ +;;; cider-selector.el --- Buffer selection command inspired by SLIME's selector -*- lexical-binding: t -*- + +;; Copyright © 2012-2024 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Buffer selection command inspired by SLIME's selector. + +;;; Code: + +(require 'cider-client) +(require 'cider-eval) +(require 'cider-scratch) +(require 'cider-profile) + +(defconst cider-selector-help-buffer "*CIDER Selector Help*" + "The name of the selector's help buffer.") + +(defvar cider-selector-methods nil + "List of buffer-selection methods for the `cider-selector' command. +Each element is a list (KEY DESCRIPTION FUNCTION). +DESCRIPTION is a one-line description of what the key selects.") + +(defvar cider-selector-other-window nil + "If non-nil use `switch-to-buffer-other-window'. +Not meant to be set by users. It's used internally +by `cider-selector'.") + +(defun cider-selector--recently-visited-buffer (modes &optional consider-visible-p) + "Return the most recently visited buffer, deriving its `major-mode' from MODES. +MODES may be a symbol for a single mode, or a list of mode symbols. +CONSIDER-VISIBLE-P will allow handling of visible windows as well. +First pass only considers buffers that are not already visible. +Second pass will attempt one of visible ones for scenarios where the window +is visible, but not focused." + (cl-loop for buffer in (buffer-list) + when (and (with-current-buffer buffer + (apply #'derived-mode-p (if (listp modes) + modes + (list modes)))) + ;; names starting with space are considered hidden by Emacs + (not (string-match-p "^ " (buffer-name buffer))) + (or consider-visible-p + (null (get-buffer-window buffer 'visible)))) + return buffer + finally (if consider-visible-p + (error "Can't find unshown buffer in %S" modes) + (cider-selector--recently-visited-buffer modes t)))) + +;;;###autoload +(defun cider-selector (&optional other-window) + "Select a new buffer by type, indicated by a single character. +The user is prompted for a single character indicating the method by +which to choose a new buffer. The `?' character describes the +available methods. OTHER-WINDOW provides an optional target. +See `def-cider-selector-method' for defining new methods." + (interactive) + (message "Select [%s]: " + (apply #'string (mapcar #'car cider-selector-methods))) + (let* ((cider-selector-other-window other-window) + (ch (save-window-excursion + (select-window (minibuffer-window)) + (read-char))) + (method (cl-find ch cider-selector-methods :key #'car))) + (cond (method + (funcall (cl-caddr method))) + (t + (message "No method for character: ?\\%c" ch) + (ding) + (sleep-for 1) + (discard-input) + (cider-selector))))) + +(defmacro def-cider-selector-method (key description &rest body) + "Define a new `cider-select' buffer selection method. +KEY is the key the user will enter to choose this method. + +DESCRIPTION is a one-line sentence describing how the method +selects a buffer. + +BODY is a series of forms which are evaluated when the selector +is chosen. The returned buffer is selected with +`switch-to-buffer'." + (let ((method `(lambda () + (let ((buffer (progn ,@body))) + (cond ((not (and buffer (get-buffer buffer))) + (message "No such buffer: %S" buffer) + (ding)) + ((get-buffer-window buffer) + (select-window (get-buffer-window buffer))) + (cider-selector-other-window + (switch-to-buffer-other-window buffer)) + (t + (switch-to-buffer buffer))))))) + `(setq cider-selector-methods + (cl-sort (cons (list ,key ,description ,method) + (cl-remove ,key cider-selector-methods :key #'car)) + #'< :key #'car)))) + +(def-cider-selector-method ?? "Selector help buffer." + (ignore-errors (kill-buffer cider-selector-help-buffer)) + (with-current-buffer (get-buffer-create cider-selector-help-buffer) + (insert "CIDER Selector Methods:\n\n") + (cl-loop for (key line nil) in cider-selector-methods + do (insert (format "%c:\t%s\n" key line))) + (goto-char (point-min)) + (help-mode) + (display-buffer (current-buffer) t)) + (cider-selector) + (current-buffer)) + +(cl-pushnew (list ?4 "Select in other window" (lambda () (cider-selector t))) + cider-selector-methods :key #'car) + +(def-cider-selector-method ?c + "Most recently visited clojure-mode buffer." + (cider-selector--recently-visited-buffer '(clojure-mode clojure-ts-mode))) + +(def-cider-selector-method ?e + "Most recently visited emacs-lisp-mode buffer." + (cider-selector--recently-visited-buffer 'emacs-lisp-mode)) + +(def-cider-selector-method ?q "Abort." + (top-level)) + +(def-cider-selector-method ?r + "Current REPL buffer or as a fallback, the most recently +visited cider-repl-mode buffer." + (or (cider-current-repl) + (cider-selector--recently-visited-buffer 'cider-repl-mode))) + +(def-cider-selector-method ?m + "Current connection's *nrepl-messages* buffer." + (nrepl-messages-buffer (cider-current-repl))) + +(def-cider-selector-method ?x + "*cider-error* buffer." + cider-error-buffer) + +(def-cider-selector-method ?p + "*cider-profile* buffer." + cider-profile-buffer) + +(def-cider-selector-method ?d + "*cider-doc* buffer." + cider-doc-buffer) + +(def-cider-selector-method ?s + "*cider-scratch* buffer." + (cider-scratch-find-or-create-buffer)) + +(provide 'cider-selector) + +;;; cider-selector.el ends here diff --git a/elpa/cider-20241203.1607/cider-stacktrace.el b/elpa/cider-20241203.1607/cider-stacktrace.el new file mode 100644 index 00000000..93019389 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-stacktrace.el @@ -0,0 +1,980 @@ +;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*- + +;; Copyright © 2014-2024 Jeff Valk, Bozhidar Batsov and CIDER contributors + +;; Author: Jeff Valk + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Stacktrace filtering and stack frame source navigation + +;;; Code: + +(require 'button) +(require 'cl-lib) +(require 'easymenu) +(require 'map) +(require 'seq) +(require 'subr-x) + +(require 'cider-common) +(require 'cider-client) +(require 'cider-popup) +(require 'cider-util) + +;; Variables + +(defgroup cider-stacktrace nil + "Stacktrace filtering and navigation." + :prefix "cider-stacktrace-" + :group 'cider) + +(defcustom cider-stacktrace-fill-column t + "Fill column for error messages in stacktrace display. +If nil, messages will not be wrapped. If truthy but non-numeric, +`fill-column' will be used." + :type 'list + :package-version '(cider . "0.7.0")) + +(defcustom cider-stacktrace-default-filters '(tooling dup) + "Frame types to omit from initial stacktrace display." + :type 'list + :package-version '(cider . "0.6.0")) + +(defcustom cider-stacktrace-navigate-to-other-window t + "If truthy, navigating from a stack frame will use other window. +Pick nil if you prefer the same window as *cider-error*." + :type 'boolean + :package-version '(cider . "1.8.0")) + +(make-obsolete 'cider-stacktrace-print-length 'cider-stacktrace-print-options "0.20") +(make-obsolete 'cider-stacktrace-print-level 'cider-stacktrace-print-options "0.20") +(make-obsolete-variable 'cider-stacktrace-print-options 'cider-print-options "0.21") + +(defvar cider-stacktrace-detail-max 2 + "The maximum detail level for causes.") + +(defvar-local cider-stacktrace-hidden-frame-count 0) +(defvar-local cider-stacktrace-filters nil) +(defvar-local cider-stacktrace-cause-visibility nil) +(defvar-local cider-stacktrace-positive-filters nil) + +(defconst cider-error-buffer "*cider-error*") + +(make-obsolete 'cider-visit-error-buffer 'cider-selector "0.18") + +(defcustom cider-stacktrace-suppressed-errors '() + "Errors that won't make the stacktrace buffer 'pop-over' your active window. +The error types are represented as strings." + :type 'list + :package-version '(cider . "0.12.0")) + +;; Faces + +(defface cider-stacktrace-error-class-face + '((t (:inherit font-lock-warning-face))) + "Face for exception class names." + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-error-message-face + '((t (:inherit font-lock-doc-face))) + "Face for exception messages." + :package-version '(cider . "0.7.0")) + +(defface cider-stacktrace-filter-active-face + '((t (:inherit button :underline t :weight normal))) + "Face for filter buttons representing frames currently visible." + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-filter-inactive-face + '((t (:inherit button :underline nil :weight normal))) + "Face for filter buttons representing frames currently filtered out." + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-face + '((t (:inherit default))) + "Face for stack frame text." + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-ns-face + '((t (:inherit font-lock-comment-face))) + "Face for stack frame namespace name." + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-fn-face + '((t (:inherit default :weight bold))) + "Face for stack frame function name." + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-promoted-button-face + '((((type graphic)) + :box (:line-width 3 :style released-button) + :inherit error) + (t :inverse-video t)) + "A button with this face represents a promoted (non-suppressed) error type." + :package-version '(cider . "0.12.0")) + +(defface cider-stacktrace-suppressed-button-face + '((((type graphic)) + :box (:line-width 3 :style pressed-button) + :inherit widget-inactive) + (t :inverse-video t)) + "A button with this face represents a suppressed error type." + :package-version '(cider . "0.12.0")) + +;; Colors & Theme Support + +(defvar cider-stacktrace-frames-background-color + (cider-scale-background-color) + "Background color for stacktrace frames.") + +(advice-add 'enable-theme :after #'cider--stacktrace-adapt-to-theme) +(advice-add 'disable-theme :after #'cider--stacktrace-adapt-to-theme) +(defun cider--stacktrace-adapt-to-theme (&rest _) + "When theme is changed, update `cider-stacktrace-frames-background-color'." + (setq cider-stacktrace-frames-background-color + (cider-scale-background-color))) + + +;; Mode & key bindings + +(defvar cider-stacktrace-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "M-p") #'cider-stacktrace-previous-cause) + (define-key map (kbd "M-n") #'cider-stacktrace-next-cause) + (define-key map (kbd "M-.") #'cider-stacktrace-jump) + (define-key map "q" #'cider-popup-buffer-quit-function) + (define-key map "j" #'cider-stacktrace-toggle-java) + (define-key map "c" #'cider-stacktrace-toggle-clj) + (define-key map "r" #'cider-stacktrace-toggle-repl) + (define-key map "t" #'cider-stacktrace-toggle-tooling) + (define-key map "d" #'cider-stacktrace-toggle-duplicates) + (define-key map "p" #'cider-stacktrace-show-only-project) + (define-key map "a" #'cider-stacktrace-toggle-all) + (define-key map "1" #'cider-stacktrace-cycle-cause-1) + (define-key map "2" #'cider-stacktrace-cycle-cause-2) + (define-key map "3" #'cider-stacktrace-cycle-cause-3) + (define-key map "4" #'cider-stacktrace-cycle-cause-4) + (define-key map "5" #'cider-stacktrace-cycle-cause-5) + (define-key map "0" #'cider-stacktrace-cycle-all-causes) + (define-key map (kbd "TAB") #'cider-stacktrace-cycle-current-cause) + (define-key map [backtab] #'cider-stacktrace-cycle-all-causes) + (easy-menu-define cider-stacktrace-mode-menu map + "Menu for CIDER's stacktrace mode" + '("Stacktrace" + ["Previous cause" cider-stacktrace-previous-cause] + ["Next cause" cider-stacktrace-next-cause] + "--" + ["Jump to frame source" cider-stacktrace-jump] + "--" + ["Cycle current cause detail" cider-stacktrace-cycle-current-cause] + ["Cycle cause #1 detail" cider-stacktrace-cycle-cause-1] + ["Cycle cause #2 detail" cider-stacktrace-cycle-cause-2] + ["Cycle cause #3 detail" cider-stacktrace-cycle-cause-3] + ["Cycle cause #4 detail" cider-stacktrace-cycle-cause-4] + ["Cycle cause #5 detail" cider-stacktrace-cycle-cause-5] + ["Cycle all cause detail" cider-stacktrace-cycle-all-causes] + "--" + ["Show/hide Java frames" cider-stacktrace-toggle-java] + ["Show/hide Clojure frames" cider-stacktrace-toggle-clj] + ["Show/hide REPL frames" cider-stacktrace-toggle-repl] + ["Show/hide tooling frames" cider-stacktrace-toggle-tooling] + ["Show/hide duplicate frames" cider-stacktrace-toggle-duplicates] + ["Toggle only project frames" cider-stacktrace-show-only-project] + ["Show/hide all frames" cider-stacktrace-toggle-all])) + map)) + +(define-derived-mode cider-stacktrace-mode special-mode "Stacktrace" + "Major mode for filtering and navigating CIDER stacktraces. + +\\{cider-stacktrace-mode-map}" + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t)) + (setq-local sesman-system 'CIDER) + (setq-local electric-indent-chars nil) + (setq-local cider-stacktrace-hidden-frame-count 0) + (setq-local cider-stacktrace-filters cider-stacktrace-default-filters) + (setq-local cider-stacktrace-cause-visibility (make-vector 10 0)) + (buffer-disable-undo)) + + +;; Stacktrace filtering + +(defvar cider-stacktrace--all-negative-filters + '(clj tooling dup java repl) + "Filters that remove stackframes.") + +(defvar cider-stacktrace--all-positive-filters + '(project all) + "Filters that ensure stackframes are shown.") + +(defun cider-stacktrace--face-for-filter (filter neg-filters pos-filters) + "Return whether we should mark the FILTER is active or not. + +NEG-FILTERS and POS-FILTERS are lists of filters to check FILTER's type. + +NEG-FILTERS dictate which frames should be hidden while POS-FILTERS can +override this and ensure that those frames are shown." + (cond ((member filter cider-stacktrace--all-negative-filters) + (if (member filter neg-filters) + 'cider-stacktrace-filter-active-face + 'cider-stacktrace-filter-inactive-face)) + ((member filter cider-stacktrace--all-positive-filters) + (if (member filter pos-filters) + 'cider-stacktrace-filter-active-face + 'cider-stacktrace-filter-inactive-face)))) + +(defun cider-stacktrace-indicate-filters (filters pos-filters) + "Update enabled state of filter buttons. + +Find buttons with a 'filter property; if filter is a member of FILTERS, or +if filter is nil ('show all') and the argument list is non-nil, fontify the +button as disabled. Upon finding text with a 'hidden-count property, stop +searching and update the hidden count text. POS-FILTERS is the list of +positive filters to always include." + (with-current-buffer cider-error-buffer + (save-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t)) + ;; Toggle buttons + (while (not (or (get-text-property (point) 'hidden-count) (eobp))) + (let ((button (button-at (point)))) + (when button + (let* ((filter (button-get button 'filter)) + (face (cider-stacktrace--face-for-filter filter + filters + pos-filters))) + (button-put button 'face face))) + (goto-char (or (next-property-change (point)) + (point-max))))) + ;; Update hidden count + (when (and (get-text-property (point) 'hidden-count) + (re-search-forward "[0-9]+" (line-end-position) t)) + (replace-match + (number-to-string cider-stacktrace-hidden-frame-count))))))) + +(defun cider-stacktrace-frame-p () + "Indicate if the text at point is a stack frame." + (get-text-property (point) 'cider-stacktrace-frame)) + +(defun cider-stacktrace-collapsed-p () + "Indicate if the stackframe was collapsed." + (get-text-property (point) 'collapsed)) + +(defun cider-stacktrace--should-hide-p (neg-filters pos-filters flags) + "Decide whether a stackframe should be hidden or not. +NEG-FILTERS dictate which frames should be hidden while POS-FILTERS can +override this and ensure that those frames are shown. +Argument FLAGS are the flags set on the stackframe, ie: clj dup, etc." + (let ((neg (seq-intersection neg-filters flags)) + (pos (seq-intersection pos-filters flags)) + (all (memq 'all pos-filters))) + (cond (all nil) ;; if all filter is on then we should not hide + ((and pos neg) nil) ;; if hidden and "resurrected" we should not hide + (pos nil) + (neg t) + (t nil)))) + +(defun cider-stacktrace--apply-filters (neg-filters pos-filters) + "Set visibility on stack frames. +Should be called by `cider-stacktrace-apply-filters' which has the logic of +how to interpret the combinations of the positive and negative filters. +For instance, the presence of the positive filter `project' requires all of +the other negative filters to be applied so that only project frames are +shown. NEG-FILTERS are the tags that should be hidden. POS-FILTERS are +the tags that must be shown." + (with-current-buffer cider-error-buffer + (save-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t) + (hidden 0)) + (while (not (eobp)) + (when (and (cider-stacktrace-frame-p) + (not (cider-stacktrace-collapsed-p))) + (let* ((flags (get-text-property (point) 'flags)) + (hide (cider-stacktrace--should-hide-p neg-filters + pos-filters + flags))) + (when hide (cl-incf hidden)) + (put-text-property (point) (line-beginning-position 2) + 'invisible hide))) + (forward-line 1)) + (setq cider-stacktrace-hidden-frame-count hidden))) + (cider-stacktrace-indicate-filters neg-filters pos-filters))) + +(defun cider-stacktrace-apply-filters (filters) + "Takes a single list of filters and applies them. +Update `cider-stacktrace-hidden-frame-count' and indicate +filters applied. Currently collapsed stacktraces are ignored, and do not +contribute to the hidden count. FILTERS is the list of filters to be +applied, positive and negative all together. This function defines how +those choices interact and separates them into positive and negative +filters for the resulting machinery." + (let ((neg-filters (seq-intersection filters cider-stacktrace--all-negative-filters)) + (pos-filters (seq-intersection filters cider-stacktrace--all-positive-filters))) + ;; project and all are mutually exclusive. when both are present we check to + ;; see the most recent one (as cons onto the list would put it) and use that + ;; interaction. + (cond + ((memq 'all (memq 'project pos-filters)) ;; project is most recent + (cider-stacktrace--apply-filters cider-stacktrace--all-negative-filters '(project))) + ((memq 'project (memq 'all pos-filters)) ;; all is most recent + (cider-stacktrace--apply-filters nil '(all))) + ((memq 'all pos-filters) (cider-stacktrace--apply-filters nil '(all))) + ((memq 'project pos-filters) (cider-stacktrace--apply-filters cider-stacktrace--all-negative-filters + pos-filters)) + (t (cider-stacktrace--apply-filters neg-filters pos-filters))))) + +(defun cider-stacktrace-apply-cause-visibility () + "Apply `cider-stacktrace-cause-visibility' to causes and reapply filters." + (with-current-buffer cider-error-buffer + (save-excursion + (goto-char (point-min)) + (cl-flet ((next-detail (end) + (when-let* ((pos (next-single-property-change (point) 'detail))) + (when (< pos end) + (goto-char pos))))) + (let ((inhibit-read-only t)) + ;; For each cause... + (while (cider-stacktrace-next-cause) + (let* ((num (get-text-property (point) 'cause)) + (level (elt cider-stacktrace-cause-visibility num)) + (cause-end (cadr (cider-property-bounds 'cause)))) + ;; For each detail level within the cause, set visibility. + (while (next-detail cause-end) + (let* ((detail (get-text-property (point) 'detail)) + (detail-end (cadr (cider-property-bounds 'detail))) + (hide (if (> detail level) t nil))) + (add-text-properties (point) detail-end + (list 'invisible hide + 'collapsed hide)))))))) + (cider-stacktrace-apply-filters cider-stacktrace-filters)))) + +;;; Internal/Middleware error suppression + +(defun cider-stacktrace-some-suppressed-errors-p (error-types) + "Return intersection of ERROR-TYPES and CIDER-STACKTRACE-SUPPRESSED-ERRORS. +I.e, Return non-nil if the seq ERROR-TYPES shares any elements with +`cider-stacktrace-suppressed-errors'. This means that even a +'well-behaved' (ie, promoted) error type will be 'guilty by association' if +grouped with a suppressed error type." + (seq-intersection error-types cider-stacktrace-suppressed-errors)) + +(defun cider-stacktrace-suppress-error (error-type) + "Destructively add ERROR-TYPE to the `cider-stacktrace-suppressed-errors' set." + (setq cider-stacktrace-suppressed-errors + (cl-adjoin error-type cider-stacktrace-suppressed-errors :test 'equal))) + +(defun cider-stacktrace-promote-error (error-type) + "Destructively remove ERROR-TYPE from `cider-stacktrace-suppressed-errors'." + (setq cider-stacktrace-suppressed-errors + (remove error-type cider-stacktrace-suppressed-errors))) + +(defun cider-stacktrace-suppressed-error-p (error-type) + "Return non-nil if ERROR-TYPE is in `cider-stacktrace-suppressed-errors'." + (member error-type cider-stacktrace-suppressed-errors)) + +;; Interactive functions + +(defun cider-stacktrace-previous-cause () + "Move point to the previous exception cause, if one exists." + (interactive) + (with-current-buffer cider-error-buffer + (when-let* ((pos (previous-single-property-change (point) 'cause))) + (goto-char pos)))) + +(defun cider-stacktrace-next-cause () + "Move point to the next exception cause, if one exists." + (interactive) + (with-current-buffer cider-error-buffer + (when-let* ((pos (next-single-property-change (point) 'cause))) + (goto-char pos)))) + +(defun cider-stacktrace-cycle-cause (num &optional level) + "Update element NUM of `cider-stacktrace-cause-visibility'. +If LEVEL is specified, it is used, otherwise its current value is incremented. +When it reaches 3, it wraps to 0." + (let ((level (or level (1+ (elt cider-stacktrace-cause-visibility num))))) + (aset cider-stacktrace-cause-visibility num (mod level 3)) + (cider-stacktrace-apply-cause-visibility))) + +(defun cider-stacktrace-cycle-all-causes () + "Cycle the visibility of all exception causes." + (interactive) + (with-current-buffer cider-error-buffer + (save-excursion + ;; Find nearest cause. + (unless (get-text-property (point) 'cause) + (cider-stacktrace-next-cause) + (unless (get-text-property (point) 'cause) + (cider-stacktrace-previous-cause))) + ;; Cycle its level, and apply that to all causes. + (let* ((num (get-text-property (point) 'cause)) + (level (1+ (elt cider-stacktrace-cause-visibility num)))) + (setq-local cider-stacktrace-cause-visibility + (make-vector 10 (mod level 3))) + (cider-stacktrace-apply-cause-visibility))))) + +(defun cider-stacktrace-cycle-current-cause () + "Cycle the visibility of current exception at point, if any." + (interactive) + (with-current-buffer cider-error-buffer + (when-let* ((num (get-text-property (point) 'cause))) + (cider-stacktrace-cycle-cause num)))) + +(defun cider-stacktrace-cycle-cause-1 () + "Cycle the visibility of exception cause #1." + (interactive) + (cider-stacktrace-cycle-cause 1)) + +(defun cider-stacktrace-cycle-cause-2 () + "Cycle the visibility of exception cause #2." + (interactive) + (cider-stacktrace-cycle-cause 2)) + +(defun cider-stacktrace-cycle-cause-3 () + "Cycle the visibility of exception cause #3." + (interactive) + (cider-stacktrace-cycle-cause 3)) + +(defun cider-stacktrace-cycle-cause-4 () + "Cycle the visibility of exception cause #4." + (interactive) + (cider-stacktrace-cycle-cause 4)) + +(defun cider-stacktrace-cycle-cause-5 () + "Cycle the visibility of exception cause #5." + (interactive) + (cider-stacktrace-cycle-cause 5)) + +(defun cider-stacktrace-toggle (flag) + "Update `cider-stacktrace-filters' to add or remove FLAG, and apply filters." + (cider-stacktrace-apply-filters + (setq cider-stacktrace-filters + (if (memq flag cider-stacktrace-filters) + (remq flag cider-stacktrace-filters) + (cons flag cider-stacktrace-filters))))) + +(defun cider-stacktrace-toggle-all () + "Toggle `all' in filter list." + (interactive) + (cider-stacktrace-toggle 'all)) + +(defun cider-stacktrace-show-only-project () + "Display only the stackframes from the project." + (interactive) + (cider-stacktrace-toggle 'project)) + +(defun cider-stacktrace-toggle-java () + "Toggle display of Java stack frames." + (interactive) + (cider-stacktrace-toggle 'java)) + +(defun cider-stacktrace-toggle-clj () + "Toggle display of Clojure stack frames." + (interactive) + (cider-stacktrace-toggle 'clj)) + +(defun cider-stacktrace-toggle-repl () + "Toggle display of REPL stack frames." + (interactive) + (cider-stacktrace-toggle 'repl)) + +(defun cider-stacktrace-toggle-tooling () + "Toggle display of tooling stack frames. + +These include: + + * Clojure compiler and runtime internals + * may be `.clj' or `.java' files. + * nREPL internals + * CIDER internals." + (interactive) + (cider-stacktrace-toggle 'tooling)) + +(defun cider-stacktrace-toggle-duplicates () + "Toggle display of stack frames that are duplicates of their descendents." + (interactive) + (cider-stacktrace-toggle 'dup)) + +;; Text button functions + +(defun cider-stacktrace-filter (button) + "Apply filter(s) indicated by the BUTTON." + (with-temp-message "Filters may also be toggled with the keyboard." + (let ((flag (button-get button 'filter))) + (cond ((member flag cider-stacktrace--all-negative-filters) + (cider-stacktrace-toggle flag)) + ((member flag cider-stacktrace--all-positive-filters) + (cider-stacktrace-show-only-project)) + (t (cider-stacktrace-toggle-all)))) + (sit-for 5))) + +(defun cider-stacktrace-toggle-suppression (button) + "Toggle stacktrace pop-over/pop-under behavior for the `error-type' in BUTTON. +Achieved by destructively manipulating `cider-stacktrace-suppressed-errors'." + (with-current-buffer cider-error-buffer + (let ((inhibit-read-only t) + (suppressed (button-get button 'suppressed)) + (error-type (button-get button 'error-type))) + (if suppressed + (progn + (cider-stacktrace-promote-error error-type) + (button-put button 'face 'cider-stacktrace-promoted-button-face) + (button-put button 'help-echo "Click to suppress these stacktraces.")) + (cider-stacktrace-suppress-error error-type) + (button-put button 'face 'cider-stacktrace-suppressed-button-face) + (button-put button 'help-echo "Click to promote these stacktraces.")) + (button-put button 'suppressed (not suppressed))))) + +(defun cider-stacktrace-navigate (button) + "Navigate to the stack frame source represented by the BUTTON." + (let* ((var (button-get button 'var)) + (class (button-get button 'class)) + (method (button-get button 'method)) + (info (or (and var (cider-var-info var)) + (and class method (cider-member-info class method)) + (nrepl-dict))) + ;; Stacktrace returns more accurate line numbers, but if the function's + ;; line was unreliable, then so is the stacktrace by the same amount. + ;; Set `line-shift' to the number of lines from the beginning of defn. + (line-shift (- (or (button-get button 'line) 0) + (or (nrepl-dict-get info "line") 1))) + (file (or + (nrepl-dict-get info "file") + (button-get button 'file))) + ;; give priority to `info` files as `info` returns full paths. + (info (nrepl-dict-put info "file" file))) + (cider--jump-to-loc-from-info info cider-stacktrace-navigate-to-other-window) + (forward-line line-shift) + (back-to-indentation))) + +(declare-function cider-find-var "cider-find") + +(defun cider-stacktrace-jump (&optional arg) + "Find definition for stack frame at point, if available. +The prefix ARG and `cider-prompt-for-symbol' decide whether to +prompt and whether to use a new window. Similar to `cider-find-var'." + (interactive "P") + (let ((button (button-at (point)))) + (if (and button (button-get button 'line)) + (cider-stacktrace-navigate button) + (cider-find-var arg)))) + + +;; Rendering +(defvar cider-use-tooltips) +(defun cider-stacktrace-tooltip (tooltip) + "Return TOOLTIP if `cider-use-tooltips' is set to true, nil otherwise." + (when cider-use-tooltips tooltip)) + +(defun cider-stacktrace-emit-indented (text &optional indent fill fontify) + "Insert TEXT, and optionally FILL and FONTIFY as clojure the entire block. +INDENT is a string to insert before each line. When INDENT is nil, first +line is not indented and INDENT defaults to a white-spaced string with +length given by `current-column'." + (let ((text (if fontify + (cider-font-lock-as-clojure text) + text)) + (do-first indent) + (indent (or indent (make-string (current-column) ? ))) + (beg (point))) + (insert text) + (goto-char beg) + (when do-first + (insert indent)) + (forward-line) + (while (not (eobp)) + (insert indent) + (forward-line)) + (when (and fill cider-stacktrace-fill-column) + (when (and (numberp cider-stacktrace-fill-column)) + (setq-local fill-column cider-stacktrace-fill-column)) + (setq-local fill-prefix indent) + (fill-region beg (point))))) + +(defun cider-stacktrace-render-filters (buffer special-filters filters) + "Emit into BUFFER toggle buttons for each of the FILTERS. +SPECIAL-FILTERS are filters that show stack certain stack frames, hiding +others." + (with-current-buffer buffer + (insert " Show: ") + (dolist (filter special-filters) + (insert-text-button (car filter) + 'filter (cadr filter) + 'follow-link t + 'action #'cider-stacktrace-filter + 'help-echo (cider-stacktrace-tooltip + (format "Toggle %s stack frames" + (car filter)))) + (insert " ")) + (insert "\n") + (insert " Hide: ") + (dolist (filter filters) + (insert-text-button (car filter) + 'filter (cadr filter) + 'follow-link t + 'action #'cider-stacktrace-filter + 'help-echo (cider-stacktrace-tooltip + (format "Toggle %s stack frames" + (car filter)))) + (insert " ")) + + (let ((hidden "(0 frames hidden)")) + (put-text-property 0 (length hidden) 'hidden-count t hidden) + (insert " " hidden "\n")))) + +(defun cider-stacktrace-render-suppression-toggle (buffer error-types) + "Emit toggle buttons for each of the ERROR-TYPES leading this stacktrace BUFFER." + (with-current-buffer buffer + (when error-types + (insert " This is a CIDER middleware error. + It may be a due to a bug, or perhaps simply to bad user input. + If you believe it's a bug, please submit an issue report via `") + (insert-text-button "M-x cider-report-bug" + 'follow-link t + 'action (lambda (_button) (cider-report-bug)) + 'help-echo (cider-stacktrace-tooltip + "Report bug to the CIDER team.")) + (insert "`.\n\n") + (insert "\ + If these stacktraces are occurring frequently, consider using the + button(s) below to suppress these types of errors for the duration of + your current CIDER session. The stacktrace buffer will still be + generated, but it will \"pop under\" your current buffer instead of + \"popping over\". The button toggles this behavior.\n\n ") + (dolist (error-type error-types) + (let ((suppressed (cider-stacktrace-suppressed-error-p error-type))) + (insert-text-button (format "%s %s" (if suppressed "Promote" "Suppress") error-type) + 'follow-link t + 'error-type error-type + 'action #'cider-stacktrace-toggle-suppression + 'suppressed suppressed + 'face (if suppressed + 'cider-stacktrace-suppressed-button-face + 'cider-stacktrace-promoted-button-face) + 'help-echo (cider-stacktrace-tooltip + (format "Click to %s these stacktraces." + (if suppressed "promote" "suppress"))))) + (insert " "))))) + +(defun cider-stacktrace-render-frame (buffer frame) + "Emit into BUFFER function call site info for the stack FRAME. +This associates text properties to enable filtering and source navigation." + (with-current-buffer buffer + (if (null frame) ;; Probably caused by OmitStackTraceInFastThrow + (let ((url "https://docs.cider.mx/cider/troubleshooting.html#empty-java-stacktraces")) + (insert " No stacktrace available!\n Please see ") + (insert-text-button url + 'url url + 'follow-link t + 'action (lambda (x) (browse-url (button-get x 'url))))) + (nrepl-dbind-response frame (file line flags class method name var ns fn) + (when (or class file fn method ns name) + (let ((flags (mapcar #'intern flags))) ; strings -> symbols + (insert-text-button (format "%26s:%5d %s/%s" + (if (member 'repl flags) "REPL" file) (or line -1) + (if (member 'clj flags) ns class) + (if (member 'clj flags) fn method)) + 'var var 'class class 'method method + 'name name 'file file 'line line + 'flags flags 'follow-link t + 'action #'cider-stacktrace-navigate + 'help-echo (cider-stacktrace-tooltip + "View source at this location") + 'font-lock-face 'cider-stacktrace-face + 'type 'cider-plain-button) + (save-excursion + (let ((p4 (point)) + (p1 (search-backward " ")) + (p2 (search-forward "/")) + (p3 (search-forward-regexp "[^/$]+"))) + (put-text-property p1 p4 'font-lock-face 'cider-stacktrace-ns-face) + (put-text-property p2 p3 'font-lock-face 'cider-stacktrace-fn-face) + (put-text-property (line-beginning-position) (line-end-position) + 'cider-stacktrace-frame t))) + (insert "\n"))))))) + +(defun cider-stacktrace-render-compile-error (buffer cause) + "Emit into BUFFER the compile error CAUSE, and enable jumping to it." + (with-current-buffer buffer + (nrepl-dbind-response cause (file path line column) + (let ((indent " ") + (message-face 'cider-stacktrace-error-message-face)) + (insert indent) + (insert (propertize "Error compiling " 'font-lock-face message-face)) + (insert-text-button path 'compile-error t + 'file file 'line line 'column column 'follow-link t + 'action (lambda (_button) + (cider-jump-to (cider-find-file file) + (cons line column))) + 'help-echo (cider-stacktrace-tooltip + "Jump to the line that caused the error")) + (insert (propertize (format " at (%d:%d)" line column) + 'font-lock-face message-face)))))) + +(defun cider-stacktrace--toggle-visibility (id) + "Toggle visibility of the region with ID invisibility prop. +ID can also be a button, in which case button's property :id is used +instead. This function can be used directly in button actions." + (let ((id (if (or (numberp id) (symbolp id)) + ;; There is no proper way to identify buttons. Assuming that + ;; id's can be either numbers or symbols. + id + (button-get id :id)))) + (if (and (consp buffer-invisibility-spec) + (assoc id buffer-invisibility-spec)) + (remove-from-invisibility-spec (cons id t)) + (add-to-invisibility-spec (cons id t))))) + +(defun cider-stacktrace--insert-named-group (indent name &rest vals) + "Insert named group with the ability to toggle visibility. +NAME is a string naming the group. VALS are strings to be inserted after +the NAME. The whole group is prefixed by string INDENT." + (let* ((str (and vals (replace-regexp-in-string "\n+\\'" "" (apply #'concat vals)))) + (id (and str + (string-match "\n" str) + (cl-gensym name)))) + (insert indent) + (if id + (let* ((beg-link (string-match "[^ :]" name)) + (end-link (string-match "[ :]" name (1+ beg-link)))) + (insert (substring name 0 beg-link)) + (insert-text-button (substring name beg-link end-link) + :id id + 'face '((:weight bold) (:underline t)) + 'follow-link t + 'help-echo "Toggle visibility" + 'action #'cider-stacktrace--toggle-visibility) + (insert (substring name end-link))) + (insert (propertize name 'face '((:weight bold))))) + (let ((pos (point))) + (when str + (cider-stacktrace-emit-indented (concat str "\n") nil nil t) + (when id + (remove-from-invisibility-spec (cons id t)) + (let ((hide-beg (save-excursion (goto-char pos) (point-at-eol))) + (hide-end (1- (point-at-bol)))) + (overlay-put (make-overlay hide-beg hide-end) 'invisible id))))))) + +(defun cider-stacktrace--emit-spec-problems (spec-data indent) + "Emit SPEC-DATA indented with INDENT." + (nrepl-dbind-response spec-data (spec value problems) + (insert "\n") + (cider-stacktrace--insert-named-group indent " Spec: " spec) + (cider-stacktrace--insert-named-group indent " Value: " value) + (insert "\n") + (cider-stacktrace--insert-named-group indent "Problems: \n") + (let ((indent2 (concat indent " "))) + (dolist (prob problems) + (nrepl-dbind-response prob (in val predicate reason spec at extra) + (insert "\n") + (when (not (string= val value)) + (cider-stacktrace--insert-named-group indent2 " val: " val)) + (when in + (cider-stacktrace--insert-named-group indent2 " in: " in)) + (cider-stacktrace--insert-named-group indent2 "failed: " predicate) + (when spec + (cider-stacktrace--insert-named-group indent2 " spec: " spec)) + (when at + (cider-stacktrace--insert-named-group indent2 " at: " at)) + (when reason + (cider-stacktrace--insert-named-group indent2 "reason: " reason)) + (when extra + (cider-stacktrace--insert-named-group indent2 "extras: \n") + (cider-stacktrace-emit-indented extra (concat indent2 " ") nil t))))))) + +(declare-function cider-inspector-inspect-last-exception "cider-inspector") + +(defun cider-stacktrace--inspect-class (event) + "Mouse handler for EVENT." + (interactive "e") + (let* ((pos (posn-point (event-end event))) + (window (posn-window (event-end event))) + (buffer (window-buffer window)) + (inspect-index (with-current-buffer buffer + (get-text-property pos 'inspect-index)))) + (cider-inspector-inspect-last-exception inspect-index))) + +(defun cider-stacktrace--inspect-class-kbd () + "Keyboard handler." + (interactive) + (when-let ((inspect-index (get-text-property (point) 'inspect-index))) + (cider-inspector-inspect-last-exception inspect-index))) + +(defvar cider-stacktrace-exception-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] #'cider-stacktrace--inspect-class) + (define-key map (kbd "p") #'cider-stacktrace--inspect-class-kbd) + (define-key map (kbd "i") #'cider-stacktrace--inspect-class-kbd) + map)) + +(defun cider-stacktrace-render-cause (buffer cause num note &optional inspect-index) + "Emit into BUFFER the CAUSE NUM, exception class, message, data, and NOTE, +make INSPECT-INDEX actionable if present." + (with-current-buffer buffer + (nrepl-dbind-response cause (class message data spec stacktrace) + (let ((indent " ") + (class-face 'cider-stacktrace-error-class-face) + (message-face 'cider-stacktrace-error-message-face)) + (cider-propertize-region `(cause ,num) + ;; Detail level 0: exception class + (cider-propertize-region `(detail + 0 + + inspect-index + ,inspect-index + + keymap + ,cider-stacktrace-exception-map) + (insert (format "%d. " num) + (propertize note 'font-lock-face 'font-lock-comment-face) " " + (propertize class 'font-lock-face class-face 'mouse-face 'highlight) + "\n")) + ;; Detail level 1: message + ex-data + (cider-propertize-region '(detail 1) + (if (equal class "clojure.lang.Compiler$CompilerException") + (cider-stacktrace-render-compile-error buffer cause) + (cider-stacktrace-emit-indented + (propertize (or message "(No message)") + 'font-lock-face message-face) + indent t)) + (insert "\n") + (when spec + (cider-stacktrace--emit-spec-problems spec (concat indent " "))) + (when data + (cider-stacktrace-emit-indented data indent nil t))) + ;; Detail level 2: stacktrace + (cider-propertize-region '(detail 2) + (insert "\n") + (let ((beg (point)) + (bg `(:background ,cider-stacktrace-frames-background-color :extend t))) + (dolist (frame stacktrace) + (cider-stacktrace-render-frame buffer frame)) + (overlay-put (make-overlay beg (point)) 'font-lock-face bg))) + ;; Add line break between causes, even when collapsed. + (cider-propertize-region '(detail 0) + (insert "\n"))))))) + +(defun cider-stacktrace-initialize (causes) + "Set and apply CAUSES initial visibility, filters, and cursor position." + (nrepl-dbind-response (car causes) (class) + (let ((compile-error-p (equal class "clojure.lang.Compiler$CompilerException"))) + ;; Partially display outermost cause if it's a compiler exception (the + ;; description reports reader location of the error). + (when compile-error-p + (cider-stacktrace-cycle-cause (length causes) 1)) + ;; Fully display innermost cause. This also applies visibility/filters. + (cider-stacktrace-cycle-cause 1 cider-stacktrace-detail-max) + ;; Move point (DWIM) to the compile error location if present, or to the + ;; first stacktrace frame in displayed cause otherwise. If the error + ;; buffer is visible in a window, ensure that window is selected while moving + ;; point, so as to move both the buffer's and the window's point. + (with-selected-window (or (get-buffer-window cider-error-buffer) + (selected-window)) + (with-current-buffer cider-error-buffer + (goto-char (point-min)) + (if compile-error-p + (goto-char (next-single-property-change (point) 'compile-error)) + (progn + (while (cider-stacktrace-next-cause)) + (when-let (position (next-single-property-change (point) 'flags)) + (goto-char position))))))))) + +(defun cider-stacktrace-render (buffer causes &optional error-types) + "Emit into BUFFER useful stacktrace information for the CAUSES. +Takes an optional ERROR-TYPES list which will render a 'suppression' toggle +that alters the pop-over/pop-under behavorior of the stacktrace buffers +created by these types of errors. The suppressed errors set can be customized +through the `cider-stacktrace-suppressed-errors' variable." + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (erase-buffer) + (insert "\n") + ;; Stacktrace filters + (cider-stacktrace-render-filters + buffer + `(("Project-Only" project) ("All" all)) + `(("Clojure" clj) ("Java" java) ("REPL" repl) + ("Tooling" tooling) ("Duplicates" dup))) + (insert "\n") + ;; Option to suppress internal/middleware errors + (when error-types + (cider-stacktrace-render-suppression-toggle buffer error-types) + (insert "\n\n")) + ;; Stacktrace exceptions & frames + (let* ((causes-length (length causes)) + (num causes-length)) + (dolist (cause causes) + (let ((note (if (= num causes-length) "Unhandled" "Caused by"))) + (cider-stacktrace-render-cause buffer cause num note (- causes-length num)) + (setq num (1- num)))))) + (cider-stacktrace-initialize causes) + (font-lock-refresh-defaults))) + +(defun cider-stacktrace--analyze-stacktrace-op (stacktrace) + "Return the Cider NREPL op to analyze STACKTRACE." + (list "op" "analyze-stacktrace" "stacktrace" stacktrace)) + +(defun cider-stacktrace--stacktrace-request (stacktrace) + "Return the Cider NREPL request to analyze STACKTRACE." + (thread-last + (map-merge 'list + (list (cider-stacktrace--analyze-stacktrace-op stacktrace)) + (cider--nrepl-print-request-map fill-column)) + (seq-mapcat #'identity))) + +(defun cider-stacktrace--analyze-render (causes) + "Render the CAUSES of the stacktrace analysis result." + (let ((buffer (get-buffer-create cider-error-buffer))) + (with-current-buffer buffer + (cider-stacktrace-mode) + (cider-stacktrace-render buffer (reverse causes)) + (display-buffer buffer cider-jump-to-pop-to-buffer-actions)))) + +(defun cider-stacktrace-analyze-string (stacktrace) + "Analyze the STACKTRACE string and show the result." + (when (stringp stacktrace) + (set-text-properties 0 (length stacktrace) nil stacktrace)) + (let (causes) + (cider-nrepl-send-request + (cider-stacktrace--stacktrace-request stacktrace) + (lambda (response) + (setq causes (nrepl-dbind-response response (class status) + (cond (class (cons response causes)) + ((and (member "done" status) causes) + (cider-stacktrace--analyze-render causes))))))))) + +(defun cider-stacktrace-analyze-at-point () + "Analyze the stacktrace at point." + (interactive) + (cond ((thing-at-point 'sentence) + (cider-stacktrace-analyze-string (thing-at-point 'sentence))) + ((thing-at-point 'paragraph) + (cider-stacktrace-analyze-string (thing-at-point 'paragraph))) + (t (cider-stacktrace-analyze-in-region (region-beginning) (region-end))))) + +(defun cider-stacktrace-analyze-in-region (beg end) + "Analyze the stacktrace in the region between BEG and END." + (interactive (list (region-beginning) (region-end))) + (let ((stacktrace (buffer-substring beg end))) + (cider-stacktrace-analyze-string stacktrace))) + +(provide 'cider-stacktrace) + +;;; cider-stacktrace.el ends here diff --git a/elpa/cider-20241203.1607/cider-test.el b/elpa/cider-20241203.1607/cider-test.el new file mode 100644 index 00000000..b67021ce --- /dev/null +++ b/elpa/cider-20241203.1607/cider-test.el @@ -0,0 +1,944 @@ +;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*- + +;; Copyright © 2014-2024 Jeff Valk, Bozhidar Batsov and CIDER contributors + +;; Author: Jeff Valk + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; This provides execution, reporting, and navigation support for Clojure tests, +;; specifically using the `clojure.test' machinery. This functionality replaces +;; the venerable `clojure-test-mode' (deprecated in June 2014), and relies on +;; nREPL middleware for report running and session support. + +;;; Code: + +(require 'ansi-color) +(require 'button) +(require 'cl-lib) +(require 'easymenu) +(require 'map) +(require 'seq) +(require 'subr-x) + +(require 'cider-common) +(require 'cider-client) +(require 'cider-popup) +(require 'cider-stacktrace) +(require 'cider-overlays) +(require 'cider-util) + +;;; Variables + +(defgroup cider-test nil + "Presentation and navigation for test results." + :prefix "cider-test-" + :group 'cider) + +(defcustom cider-test-show-report-on-success nil + "Whether to show the `*cider-test-report*` buffer on passing tests." + :type 'boolean + :package-version '(cider . "0.8.0")) + +(defcustom cider-auto-select-test-report-buffer t + "Determines if the test-report buffer should be auto-selected." + :type 'boolean + :package-version '(cider . "0.9.0")) + +(make-obsolete 'cider-test-defining-forms nil "1.8.0") + +(defvar cider-test--current-repl nil + "Contains the reference to the REPL where the tests were last invoked from. +This is needed for *cider-test-report* navigation +to work against the correct REPL session.") + +(defvar cider-test-last-summary nil + "The summary of the last run test.") + +(defvar cider-test-last-results nil + "The results of the last run test.") + +(defconst cider-test-report-buffer "*cider-test-report*" + "Buffer name in which to display test reports.") + +;;; Faces + +(defface cider-test-failure-face + '((((class color) (background light)) + :background "orange red") + (((class color) (background dark)) + :background "firebrick")) + "Face for failed tests." + :package-version '(cider . "0.7.0")) + +(defface cider-test-error-face + '((((class color) (background light)) + :background "orange1") + (((class color) (background dark)) + :background "orange4")) + "Face for erring tests." + :package-version '(cider . "0.7.0")) + +(defface cider-test-success-face + '((((class color) (background light)) + :foreground "black" + :background "green") + (((class color) (background dark)) + :foreground "black" + :background "green")) + "Face for passing tests." + :package-version '(cider . "0.7.0")) + + +;; Colors & Theme Support + +(defvar cider-test-items-background-color + (cider-scale-background-color) + "Background color for test assertion items.") + +(advice-add 'enable-theme :after #'cider--test-adapt-to-theme) +(advice-add 'disable-theme :after #'cider--test-adapt-to-theme) +(defun cider--test-adapt-to-theme (&rest _) + "When theme is changed, update `cider-test-items-background-color'." + (setq cider-test-items-background-color (cider-scale-background-color))) + +;;; Report mode & key bindings +;; +;; The primary mode of interacting with test results is the report buffer, which +;; allows navigation among tests, jumping to test definitions, expected/actual +;; diff-ing, and cause/stacktrace inspection for test errors. + +(defvar cider-test-commands-map + (let ((map (define-prefix-command 'cider-test-commands-map))) + ;; Duplicates of keys below with C- for convenience + (define-key map (kbd "C-r") #'cider-test-rerun-failed-tests) + (define-key map (kbd "C-t") #'cider-test-run-test) + (define-key map (kbd "C-a") #'cider-test-rerun-test) + (define-key map (kbd "C-n") #'cider-test-run-ns-tests) + (define-key map (kbd "C-s") #'cider-test-run-ns-tests-with-filters) + (define-key map (kbd "C-l") #'cider-test-run-loaded-tests) + (define-key map (kbd "C-p") #'cider-test-run-project-tests) + (define-key map (kbd "C-b") #'cider-test-show-report) + (define-key map (kbd "C-f") #'cider-test-toggle-fail-fast) + ;; Single-key bindings defined last for display in menu + (define-key map (kbd "r") #'cider-test-rerun-failed-tests) + (define-key map (kbd "t") #'cider-test-run-test) + (define-key map (kbd "a") #'cider-test-rerun-test) + (define-key map (kbd "n") #'cider-test-run-ns-tests) + (define-key map (kbd "s") #'cider-test-run-ns-tests-with-filters) + (define-key map (kbd "l") #'cider-test-run-loaded-tests) + (define-key map (kbd "p") #'cider-test-run-project-tests) + (define-key map (kbd "b") #'cider-test-show-report) + (define-key map (kbd "f") #'cider-test-toggle-fail-fast) + map)) + +(defconst cider-test-menu + '("Test" + ["Run test" cider-test-run-test] + ["Run namespace tests" cider-test-run-ns-tests] + ["Run namespace tests with filters" cider-test-run-ns-tests-with-filters] + ["Run all loaded tests" cider-test-run-loaded-tests] + ["Run all loaded tests with filters" (apply-partially cider-test-run-loaded-tests 'prompt-for-filters)] + ["Run all project tests" cider-test-run-project-tests] + ["Run all project tests with filters" (apply-partially cider-test-run-project-tests 'prompt-for-filters)] + ["Run tests after load-file" cider-auto-test-mode + :style toggle :selected cider-auto-test-mode] + "--" + ["Interrupt running tests" cider-interrupt] + ["Rerun failed/erring tests" cider-test-rerun-failed-tests] + ["Show test report" cider-test-show-report] + "--" + ["Configure testing" (customize-group 'cider-test)]) + "CIDER test submenu.") + +(defvar cider-test-report-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c ,") 'cider-test-commands-map) + (define-key map (kbd "C-c C-t") 'cider-test-commands-map) + (define-key map (kbd "M-p") #'cider-test-previous-result) + (define-key map (kbd "M-n") #'cider-test-next-result) + (define-key map (kbd "M-.") #'cider-test-jump) + (define-key map (kbd "") #'cider-test-previous-result) + (define-key map (kbd "TAB") #'cider-test-next-result) + (define-key map (kbd "RET") #'cider-test-jump) + (define-key map (kbd "t") #'cider-test-jump) + (define-key map (kbd "d") #'cider-test-ediff) + (define-key map (kbd "e") #'cider-test-stacktrace) + ;; `f' for "run failed". + (define-key map "f" #'cider-test-rerun-failed-tests) + (define-key map "n" #'cider-test-run-ns-tests) + (define-key map "s" #'cider-test-run-ns-tests-with-filters) + (define-key map "l" #'cider-test-run-loaded-tests) + (define-key map "p" #'cider-test-run-project-tests) + ;; `g' generally reloads the buffer. The closest thing we have to that is + ;; "run the test at point". But it's not as nice as rerunning all tests in + ;; this buffer. + (define-key map "g" #'cider-test-run-test) + (define-key map "q" #'cider-popup-buffer-quit-function) + (easy-menu-define cider-test-report-mode-menu map + "Menu for CIDER's test result mode" + '("Test-Report" + ["Previous result" cider-test-previous-result] + ["Next result" cider-test-next-result] + "--" + ["Rerun current test" cider-test-run-test] + ["Rerun failed/erring tests" cider-test-rerun-failed-tests] + ["Run all ns tests" cider-test-run-ns-tests] + ["Run all ns tests with filters" cider-test-run-ns-tests-with-filters] + ["Run all loaded tests" cider-test-run-loaded-tests] + ["Run all loaded tests with filters" (apply-partially cider-test-run-loaded-tests 'prompt-for-filters)] + ["Run all project tests" cider-test-run-project-tests] + ["Run all project tests with filters" (apply-partially cider-test-run-project-tests 'prompt-for-filters)] + "--" + ["Jump to test definition" cider-test-jump] + ["Display test error" cider-test-stacktrace] + ["Display expected/actual diff" cider-test-ediff])) + map)) + +(define-derived-mode cider-test-report-mode fundamental-mode "Test Report" + "Major mode for presenting Clojure test results. + +\\{cider-test-report-mode-map}" + (setq buffer-read-only t) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t)) + (setq-local sesman-system 'CIDER) + (setq-local electric-indent-chars nil) + (buffer-disable-undo)) + +;; Report navigation + +(defun cider-test-show-report () + "Show the test report buffer, if one exists." + (interactive) + (if-let* ((report-buffer (get-buffer cider-test-report-buffer))) + (switch-to-buffer report-buffer) + (message "No test report buffer"))) + +(defun cider-test-previous-result () + "Move point to the previous test result, if one exists." + (interactive) + (with-current-buffer (get-buffer cider-test-report-buffer) + (when-let* ((pos (previous-single-property-change (point) 'type))) + (if (get-text-property pos 'type) + (goto-char pos) + (when-let* ((pos (previous-single-property-change pos 'type))) + (goto-char pos)))))) + +(defun cider-test-next-result () + "Move point to the next test result, if one exists." + (interactive) + (with-current-buffer (get-buffer cider-test-report-buffer) + (when-let* ((pos (next-single-property-change (point) 'type))) + (if (get-text-property pos 'type) + (goto-char pos) + (when-let* ((pos (next-single-property-change pos 'type))) + (goto-char pos)))))) + +(declare-function cider-find-var "cider-find") + +(defun cider-test-jump (&optional arg) + "Find definition for test at point, if available. +The prefix ARG and `cider-prompt-for-symbol' decide whether to +prompt and whether to use a new window. Similar to `cider-find-var'." + (interactive "P") + (let ((ns (get-text-property (point) 'ns)) + (var (get-text-property (point) 'var)) + (line (get-text-property (point) 'line))) + (if (and ns var) + (cider-find-var arg (concat ns "/" var) line) + (cider-find-var arg)))) + +;;; Error stacktraces + +(defvar cider-auto-select-error-buffer) + +(defun cider-test-stacktrace-for (ns var index) + "Display stacktrace for the erring NS VAR test with the assertion INDEX." + (let (causes) + (cider-nrepl-send-request + (thread-last + (map-merge 'list + `(("op" "test-stacktrace") + ("ns" ,ns) + ("var" ,var) + ("index" ,index)) + (cider--nrepl-print-request-map fill-column)) + (seq-mapcat #'identity)) + (lambda (response) + (nrepl-dbind-response response (class status) + (cond (class (setq causes (cons response causes))) + (status (when causes + (cider-stacktrace-render + (cider-popup-buffer cider-error-buffer + cider-auto-select-error-buffer + #'cider-stacktrace-mode + 'ancillary) + (reverse causes))))))) + cider-test--current-repl))) + +(defun cider-test-stacktrace () + "Display stacktrace for the erring test at point." + (interactive) + (let ((ns (get-text-property (point) 'ns)) + (var (get-text-property (point) 'var)) + (index (get-text-property (point) 'index)) + (err (get-text-property (point) 'error))) + (if (and err ns var index) + (cider-test-stacktrace-for ns var index) + (message "No test error at point")))) + + +;;; Expected vs actual diffing + +(defvar cider-test-ediff-buffers nil + "The expected/actual buffers used to display diff.") + +(defun cider-test--extract-from-actual (actual n) + "Extract form N from ACTUAL, ignoring outermost not. + +ACTUAL is a string like \"(not (= 3 4))\", of the sort returned by +clojure.test. + +N = 1 => 3, N = 2 => 4, etc." + (with-temp-buffer + (insert actual) + (clojure-mode) + (goto-char (point-min)) + (re-search-forward "(" nil t 2) + (clojure-forward-logical-sexp n) + (forward-whitespace 1) + (let ((beg (point))) + (clojure-forward-logical-sexp) + (buffer-substring beg (point))))) + +(defun cider-test-ediff () + "Show diff of the expected vs actual value for the test at point. +With the actual value, the outermost '(not ...)' s-expression is removed." + (interactive) + (let* ((expected-buffer (generate-new-buffer " *expected*")) + (actual-buffer (generate-new-buffer " *actual*")) + (diffs (get-text-property (point) 'diffs)) + (actual* (get-text-property (point) 'actual)) + (expected (cond (diffs (get-text-property (point) 'expected)) + (actual* (cider-test--extract-from-actual actual* 1)))) + (actual (cond (diffs (caar diffs)) + (actual* (cider-test--extract-from-actual actual* 2))))) + (if (not (and expected actual)) + (message "No test failure at point") + (with-current-buffer expected-buffer + (insert expected) + (clojure-mode)) + (with-current-buffer actual-buffer + (insert actual) + (clojure-mode)) + (apply #'ediff-buffers + (setq cider-test-ediff-buffers + (list (buffer-name expected-buffer) + (buffer-name actual-buffer))))))) + +(defun cider-test-ediff-cleanup () + "Cleanup expected/actual buffers used for diff." + (interactive) + (mapc (lambda (b) (when (get-buffer b) (kill-buffer b))) + cider-test-ediff-buffers)) + +(add-hook 'ediff-cleanup-hook #'cider-test-ediff-cleanup) + + +;;; Report rendering + +(defcustom cider-test-fail-fast t + "Controls whether to stop a test run on failure/error." + :type 'boolean + :package-version '(cider . "1.8.0")) + +(defun cider-test-toggle-fail-fast () + "Toggles `cider-test-fail-fast' t <-> nil for the current buffer." + (interactive) + (setq-local cider-test-fail-fast (not cider-test-fail-fast))) + +(defun cider-test-type-face (type) + "Return the font lock face for the test result TYPE." + (pcase type + ("pass" 'cider-test-success-face) + ("fail" 'cider-test-failure-face) + ("error" 'cider-test-error-face) + (_ 'default))) + +(defun cider-test-type-simple-face (type) + "Return a face for the test result TYPE using the highlight color as foreground." + (let ((face (cider-test-type-face type))) + `(:foreground ,(face-attribute face :background)))) + +(defun cider-test-render-summary (buffer summary &optional elapsed-time) + "Emit into BUFFER the report SUMMARY statistics. + +If ELAPSED-TIME is provided it will be included in the summary." + (with-current-buffer buffer + (nrepl-dbind-response summary (ns var test pass fail error) + (let ((ms (nrepl-dict-get elapsed-time "ms"))) + (insert (format "Tested %d namespaces%s\n" ns (if ms + (format " in %s ms" ms) + "")))) + (insert (format "Ran %d assertions, in %d test functions\n" test var)) + (unless (zerop fail) + (cider-insert (format "%d failures" fail) 'cider-test-failure-face t)) + (unless (zerop error) + (cider-insert (format "%d errors" error) 'cider-test-error-face t)) + (when (zerop (+ fail error)) + (cider-insert (format "%d passed" pass) 'cider-test-success-face t)) + (when cider-test-fail-fast + (cider-insert "cider-test-fail-fast: " 'font-lock-comment-face nil) + (cider-insert "t" 'font-lock-constant-face t)) + (insert "\n\n")))) + +(defun cider-test--string-contains-newline (input-string) + "Returns whether INPUT-STRING contains an escaped newline." + (when (stringp input-string) + (and (string-match-p "\\\\n" input-string) + t))) + +(defvar cider-test-var-keymap + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] #'cider-test-jump) + map)) + +(defun cider-test-render-assertion (buffer test) + "Emit into BUFFER report detail for the TEST assertion." + (with-current-buffer buffer + (nrepl-dbind-response test (var context type message expected actual diffs error gen-input) + (cl-flet ((insert-label (s) + (cider-insert (format "%8s: " s) 'font-lock-comment-face)) + (insert-align-label (s) + (insert (format "%12s" s))) + (insert-rect (s) + (let ((start (point))) + (insert-rectangle (thread-first + s + cider-font-lock-as-clojure + (split-string "\n"))) + (ansi-color-apply-on-region start (point))) + (beginning-of-line))) + (cider-propertize-region (cider-intern-keys (cdr test)) + (let ((beg (point)) + (type-face (cider-test-type-simple-face type)) + (bg `(:background ,cider-test-items-background-color :extend t))) + (cider-insert (capitalize type) type-face nil " in ") + (cider-propertize-region `(keymap ,cider-test-var-keymap) + (cider-insert (propertize var 'mouse-face 'highlight) + 'font-lock-function-name-face t)) + (when context (cider-insert context 'font-lock-doc-face t)) + (when message (cider-insert message 'font-lock-string-face t)) + (when expected + (insert-label "expected") + (insert-rect expected) + ;; Only place a newline between expected and actual when the values are deemed 'dense', + ;; otherwise favor compact output: + (when (or (cider-test--string-contains-newline expected) + (cider-test--string-contains-newline actual)) + (insert "\n"))) + (if diffs + (dolist (d diffs) + (cl-destructuring-bind (actual (removed added)) d + (insert-label "actual") + (insert-rect actual) + (insert "\n") + (insert-label "diff") + (insert "- ") + (insert-rect removed) + (insert-align-label "+ ") + (insert-rect added) + (insert "\n"))) + (when actual + (insert-label "actual") + (insert-rect actual))) + (when error + (insert-label "error") + (insert-text-button error + 'follow-link t + 'action '(lambda (_button) (cider-test-stacktrace)) + 'help-echo "View causes and stacktrace") + (insert "\n")) + (when gen-input + (insert-label "input") + (insert (cider-font-lock-as-clojure gen-input))) + (overlay-put (make-overlay beg (point)) 'font-lock-face bg)) + (insert "\n")))))) + +(defun cider-test-non-passing (tests) + "For a list of TESTS, each an `nrepl-dict`, return only those that did not pass." + (seq-filter (lambda (test) + (unless (equal (nrepl-dict-get test "type") "pass") + test)) + tests)) + +(defun cider-test-render-report (buffer summary results &optional elapsed-time ns-elapsed-time var-elapsed-time) + "Emit into BUFFER the report for the SUMMARY, and test RESULTS." + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (cider-test-report-mode) + (cider-insert "Test Summary" 'bold t) + (dolist (ns (nrepl-dict-keys results)) + (insert (cider-propertize ns 'ns) + (or (let ((ms (nrepl-dict-get (nrepl-dict-get ns-elapsed-time ns) + "ms"))) + (propertize (format " %s ms" ms) 'face 'font-lock-comment-face)) + "") + "\n") + (when var-elapsed-time + (when-let ((pairs (nrepl-dict-get var-elapsed-time ns))) + (nrepl-dict-map (lambda (var meta) + (insert " " ;; indentation - we're showing a var within a ns + (cider-propertize var 'font-lock-function-name-face) + (or (when-let* ((elapsed (nrepl-dict-get meta "elapsed-time")) + (ms (nrepl-dict-get elapsed "ms"))) + (propertize (format " %s ms" ms) 'face 'font-lock-comment-face)) + "") + "\n")) + pairs)))) + (cider-insert "\n") + (cider-test-render-summary buffer summary elapsed-time) + (nrepl-dbind-response summary (fail error) + (unless (zerop (+ fail error)) + (cider-insert "Results" 'bold t "\n") + ;; Results are a nested dict, keyed first by ns, then var. Within each + ;; var is a sequence of test assertion results. + (nrepl-dict-map + (lambda (ns vars) + (nrepl-dict-map + (lambda (_var tests) + (let* ((problems (cider-test-non-passing tests)) + (count (length problems))) + (when (< 0 count) + (insert (format "%s\n%d non-passing tests:\n\n" + (cider-propertize ns 'ns) count)) + (dolist (test problems) + (cider-test-render-assertion buffer test))))) + vars)) + results))) + ;; Replace any newline chars with actual newlines to make long error + ;; messages more readable + (goto-char (point-min)) + (while (search-forward "\\n" nil t) + (replace-match " +")) + (goto-char (point-min)) + (current-buffer)))) + + +;;; Message echo + +(defun cider-test-echo-running (ns &optional test) + "Echo a running message for the test NS, which may be a keyword. +The optional arg TEST denotes an individual test name." + (if test + (message "Running test %s in %s..." + (cider-propertize test 'bold) + (cider-propertize ns 'ns)) + (message "Running tests in %s..." + (concat (cider-propertize + (cond ((stringp ns) ns) + ((eq :non-passing ns) "failing") + ((eq :loaded ns) "all loaded") + ((eq :project ns) "all project")) + 'ns) + (unless (stringp ns) " namespaces"))))) + +(defun cider-test-echo-summary (summary results &optional elapsed-time) + "Echo SUMMARY statistics for a test run returning RESULTS in ELAPSED-TIME." + (nrepl-dbind-response summary (ns test var fail error) + (if (nrepl-dict-empty-p results) + (message (concat (propertize "No assertions (or no tests) were run." 'face 'cider-test-error-face) + "Did you forget to use `is' in your tests?")) + (let* ((ms (nrepl-dict-get elapsed-time "ms")) + (ms (if ms + (propertize (format " in %s ms" ms ) 'face 'font-lock-comment-face) + "."))) + (message (propertize + "%sRan %d assertions, in %d test functions. %d failures, %d errors%s" + 'face (cond ((not (zerop error)) 'cider-test-error-face) + ((not (zerop fail)) 'cider-test-failure-face) + (t 'cider-test-success-face))) + (concat (if (= 1 ns) ; ns count from summary + (cider-propertize (car (nrepl-dict-keys results)) 'ns) + (propertize (format "%d namespaces" ns) 'face 'default)) + (propertize ": " 'face 'default)) + test var fail error ms))))) + +;;; Test definition highlighting +;; +;; On receipt of test results, failing/erring test definitions are highlighted. +;; Highlights are cleared on the next report run, and may be cleared manually +;; by the user. + +;; NOTE If keybindings specific to test sources are desired, it would be +;; straightforward to turn this into a `cider-test-mode' minor mode, which we +;; enable on test sources, much like the legacy `clojure-test-mode'. At present, +;; though, there doesn't seem to be much value in this, since the report buffer +;; provides the primary means of interacting with test results. + +(defun cider-test-highlight-problem (buffer test) + "Highlight the BUFFER test definition for the non-passing TEST." + (with-current-buffer buffer + ;; we don't need the file name here, as we always operate on the current + ;; buffer and the line data is correct even for vars that were + ;; defined interactively + (nrepl-dbind-response test (type line message expected actual) + (when line + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (search-forward "(" nil t) + (let ((beg (point))) + (forward-sexp) + (cider--make-overlay beg (point) 'cider-test + 'font-lock-face (cider-test-type-face type) + 'type type + 'help-echo message + 'message message + 'expected expected + 'actual actual))))))) + +(defun cider-find-var-file (ns var) + "Return the buffer visiting the file in which the NS VAR is defined. +Or nil if not found." + (when-let* ((info (cider-var-info (concat ns "/" var))) + (file (nrepl-dict-get info "file"))) + (cider-find-file file))) + +(defun cider-test-highlight-problems (results) + "Highlight all non-passing tests in the test RESULTS." + (nrepl-dict-map + (lambda (ns vars) + (nrepl-dict-map + (lambda (var tests) + (when-let* ((buffer (cider-find-var-file ns var))) + (dolist (test tests) + (nrepl-dbind-response test (type) + (unless (equal "pass" type) + (cider-test-highlight-problem buffer test)))))) + vars)) + results)) + +(defun cider-test-clear-highlights () + "Clear highlighting of non-passing tests from the last test run." + (interactive) + (when cider-test-last-results + (nrepl-dict-map + (lambda (ns vars) + (dolist (var (nrepl-dict-keys vars)) + (when-let* ((buffer (cider-find-var-file ns var))) + (with-current-buffer buffer + (remove-overlays nil nil 'category 'cider-test))))) + cider-test-last-results))) + + +;;; Test namespaces +;; +;; Test namespace inference exists to enable DWIM test running functions: the +;; same "run-tests" function should be able to be used in a source file, and in +;; its corresponding test namespace. To provide this, we need to map the +;; relationship between those namespaces. + +(defcustom cider-test-infer-test-ns 'cider-test-default-test-ns-fn + "Function to infer the test namespace for NS. +The default implementation uses the simple Leiningen convention of appending +'-test' to the namespace name." + :type 'symbol + :package-version '(cider . "0.7.0")) + +(defun cider-test-default-test-ns-fn (ns) + "For a NS, return the test namespace, which may be the argument itself. +This uses the Leiningen convention of appending '-test' to the namespace name." + (when ns + (let ((suffix "-test")) + (if (string-suffix-p suffix ns) + ns + (concat ns suffix))))) + + +;;; Test execution + +(defcustom cider-test-default-include-selectors '() + "List of include selector strings to use when executing tests if none provided." + :type '(repeat string) + :package-version '(cider . "1.1.0")) + +(defcustom cider-test-default-exclude-selectors '() + "List of exclude selector strings to use when executing tests if none provided." + :type '(repeat string) + :package-version '(cider . "1.1.0")) + +(declare-function cider-emit-interactive-eval-output "cider-eval") +(declare-function cider-emit-interactive-eval-err-output "cider-eval") + +(defun cider-test--prompt-for-selectors (message) + "Prompt for test selectors with MESSAGE. +The selectors can be either keywords or strings." + (mapcar + (lambda (string) (replace-regexp-in-string "^:+" "" string)) + (split-string + (cider-read-from-minibuffer message)))) + +(defun cider-test-execute (ns &optional tests silent prompt-for-filters) + "Run tests for NS, which may be a keyword, optionally specifying TESTS. +This tests a single NS, or multiple namespaces when using keywords `:project', +`:loaded' or `:non-passing'. Optional TESTS are only honored when a single +namespace is specified. Upon test completion, results are echoed and a test +report is optionally displayed. When test failures/errors occur, their sources +are highlighted. +If SILENT is non-nil, suppress all messages other then test results. +If PROMPT-FOR-FILTERS is non-nil, prompt the user for a test selector filters. +The include/exclude selectors will be used to filter the tests before +running them." + (cider-test-clear-highlights) + (let ((include-selectors + (if prompt-for-filters + (cider-test--prompt-for-selectors + "Test selectors to include (space separated): ") + cider-test-default-include-selectors)) + (exclude-selectors + (if prompt-for-filters + (cider-test--prompt-for-selectors + "Test selectors to exclude (space separated): ") + cider-test-default-exclude-selectors))) + (cider-map-repls :clj-strict + (lambda (conn) + (unless silent + (if (and tests (= (length tests) 1)) + ;; we generate a different message when running individual tests + (cider-test-echo-running ns (car tests)) + (cider-test-echo-running ns))) + (setq cider-test--current-repl conn) + (let* ((retest? (eq :non-passing ns)) + (request `("op" ,(cond ((stringp ns) "test") + ((eq :project ns) "test-all") + ((eq :loaded ns) "test-all") + (retest? "retest"))))) + ;; we add optional parts of the request only when relevant + (when (and (listp include-selectors) include-selectors) + (setq request (append request `("include" ,include-selectors)))) + (when (and (listp exclude-selectors) exclude-selectors) + (setq request (append request `("exclude" ,exclude-selectors)))) + (when (stringp ns) + (setq request (append request `("ns" ,ns)))) + (when (stringp ns) + (setq request (append request `("tests" ,tests)))) + (when (or (stringp ns) (eq :project ns)) + (setq request (append request `("load?" ,"true")))) + (when (and cider-test-fail-fast + (not retest?)) + (setq request (append request `("fail-fast" ,"true")))) + (cider-nrepl-send-request + request + (lambda (response) + (nrepl-dbind-response response (summary results status out err elapsed-time ns-elapsed-time var-elapsed-time) + (cond ((member "namespace-not-found" status) + (unless silent + (message "No test namespace: %s" (cider-propertize ns 'ns)))) + (out (cider-emit-interactive-eval-output out)) + (err (cider-emit-interactive-eval-err-output err)) + (results + (nrepl-dbind-response summary (error fail) + (setq cider-test-last-summary summary) + (setq cider-test-last-results results) + (cider-test-highlight-problems results) + (cider-test-echo-summary summary results elapsed-time) + (if (or (not (zerop (+ error fail))) + cider-test-show-report-on-success) + (let ((b (cider-popup-buffer + cider-test-report-buffer + cider-auto-select-test-report-buffer))) + (with-current-buffer b + ;; Change the default-directory so that it doesn't affect `sesman--linked-sessions` logic: + (setq-local default-directory + (with-current-buffer "*Messages*" default-directory))) + (cider-test-render-report + b + summary + results + elapsed-time + ns-elapsed-time + var-elapsed-time)) + (when (get-buffer cider-test-report-buffer) + (with-current-buffer cider-test-report-buffer + (let ((inhibit-read-only t)) + (erase-buffer))) + (cider-test-render-report + cider-test-report-buffer + summary + results + elapsed-time + ns-elapsed-time)))))))) + conn)))))) + +(defun cider-test-rerun-failed-tests () + "Rerun failed and erring tests from the last test run." + (interactive) + (if cider-test-last-summary + (nrepl-dbind-response cider-test-last-summary (fail error) + (if (not (zerop (+ error fail))) + (cider-test-execute :non-passing) + (message "No prior failures to retest"))) + (message "No prior results to retest"))) + +(defun cider-test-run-loaded-tests (prompt-for-filters) + "Run all tests defined in currently loaded namespaces. + +If PROMPT-FOR-FILTERS is non-nil, prompt the user for a test selectors to +filter the tests with." + (interactive "P") + (cider-test-execute :loaded nil nil prompt-for-filters)) + +(defun cider-test-run-project-tests (prompt-for-filters) + "Run all tests defined in all project namespaces, loading these as needed. + +If PROMPT-FOR-FILTERS is non-nil, prompt the user for a test selectors to +filter the tests with." + (interactive "P") + (cider-test-execute :project nil nil prompt-for-filters)) + +(defun cider-test-run-ns-tests-with-filters (suppress-inference) + "Run tests filtered by selectors for the current Clojure namespace context. + +With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the +current ns." + (interactive "P") + (cider-test-run-ns-tests suppress-inference nil 't)) + +(defun cider-test-run-ns-tests (suppress-inference &optional silent prompt-for-filters) + "Run all tests for the current Clojure namespace context. + +If SILENT is non-nil, suppress all messages other then test results. +With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the +current ns. If PROMPT-FOR-FILTERS is non-nil, prompt the user for +test selectors to filter the tests with." + (interactive "P") + (if-let* ((ns (if suppress-inference + (cider-current-ns t) + (funcall cider-test-infer-test-ns (cider-current-ns t))))) + (cider-test-execute ns nil silent prompt-for-filters) + (if (eq major-mode 'cider-test-report-mode) + (when (y-or-n-p (concat "Test report does not define a namespace. " + "Rerun failed/erring tests?")) + (cider-test-rerun-failed-tests)) + (unless silent + (message "No namespace to test in current context"))))) + +(defvar cider-test-last-test-ns nil + "The ns of the last test ran with `cider-test-run-test'.") +(defvar cider-test-last-test-var nil + "The var of the last test ran with `cider-test-run-test'.") + +(defun cider-test-update-last-test (ns var) + "Update the last test by setting NS and VAR. + +See `cider-test-rerun-test'." + (setq cider-test-last-test-ns ns + cider-test-last-test-var var)) + +(defun cider--test-var-p (ns var) + "Determines if the VAR in NS is a test." + (if (cider-nrepl-op-supported-p "cider/get-state") + (cider-resolve--get-in ns "interns" var "test") + (equal "true" + (nrepl-dict-get (cider-sync-tooling-eval + (format "(clojure.core/-> %s var clojure.core/meta (clojure.core/contains? :test))" + var) + ns) + "value")))) + +(defun cider--extract-test-var-at-point () + "Find ns and var for the test at point. +The test ns/var exist as text properties on report items and on highlighted +failed/erred test definitions. + +When not found, a test definition at point +or in a corresponding test namespace is searched." + (let* ((ns-from-text-property (get-text-property (point) 'ns)) + (var-from-text-property (when ns-from-text-property + ;; we're in a `cider-test-report-mode' buffer + ;; or on a highlighted failed/erred test definition + (get-text-property (point) 'var)))) + (or (when (and var-from-text-property + ;; Slightly redundant check. However querying `cider-resolve--get-in` is cheap: + (cider--test-var-p ns-from-text-property var-from-text-property)) + (list ns-from-text-property var-from-text-property)) + (when-let* ((n (cider-get-ns-name)) + (v (cadr (clojure-find-def)))) + (or (when (cider--test-var-p n v) + (list n v)) + (let ((derived-ns (funcall cider-test-infer-test-ns n)) + (derived-var (concat v "-test"))) + ;; deftest foo-test: + (or (when (cider--test-var-p derived-ns derived-var) + (list derived-ns derived-var)) + ;; deftest foo (less usual, but quite frequent): + (when (cider--test-var-p derived-ns v) + (list derived-ns v))))))))) + +(defun cider-test-run-test () + "Run the test at point. +The test ns/var exist as text properties on report items and on highlighted +failed/erred test definitions. + +When not found, a test definition at point +or in a corresponding test namespace is searched." + (interactive) + (let* ((found (cider--extract-test-var-at-point)) + (found-ns (car found)) + (found-var (cadr found))) + (if (not found-var) + (message "No test found at point") + (cider-test-update-last-test found-ns (list found-var)) + (cider-test-execute found-ns (list found-var))))) + +(defun cider-test-rerun-test () + "Re-run the test that was previously ran." + (interactive) + (if (and cider-test-last-test-ns cider-test-last-test-var) + (cider-test-execute cider-test-last-test-ns cider-test-last-test-var) + (user-error "No test to re-run"))) + +;;; Auto-test mode +(defun cider--test-silently () + "Like `cider-test-run-tests', but with less feedback. +Only notify the user if there actually were any tests to run and only after +the results are received." + (when (cider-connected-p) + (let ((cider-auto-select-test-report-buffer nil) + (cider-test-show-report-on-success nil)) + (cider-test-run-ns-tests nil 'soft)))) + +;;;###autoload +(define-minor-mode cider-auto-test-mode + "Toggle automatic testing of Clojure files. + +When enabled this reruns tests every time a Clojure file is loaded. +Only runs tests corresponding to the loaded file's namespace and does +nothing if no tests are defined or if the file failed to load." + :init-value nil :lighter (cider-mode " Test") :keymap nil + :global t + (if cider-auto-test-mode + (add-hook 'cider-file-loaded-hook #'cider--test-silently) + (remove-hook 'cider-file-loaded-hook #'cider--test-silently))) + +(provide 'cider-test) + +;;; cider-test.el ends here diff --git a/elpa/cider-20241203.1607/cider-tracing.el b/elpa/cider-20241203.1607/cider-tracing.el new file mode 100644 index 00000000..f466fc8f --- /dev/null +++ b/elpa/cider-20241203.1607/cider-tracing.el @@ -0,0 +1,90 @@ +;;; cider-tracing.el --- Executing tracing functionality -*- lexical-binding: t -*- + +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Bozhidar Batsov +;; Artur Malabarba + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; A couple of commands for tracing the execution of functions. + +;;; Code: + +(require 'cider-client) +(require 'cider-common) ; for `cider-prompt-for-symbol-function' +(require 'cider-util) ; for `cider-propertize' +(require 'cider-connection) ; for `cider-map-repls' +(require 'nrepl-dict) + +(defun cider-sync-request:toggle-trace-var (sym) + "Toggle var tracing for SYM." + (thread-first `("op" "toggle-trace-var" + "ns" ,(cider-current-ns) + "sym" ,sym) + (cider-nrepl-send-sync-request))) + +(defun cider--toggle-trace-var (sym) + "Toggle var tracing for SYM." + (let* ((trace-response (cider-sync-request:toggle-trace-var sym)) + (var-name (nrepl-dict-get trace-response "var-name")) + (var-status (nrepl-dict-get trace-response "var-status"))) + (pcase var-status + ("not-found" (error "Var %s not found" (cider-propertize sym 'fn))) + ("not-traceable" (error "Var %s can't be traced because it's not bound to a function" (cider-propertize var-name 'fn))) + (_ (message "Var %s %s" (cider-propertize var-name 'fn) var-status))))) + +;;;###autoload +(defun cider-toggle-trace-var (arg) + "Toggle var tracing. +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates." + (interactive "P") + (cider-ensure-op-supported "toggle-trace-var") + (funcall (cider-prompt-for-symbol-function arg) + "Toggle trace for var" + #'cider--toggle-trace-var)) + +(defun cider-sync-request:toggle-trace-ns (ns) + "Toggle namespace tracing for NS." + (thread-first `("op" "toggle-trace-ns" + "ns" ,ns) + (cider-nrepl-send-sync-request))) + +;;;###autoload +(defun cider-toggle-trace-ns (query) + "Toggle ns tracing. +Defaults to the current ns. With prefix arg QUERY, prompts for a ns." + (interactive "P") + (cider-map-repls :clj-strict + (lambda (conn) + (with-current-buffer conn + (cider-ensure-op-supported "toggle-trace-ns") + (let ((ns (if query + (completing-read "Toggle trace for ns: " + (cider-sync-request:ns-list)) + (cider-current-ns)))) + (let* ((trace-response (cider-sync-request:toggle-trace-ns ns)) + (ns-status (nrepl-dict-get trace-response "ns-status"))) + (pcase ns-status + ("not-found" (error "Namespace %s not found" (cider-propertize ns 'ns))) + (_ (message "Namespace %s %s" (cider-propertize ns 'ns) ns-status))))))))) + +(provide 'cider-tracing) +;;; cider-tracing.el ends here diff --git a/elpa/cider-20241203.1607/cider-util.el b/elpa/cider-20241203.1607/cider-util.el new file mode 100644 index 00000000..8316af96 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-util.el @@ -0,0 +1,831 @@ +;; cider-util.el --- Common utility functions that don't belong anywhere else -*- lexical-binding: t -*- + +;; Copyright © 2012-2024 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Common utility functions that don't belong anywhere else. + +;;; Code: + +;; Built-ins +(require 'ansi-color) +(require 'color) +(require 'seq) +(require 'subr-x) +(require 'thingatpt) + +;; clojure-mode and CIDER +(require 'clojure-mode) + +(defalias 'cider-pop-back #'pop-tag-mark) + +(defcustom cider-font-lock-max-length 10000 + "The max length of strings to fontify in `cider-font-lock-as'. + +Setting this to nil removes the fontification restriction." + :group 'cider + :type 'boolean + :package-version '(cider . "0.10.0")) + +(defun cider-util--hash-keys (hashtable) + "Return a list of keys in HASHTABLE." + (let ((keys '())) + (maphash (lambda (k _v) (setq keys (cons k keys))) hashtable) + keys)) + +(defun cider-clojure-major-mode-p () + "Return non-nil if current buffer is managed by a Clojure major mode." + (derived-mode-p 'clojure-mode 'clojure-ts-mode)) + +(defun cider-clojurescript-major-mode-p () + "Return non-nil if current buffer is managed by a ClojureScript major mode." + (derived-mode-p 'clojurescript-mode 'clojure-ts-clojurescript-mode)) + +(defun cider-clojurec-major-mode-p () + "Return non-nil if current buffer is managed by a ClojureC major mode." + (derived-mode-p 'clojurec-mode 'clojure-ts-clojurec-mode)) + +(defun cider-util--clojure-buffers () + "Return a list of all existing `clojure-mode' buffers." + (seq-filter + (lambda (buffer) + (with-current-buffer buffer + (cider-clojure-major-mode-p))) + (buffer-list))) + +(defun cider-current-dir () + "Return the directory of the current buffer." + (if buffer-file-name + (file-name-directory buffer-file-name) + default-directory)) + +(defun cider-in-string-p () + "Return non-nil if point is in a string." + (let ((beg (save-excursion (beginning-of-defun-raw) (point)))) + (nth 3 (parse-partial-sexp beg (point))))) + +(defun cider-in-comment-p () + "Return non-nil if point is in a comment." + (let ((beg (save-excursion (beginning-of-defun-raw) (point)))) + (nth 4 (parse-partial-sexp beg (point))))) + +(defun cider--tooling-file-p (file-name) + "Return t if FILE-NAME is not a 'real' source file. +Currently, only check if the relative file name starts with 'form-init' +which nREPL uses for temporary evaluation file names." + (let ((fname (file-name-nondirectory file-name))) + (string-match-p "^form-init" fname))) + +(defun cider--cljc-buffer-p (&optional buffer) + "Return non-nil if the current buffer is visiting a cljc file. + +If BUFFER is provided act on that buffer instead." + (with-current-buffer (or buffer (current-buffer)) + (or (cider-clojurec-major-mode-p)))) + + +;;; Thing at point + +(defun cider--text-or-limits (bounds start end) + "Returns the substring or the bounds of text. +If BOUNDS is non-nil, returns the list (START END) of character +positions. Else returns the substring from START to END." + (funcall (if bounds #'list #'buffer-substring-no-properties) + start end)) + +(defun cider-defun-at-point (&optional bounds) + "Return the text of the top level sexp at point. +If BOUNDS is non-nil, return a list of its starting and ending position +instead." + (save-excursion + (save-match-data + (if (derived-mode-p 'cider-repl-mode) + (goto-char (point-max)) ;; in repls, end-of-defun won't work, so we perform the closest reasonable thing + (end-of-defun)) + (let ((end (point))) + (clojure-backward-logical-sexp 1) + (cider--text-or-limits bounds (point) end))))) + +(defun cider-get-ns-name () + "Calls `clojure-find-ns', suppressing any errors. +Therefore, possibly returns nil, +so please handle that value from any callsites." + (clojure-find-ns :supress-errors)) + +(defun cider-ns-form () + "Retrieve the ns form." + (when (cider-get-ns-name) + (save-excursion + (goto-char (match-beginning 0)) + (cider-defun-at-point)))) + +(defun cider-symbol-at-point (&optional look-back) + "Return the name of the symbol at point, otherwise nil. +Ignores the REPL prompt. If LOOK-BACK is non-nil, move backwards trying to +find a symbol if there isn't one at point. +Does not strip the : from keywords, nor attempt to expand :: auto-resolved +keywords." + (or (when-let* ((str (thing-at-point 'symbol))) + (unless (text-property-any 0 (length str) 'field 'cider-repl-prompt str) + ;; remove font-locking + (setq str (substring-no-properties str)) + (if (member str '("." "..")) + str + ;; Remove prefix quotes, and trailing . from constructors like Record. + (thread-last + str + ;; constructors (Foo.) + (string-remove-suffix ".") + ;; quoted symbols ('sym) + (string-remove-prefix "'") + ;; var references (#'inc 2) + (string-remove-prefix "#'"))))) + (when look-back + (save-excursion + (ignore-errors + (when (looking-at "(") + (forward-char 1)) + (while (not (looking-at "\\sw\\|\\s_\\|\\`")) + (forward-sexp -1))) + (cider-symbol-at-point))))) + + +;;; sexp navigation +(defun cider-sexp-at-point (&optional bounds) + "Return the sexp at point as a string, otherwise nil. +If BOUNDS is non-nil, return a list of its starting and ending position +instead." + (when-let* ((b (or (and (equal (char-after) ?\() + (member (char-before) '(?\' ?\, ?\@)) + ;; hide stuff before ( to avoid quirks with '( etc. + (save-restriction + (narrow-to-region (point) (point-max)) + (bounds-of-thing-at-point 'sexp))) + (bounds-of-thing-at-point 'sexp)))) + (funcall (if bounds #'list #'buffer-substring-no-properties) + (car b) (cdr b)))) + +(defun cider-list-at-point (&optional bounds) + "Return the list (compound form) at point as a string, otherwise nil. +If BOUNDS is non-nil, return a list of its starting and ending position +instead." + (when-let* ((b (or (and (equal (char-after) ?\() + (member (char-before) '(?\' ?\, ?\@)) + ;; hide stuff before ( to avoid quirks with '( etc. + (save-restriction + (narrow-to-region (point) (point-max)) + (bounds-of-thing-at-point 'list))) + (bounds-of-thing-at-point 'list)))) + (funcall (if bounds #'list #'buffer-substring-no-properties) + (car b) (cdr b)))) + +(defun cider-last-sexp (&optional bounds) + "Return the sexp preceding the point. +If BOUNDS is non-nil, return a list of its starting and ending position +instead." + (apply (if bounds #'list #'buffer-substring-no-properties) + (save-excursion + (clojure-backward-logical-sexp 1) + (list (point) + (progn (clojure-forward-logical-sexp 1) + (point)))))) + +(defun cider-start-of-next-sexp (&optional skip) + "Move to the start of the next sexp. +Skip any non-logical sexps like ^metadata or #reader macros. +If SKIP is an integer, also skip that many logical sexps first. +Can only error if SKIP is non-nil." + (while (clojure--looking-at-non-logical-sexp) + (forward-sexp 1)) + (when (and skip (> skip 0)) + (dotimes (_ skip) + (forward-sexp 1) + (cider-start-of-next-sexp)))) + +(defun cider-second-sexp-in-list () + "Return the second sexp in the list at point." + (condition-case nil + (save-excursion + (backward-up-list) + (forward-char) + (forward-sexp 2) + (cider-sexp-at-point)) + (error nil))) + +;;; Text properties + +(defun cider-maybe-intern (name) + "If NAME is a symbol, return it; otherwise, intern it." + (if (symbolp name) name (intern name))) + +(defun cider-intern-keys (plist) + "Copy PLIST, with any non-symbol keys replaced with symbols." + (when plist + (cons (cider-maybe-intern (pop plist)) + (cons (pop plist) (cider-intern-keys plist))))) + +(defmacro cider-propertize-region (props &rest body) + "Execute BODY and add PROPS to all the inserted text. +More precisely, PROPS are added to the region between the point's +positions before and after executing BODY." + (declare (indent 1) + (debug (sexp body))) + (let ((start (make-symbol "start"))) + `(let ((,start (point))) + (prog1 (progn ,@body) + (add-text-properties ,start (point) ,props))))) + +(put 'cider-propertize-region 'lisp-indent-function 1) + +(defun cider-property-bounds (prop) + "Return the the positions of the previous and next change to PROP. +PROP is the name of a text property." + (let ((end (next-single-char-property-change (point) prop))) + (list (previous-single-char-property-change end prop) end))) + +(defun cider-insert (text &optional face break more-text) + "Insert TEXT with FACE, optionally followed by a line BREAK and MORE-TEXT." + (insert (if face (propertize text 'font-lock-face face) text)) + (when more-text (insert more-text)) + (when break (insert "\n"))) + + +;;; Hooks + +(defun cider-run-chained-hook (hook arg) + "Like `run-hook-with-args' but pass intermediate return values through. +HOOK is a name of a hook (a symbol). You can use `add-hook' or +`remove-hook' to add functions to this variable. ARG is passed to first +function. Its return value is passed to the second function and so forth +till all functions are called or one of them returns nil. Return the value +return by the last called function." + (let ((functions (copy-sequence (symbol-value hook)))) + (while (and functions arg) + (if (eq (car functions) t) + ;; global value of the hook + (let ((functions (default-value hook))) + (while (and functions arg) + (setq arg (funcall (car functions) arg)) + (setq functions (cdr functions)))) + (setq arg (funcall (car functions) arg))) + (setq functions (cdr functions))) + arg)) + + +;;; Font lock + +(defvar cider--mode-buffers nil + "A list of buffers for different major modes.") + +(defun cider--make-buffer-for-mode (mode) + "Return a temp buffer using `major-mode' MODE. +This buffer is not designed to display anything to the user. For that, use +`cider-make-popup-buffer' instead." + (setq cider--mode-buffers (seq-filter (lambda (x) (buffer-live-p (cdr x))) + cider--mode-buffers)) + (or (cdr (assq mode cider--mode-buffers)) + (let ((b (generate-new-buffer (format " *cider-temp %s*" mode)))) + (push (cons mode b) cider--mode-buffers) + (with-current-buffer b + ;; suppress major mode hooks as we care only about their font-locking + ;; otherwise modes like whitespace-mode and paredit might interfere + (setq-local delay-mode-hooks t) + (setq delayed-mode-hooks nil) + (funcall mode)) + b))) + +(defun cider-ansi-color-string-p (string) + "Return non-nil if STRING is an ANSI string." + (string-match "^\\[" string)) + +(defun cider-font-lock-as (mode string) + "Use MODE to font-lock the STRING." + (let ((string (if (cider-ansi-color-string-p string) + (substring-no-properties (ansi-color-apply string)) + string))) + (if (or (null cider-font-lock-max-length) + (< (length string) cider-font-lock-max-length)) + (with-current-buffer (cider--make-buffer-for-mode mode) + (erase-buffer) + (insert string) + ;; don't try to font-lock unbalanced Clojure code + (when (eq mode 'clojure-mode) + (check-parens)) + (font-lock-fontify-region (point-min) (point-max)) + (buffer-string)) + string))) + +(defun cider-font-lock-region-as (mode beg end &optional buffer) + "Use MODE to font-lock text between BEG and END. + +Unless you specify a BUFFER it will default to the current one." + (with-current-buffer (or buffer (current-buffer)) + (let ((text (buffer-substring beg end))) + (delete-region beg end) + (goto-char beg) + (insert (cider-font-lock-as mode text))))) + +(defun cider-font-lock-as-clojure (string) + "Font-lock STRING as Clojure code." + ;; If something goes wrong (e.g. the code is not balanced) + ;; we simply return the string. + (condition-case nil + (cider-font-lock-as 'clojure-mode string) + (error string))) + +;; Button allowing use of `font-lock-face', ignoring any inherited `face' +(define-button-type 'cider-plain-button + 'face nil) + +(defun cider-add-face (regexp face &optional foreground-only sub-expr object) + "Propertize all occurrences of REGEXP with FACE. +If FOREGROUND-ONLY is non-nil, change only the foreground of matched +regions. SUB-EXPR is a sub-expression of REGEXP to be +propertized (defaults to 0). OBJECT is an object to be +propertized (defaults to current buffer)." + (setq sub-expr (or sub-expr 0)) + (when (and regexp face) + (let ((beg 0) + (end 0)) + (with-current-buffer (or (and (bufferp object) object) + (current-buffer)) + (while (if (stringp object) + (string-match regexp object end) + (re-search-forward regexp nil t)) + (setq beg (match-beginning sub-expr) + end (match-end sub-expr)) + (if foreground-only + (let ((face-spec (list (cons 'foreground-color + (face-attribute face :foreground nil t))))) + (font-lock-prepend-text-property beg end 'face face-spec object)) + (put-text-property beg end 'face face object))))))) + + +;;; Colors + +(defun cider-scale-background-color () + "Scale the current background color to get a slighted muted version." + (let ((color (frame-parameter nil 'background-color)) + (darkp (eq (frame-parameter nil 'background-mode) 'dark))) + (unless (equal "unspecified-bg" color) + (color-lighten-name color (if darkp 5 -5))))) + +(defvar cider-version) +(defvar cider-codename) + +(defun cider--pkg-version () + "Extract CIDER's package version from its package metadata." + ;; Use `cond' below to avoid a compiler unused return value warning + ;; when `package-get-version' returns nil. See #3181. + ;; FIXME: Inline the logic from package-get-version and adapt it + (cond ((fboundp 'package-get-version) + (package-get-version)))) + +(defun cider--version () + "Retrieve CIDER's version. +A codename is added to stable versions." + (if (string-match-p "-snapshot" cider-version) + (let ((pkg-version (cider--pkg-version))) + (if pkg-version + ;; snapshot versions include the MELPA package version + (format "%s (package: %s)" cider-version pkg-version) + cider-version)) + ;; stable versions include the codename of the release + (format "%s (%s)" cider-version cider-codename))) + + +;;; Strings + +(defun cider-join-into-alist (candidates &optional separator) + "Make an alist from CANDIDATES. +The keys are the elements joined with SEPARATOR and values are the original +elements. Useful for `completing-read' when candidates are complex +objects." + (mapcar (lambda (el) + (if (listp el) + (cons (string-join el (or separator ":")) el) + (cons el el))) + candidates)) + +(defun cider-add-to-alist (symbol car cadr) + "Add '(CAR CADR) to the alist stored in SYMBOL. +If CAR already corresponds to an entry in the alist, destructively replace +the entry's second element with CADR. + +This can be used, for instance, to update the version of an injected +plugin or dependency with: + (cider-add-to-alist 'cider-jack-in-lein-plugins + \"plugin/artifact-name\" \"THE-NEW-VERSION\")" + (let ((alist (symbol-value symbol))) + (if-let* ((cons (assoc car alist))) + (setcdr cons (list cadr)) + (set symbol (cons (list car cadr) alist))))) + +(defun cider-namespace-qualified-p (sym) + "Return t if SYM is namespace-qualified." + (string-match-p "[^/]+/" sym)) + +(defvar cider-version) + +(defconst cider-manual-url "https://docs.cider.mx/cider/%s" + "The URL to CIDER's manual.") + +(defun cider-version-sans-patch () + "Return the version sans that patch." + (string-join (seq-take (split-string cider-version "\\.") 2) ".")) + +(defun cider--manual-version () + "Convert the version to a ReadTheDocs-friendly version." + (if (string-match-p "-snapshot" cider-version) + "" + (concat (cider-version-sans-patch) "/"))) + +(defun cider-manual-url () + "The CIDER manual's url." + (format cider-manual-url (cider--manual-version))) + +;;;###autoload +(defun cider-view-manual () + "View the manual in your default browser." + (interactive) + (browse-url (cider-manual-url))) + +(defun cider--manual-button (label section-id) + "Return a button string that links to the online manual. +LABEL is the displayed string, and SECTION-ID is where it points +to." + (with-temp-buffer + (insert-text-button + label + 'follow-link t + 'action (lambda (&rest _) (interactive) + (browse-url (concat (cider-manual-url) + section-id)))) + (buffer-string))) + +(defconst cider-refcard-url "https://github.com/clojure-emacs/cider/raw/%s/refcard/cider-refcard.pdf" + "The URL to CIDER's refcard.") + +(defun cider--github-version () + "Convert the version to a GitHub-friendly version." + (if (string-match-p "-snapshot" cider-version) + "master" + (concat "v" cider-version))) + +(defun cider-refcard-url () + "The CIDER manual's url." + (format cider-refcard-url (cider--github-version))) + +(defun cider-view-refcard () + "View the refcard in your default browser." + (interactive) + (browse-url (cider-refcard-url))) + +(defconst cider-report-bug-url "https://github.com/clojure-emacs/cider/issues/new" + "The URL to report a CIDER issue.") + +(defun cider-report-bug () + "Report a bug in your default browser." + (interactive) + (browse-url cider-report-bug-url)) + +(defun cider--project-name (dir) + "Extracts a project name from DIR, possibly nil. +The project name is the final component of DIR if not nil." + (when dir + (file-name-nondirectory (directory-file-name dir)))) + +;;; Vectors +(defun cider--deep-vector-to-list (x) + "Convert vectors in X to lists. +If X is a sequence, return a list of `cider--deep-vector-to-list' applied to +each of its elements. +Any other value is just returned." + (if (sequencep x) + (mapcar #'cider--deep-vector-to-list x) + x)) + + +;;; Help mode + +;; Same as https://github.com/emacs-mirror/emacs/blob/86d083438dba60dc00e9e96414bf7e832720c05a/lisp/help-mode.el#L355 +;; the original function uses some buffer local variables, but the buffer used +;; is not configurable. It defaults to (help-buffer) + +(defun cider--help-setup-xref (item interactive-p buffer) + "Invoked from commands using the \"*Help*\" buffer to install some xref info. + +ITEM is a (FUNCTION . ARGS) pair appropriate for recreating the help +buffer after following a reference. INTERACTIVE-P is non-nil if the +calling command was invoked interactively. In this case the stack of +items for help buffer \"back\" buttons is cleared. Use BUFFER for the +buffer local variables. + +This should be called very early, before the output buffer is cleared, +because we want to record the \"previous\" position of point so we can +restore it properly when going back." + (with-current-buffer buffer + (when help-xref-stack-item + (push (cons (point) help-xref-stack-item) help-xref-stack) + (setq help-xref-forward-stack nil)) + (when interactive-p + (let ((tail (nthcdr 10 help-xref-stack))) + ;; Truncate the stack. + (if tail (setcdr tail nil)))) + (setq help-xref-stack-item item))) + +(defcustom cider-doc-xref-regexp + (eval-and-compile + (rx-to-string + `(or (: "`" (group-n 1 (+ (not space))) "`") ; `var` + (: "[[" (group-n 1 (+ (not space))) "]]") ; [[var]] + (group-n 1 (regexp ,clojure--sym-regexp) "/" (regexp ,clojure--sym-regexp))))) ;; Fully qualified + "The regexp used to search Clojure vars in doc buffers." + :type 'regexp + :safe #'stringp + :group 'cider + :package-version '(cider . "0.13.0")) + +(defun cider--find-symbol-xref () + "Parse and return the first clojure symbol in current buffer. +Use `cider-doc-xref-regexp' for the search. Set match data and return a +string of the Clojure symbol. Return nil if there are no more matches in +the buffer." + (when (re-search-forward cider-doc-xref-regexp nil t) + (match-string 1))) + +(declare-function cider-doc-lookup "cider-doc") +(declare-function cider--eldoc-remove-dot "cider-eldoc") + +;; Taken from: https://github.com/emacs-mirror/emacs/blob/65c8c7cb96c14f9c6accd03cc8851b5a3459049e/lisp/help-mode.el#L551-L565 +(defun cider--make-back-forward-xrefs (&optional buffer) + "Insert special references `back' and `forward', as in `help-make-xrefs'. + +Optional argument BUFFER is the buffer in which to insert references. +Default is current buffer." + (with-current-buffer (or buffer (current-buffer)) + (insert "\n") + (when (or help-xref-stack help-xref-forward-stack) + (insert "\n")) + ;; Make a back-reference in this buffer if appropriate. + (when help-xref-stack + (help-insert-xref-button help-back-label 'help-back + (current-buffer))) + ;; Make a forward-reference in this buffer if appropriate. + (when help-xref-forward-stack + (when help-xref-stack + (insert "\t")) + (help-insert-xref-button help-forward-label 'help-forward + (current-buffer))) + (when (or help-xref-stack help-xref-forward-stack) + (insert "\n")))) + +;; Similar to https://github.com/emacs-mirror/emacs/blob/65c8c7cb96c14f9c6accd03cc8851b5a3459049e/lisp/help-mode.el#L404 +(defun cider--doc-make-xrefs () + "Parse and hyperlink documentation cross-references in current buffer. +Find cross-reference information in a buffer and activate such cross +references for selection with `help-xref'. Cross-references are parsed +using `cider--find-symbol-xref'. + +Special references `back' and `forward' are made to go back and forth +through a stack of help buffers. Variables `help-back-label' and +`help-forward-label' specify the text for that." + (interactive "b") + + ;; parse the docstring and create xrefs for symbols + (save-excursion + (goto-char (point-min)) + (let ((symbol)) + (while (setq symbol (cider--find-symbol-xref)) + (replace-match "") + (insert-text-button symbol + 'type 'help-xref + 'help-function (apply-partially #'cider-doc-lookup + (cider--eldoc-remove-dot symbol)))))) + (cider--make-back-forward-xrefs)) + + +;;; Words of inspiration +(defun cider-user-first-name () + "Find the current user's first name." + (let ((name (if (string= (user-full-name) "") + (user-login-name) + (user-full-name)))) + (string-match "^[^ ]*" name) + (capitalize (match-string 0 name)))) + +(defvar cider-words-of-inspiration + `("The best way to predict the future is to invent it. -Alan Kay" + "A point of view is worth 80 IQ points. -Alan Kay" + "Lisp isn't a language, it's a building material. -Alan Kay" + "Simple things should be simple, complex things should be possible. -Alan Kay" + "Everything should be as simple as possible, but not simpler. -Albert Einstein" + "Measuring programming progress by lines of code is like measuring aircraft building progress by weight. -Bill Gates" + "Controlling complexity is the essence of computer programming. -Brian Kernighan" + "The unavoidable price of reliability is simplicity. -C.A.R. Hoare" + "You're bound to be unhappy if you optimize everything. -Donald Knuth" + "Simplicity is prerequisite for reliability. -Edsger W. Dijkstra" + "Elegance is not a dispensable luxury but a quality that decides between success and failure. -Edsger W. Dijkstra" + "Deleted code is debugged code. -Jeff Sickel" + "The key to performance is elegance, not battalions of special cases. -Jon Bentley and Doug McIlroy" + "First, solve the problem. Then, write the code. -John Johnson" + "Simplicity is the ultimate sophistication. -Leonardo da Vinci" + "Programming is not about typing... it's about thinking. -Rich Hickey" + "Design is about pulling things apart. -Rich Hickey" + "Programmers know the benefits of everything and the tradeoffs of nothing. -Rich Hickey" + "Code never lies, comments sometimes do. -Ron Jeffries" + "The true delight is in the finding out rather than in the knowing. -Isaac Asimov" + "If paredit is not for you, then you need to become the sort of person that paredit is for. -Phil Hagelberg" + "Express Yourself. -Madonna" + "Put on your red shoes and dance the blues. -David Bowie" + "Do. Or do not. There is no try. -Yoda" + "The enjoyment of one's tools is an essential ingredient of successful work. -Donald E. Knuth" + "Not all those who wander are lost. -J.R.R. Tolkien" + "The best way to learn is to do. -P.R. Halmos" + "If you wish to make an apple pie from scratch, you must first invent the universe. -Carl Sagan" + "Learn the rules like a pro, so you can break them like an artist. -Pablo Picasso" + "The only way of discovering the limits of the possible is to venture a little way past them into the impossible. -Arthur C. Clarke" + "Don't wish it were easier. Wish you were better. -Jim Rohn" + "One chord is fine. Two chords is pushing it. Three chords and you're into jazz. -Lou Reed" + "We are all apprentices in a craft where no one ever becomes a master. -Ernest Hemingway" + "A designer knows he has achieved perfection not when there is nothing left to add, but when there is nothing left to take away. -Antoine de Saint-Exupery" + "Clojure isn't a language, it's a building material." + "Think big!" + "Think bold!" + "Think fun!" + "Code big!" + "Code bold!" + "Code fun!" + "Take this REPL, fellow hacker, and may it serve you well." + "Let the hacking commence!" + "Hacks and glory await!" + "Hack and be merry!" + "Your hacking starts... NOW!" + "May the Source be with you!" + "May the Source shine upon thy REPL!" + "Code long and prosper!" + "Happy hacking!" + "nREPL server is up, CIDER REPL is online!" + "CIDER REPL operational!" + "Your imagination is the only limit to what you can do with this REPL!" + "This REPL is yours to command!" + "Fame is but a hack away!" + "The REPL is not enough, but it is such a perfect place to start..." + "Keep on codin' in the free world!" + "What we do in the REPL echoes in eternity!" + "Evaluating is believing." + "To infinity... and beyond." + "Showtime!" + "Unfortunately, no one can be told what CIDER is. You have to figure this out yourself." + "Procure a bottle of cider to achieve optimum programming results." + "In parentheses we trust!" + "Write you some Clojure for Great Good!" + "Oh, what a day... what a lovely day!" + "What a day! What cannot be accomplished on such a splendid day!" + "Home is where your REPL is." + "The worst day programming is better than the best day working." + "The only thing worse than a rebel without a cause is a REPL without a clause." + "In the absence of parentheses, chaos prevails." + "One REPL to rule them all, One REPL to find them, One REPL to bring them all, and in parentheses bind them!" + "A blank REPL promotes creativity." + "A blank REPL is infinitely better than a blank cheque." + "May your functions be pure, your code concise and your programs a joy to behold!" + ,(format "%s, I've a feeling we're not in Kansas anymore." + (cider-user-first-name)) + ,(format "%s, this could be the start of a beautiful program." + (cider-user-first-name))) + "Scientifically-proven optimal words of hackerish encouragement.") + +(defun cider-random-words-of-inspiration () + "Select a random entry from `cider-words-of-inspiration'." + (nth (random (length cider-words-of-inspiration)) + cider-words-of-inspiration)) + +(defun cider-inspire-me () + "Display a random inspiration message." + (interactive) + (message (cider-random-words-of-inspiration))) + +(defvar cider-tips + '("Press <\\[cider-connect]> to connect to a running nREPL server." + "Press <\\[cider-quit]> to quit the current connection." + "Press <\\[cider-view-manual]> to view CIDER's manual." + "Press <\\[cider-view-refcard]> to view CIDER's refcard." + "Press <\\[describe-mode]> to see a list of the keybindings available (this will work in every Emacs buffer)." + "Press <\\[cider-repl-handle-shortcut]> to quickly invoke some REPL command." + "Press <\\[cider-switch-to-last-clojure-buffer]> to switch between the REPL and a Clojure source buffer." + "Press <\\[cider-doc]> to view the documentation for something (e.g. a var, a Java method)." + "Press <\\[cider-find-resource]> to find a resource on the classpath." + "Press <\\[cider-find-var]> to jump to the source of something (e.g. a var, a Java method)." + "Press <\\[cider-selector]> to quickly select a CIDER buffer." + "Press <\\[cider-test-run-ns-tests]> to run the tests for the current namespace." + "Press <\\[cider-test-run-loaded-tests]> to run all loaded tests." + "Press <\\[cider-test-run-project-tests]> to run all tests for the current project." + "Press <\\[cider-apropos]> to look for a symbol by some search string." + "Press <\\[cider-apropos-documentation]> to look for a symbol that has some string in its docstring." + "Press <\\[cider-eval-defun-at-point]> to eval the top-level form at point." + "Press <\\[cider-eval-dwim]> to eval to run cider-eval-region if a region is active, and cider-eval-defun-at-point otherwise." + "Press <\\[cider-eval-defun-up-to-point]> to eval the top-level form up to the point." + "Press <\\[cider-eval-sexp-up-to-point]> to eval the current form up to the point." + "Press <\\[cider-eval-sexp-at-point]> to eval the current form around the point." + "Press <\\[cider-eval-sexp-at-point-in-context]> to eval the current form around the point in a user-provided context." + "Press <\\[cider-eval-buffer]> to eval the entire source buffer." + "Press <\\[cider-scratch]> to create a Clojure scratchpad. Pretty handy for prototyping." + "Press <\\[cider-read-and-eval]> to evaluate some Clojure expression directly in the minibuffer." + "Press <\\[cider-drink-a-sip]> to get more CIDER tips." + "Press <\\[cider-browse-ns-all]> to start CIDER's namespace browser." + "Press <\\[cider-classpath]> to start CIDER's classpath browser." + "Press <\\[cider-repl-history]> to start CIDER's REPL input history browser." + "Press <\\[cider-macroexpand-1]> to expand the preceding macro." + "Press <\\[cider-inspect]> to inspect the preceding expression's result." + "Press to inspect the defun at point's result." + "Press to read Clojure code from the minibuffer and inspect its result." + "Press <\\[cider-ns-refresh]> to reload modified and unloaded namespaces." + "You can define Clojure functions to be called before and after `cider-ns-refresh' (see `cider-ns-refresh-before-fn' and `cider-ns-refresh-after-fn'." + "Press <\\[cider-describe-connection]> to view information about the connection." + "Press <\\[cider-undef]> to undefine a symbol in the current namespace." + "Press <\\[cider-interrupt]> to interrupt an ongoing evaluation." + "Use to see every possible setting you can customize." + "Use to see every possible REPL setting you can customize." + "Enable `eldoc-mode' to display function & method signatures in the minibuffer." + "Enable `cider-enlighten-mode' to display the locals of a function when it's executed." + "Use <\\[cider-close-ancillary-buffers]> to close all ancillary buffers created by CIDER (e.g. *cider-doc*)." + "Exploring CIDER's menu-bar entries is a great way to discover features." + "Keep in mind that some commands don't have a keybinding by default. Explore CIDER!" + "Tweak `cider-repl-prompt-function' to customize your REPL prompt." + "Tweak `cider-eldoc-ns-function' to customize the way namespaces are displayed by eldoc." + "For no middleware, low-tech and reliable namespace reloading use <\\[cider-ns-reload]>." + "Press <\\[cider-load-buffer-and-switch-to-repl-buffer]> to load the current buffer and switch to the REPL buffer afterwards.") + "Some handy CIDER tips." + ) + +(defun cider-random-tip () + "Select a random tip from `cider-tips'." + (substitute-command-keys (nth (random (length cider-tips)) cider-tips))) + +(defun cider-drink-a-sip () + "Show a random tip." + (interactive) + (message (cider-random-tip))) + +(defun cider-column-number-at-pos (pos) + "Analog to `line-number-at-pos'. +Return buffer column number at position POS." + (save-excursion + (goto-char pos) + ;; we have to adjust the column number by 1 to account for the fact + ;; that Emacs starts counting columns from 0 and Clojure from 1 + (1+ (current-column)))) + +(defun cider-propertize (text kind) + "Propertize TEXT as KIND. +KIND can be the symbols `ns', `var', `emph', `fn', or a face name." + (propertize text 'face (pcase kind + (`fn 'font-lock-function-name-face) + (`method 'font-lock-function-name-face) + (`special-form 'font-lock-keyword-face) + (`macro 'font-lock-keyword-face) + (`var 'font-lock-variable-name-face) + (`ns 'font-lock-type-face) + (`emph 'font-lock-keyword-face) + (face face)))) + +(defun cider--menu-add-help-strings (menu-list) + "Add a :help entries to items in MENU-LIST." + (mapcar (lambda (x) + (cond + ((listp x) (cider--menu-add-help-strings x)) + ((and (vectorp x) + (not (plist-get (append x nil) :help)) + (functionp (elt x 1))) + (vconcat x `[:help ,(documentation (elt x 1))])) + (t x))) + menu-list)) + +(provide 'cider-util) + +;;; cider-util.el ends here diff --git a/elpa/cider-20241203.1607/cider-xref-backend.el b/elpa/cider-20241203.1607/cider-xref-backend.el new file mode 100644 index 00000000..4b3ca4b0 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-xref-backend.el @@ -0,0 +1,166 @@ +;;; cider-xref-backend.el --- CIDER's backend for Emacs' xref functionality -*- lexical-binding: t -*- + +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Bozhidar Batsov +;; Artur Malabarba + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; CIDER's backend for Emacs' xref functionality. + +;;; Code: + +(require 'cider-client) +(require 'cider-common) +(require 'cider-doc) ;; for cider--abbreviate-file-protocol +(require 'cider-resolve) + +(require 'seq) +(require 'thingatpt) + +;;; xref integration +;; +;; xref.el was introduced in Emacs 25.1. +;; CIDER's xref backend was added in CIDER 1.2. +(defun cider--xref-backend () + "Used for xref integration." + ;; Check if `cider-nrepl` middleware is loaded. Allows fallback to other xref + ;; backends, if cider-nrepl is not loaded. + (when (or + ;; the main requirement: + (cider-nrepl-op-supported-p "ns-path" nil 'skip-ensure) + ;; the fallback, used for bare nrepl or babashka integrations: + (cider-nrepl-op-supported-p "lookup" nil 'skip-ensure)) + 'cider)) + +(cl-defmethod xref-backend-identifier-at-point ((_backend (eql cider))) + "Return the relevant identifier at point." + (cider-symbol-at-point 'look-back)) + +(defun cider--xref-extract-file (dict) + "Extracts the best possible file path from DICT." + (or (nrepl-dict-get dict "file-url") ;; This is the primary choice, it has a protocol and indicates an absolute path + ;; fall back in case it was absent or we're running an older cider-nrepl: + (nrepl-dict-get dict "file"))) + +(defun cider--xref-extract-friendly-file-name (dict) + "Extracts the best possible friendly file name from DICT. +These are used for presentation purposes." + (let* ((s (or (nrepl-dict-get dict "file") ;; these are shorter and relative, which look better in UIs. + (nrepl-dict-get dict "file-url"))) + (s (cider--abbreviate-file-protocol s)) + (line (nrepl-dict-get dict "line")) + (column (nrepl-dict-get dict "column"))) + (concat s + (when line + ":") + (when line + (prin1-to-string line)) + (when (and line column) + ":") + (when column + (prin1-to-string column))))) + +(defun cider--var-to-xref-location (var) + "Get location of definition of VAR." + (when-let* ((info (cider-var-info var)) + (line (nrepl-dict-get info "line")) + (file (cider--xref-extract-file info)) + (buf (cider--find-buffer-for-file file))) + (xref-make-buffer-location + buf + (with-current-buffer buf + (save-excursion + (goto-char 0) + (forward-line (1- line)) + (back-to-indentation) + (point)))))) + +(cl-defmethod xref-backend-definitions ((_backend (eql cider)) var) + "Find definitions of VAR." + (cider-ensure-connected) + (when-let* ((loc (cider--var-to-xref-location var))) + (list (xref-make var loc)))) + +(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql cider))) + "Return the completion table for identifiers." + (cider-ensure-connected) + (when-let* ((ns (cider-current-ns)) + (results (cider-sync-request:ns-vars ns))) + results)) + +(cl-defmethod xref-backend-references ((_backend (eql cider)) var) + "Find references of VAR." + (cider-ensure-connected) + (cider-ensure-op-supported "fn-refs") + (when-let* ((ns (cider-current-ns)) + (results (cider-sync-request:fn-refs ns var)) + (previously-existing-buffers (buffer-list))) + (thread-last results + (mapcar (lambda (info) + (let* ((filename (cider--xref-extract-file info)) + (column (nrepl-dict-get info "column")) + (line (nrepl-dict-get info "line")) + (friendly-name (cider--xref-extract-friendly-file-name info)) + ;; translate .jar urls and such: + (buf (cider--find-buffer-for-file filename)) + (bfn (and buf (buffer-file-name buf))) + (loc (when buf + ;; favor `xref-make-file-location' when possible, since that way, we can close their buffers. + (if bfn + (xref-make-file-location bfn line (or column 0)) + (xref-make-buffer-location buf (with-current-buffer buf + (save-excursion + (goto-char 0) + (forward-line line) + (move-to-column (or column 0)) + (point))))))) + (should-be-closed (and + buf + ;; if a buffer did not exist before, + ;; then it is a side-effect of invoking `cider--find-buffer-for-file'. + (not (member buf previously-existing-buffers)) + bfn + ;; only buffers with a normally reachable filename are safe to close. + ;; buffers not backed by such files may include .jars, TRAMP files, etc. + ;; Sadly this means we will still 'leak' some open buffers, but it's what we can do atm. + (file-exists-p bfn)))) + (when should-be-closed + (kill-buffer buf)) + (when loc + (xref-make friendly-name loc))))) + (seq-filter #'identity)))) + +(cl-defmethod xref-backend-apropos ((_backend (eql cider)) pattern) + "Find all symbols that match regexp PATTERN." + (cider-ensure-connected) + (cider-ensure-op-supported "apropos") + (when-let* ((ns (cider-current-ns)) + (results (cider-sync-request:apropos pattern ns t t completion-ignore-case))) + (mapcar (lambda (info) + (let* ((symbol (nrepl-dict-get info "name")) + (loc (cider--var-to-xref-location symbol)) + (type (nrepl-dict-get info "type")) + (doc (nrepl-dict-get info "doc"))) + (xref-make (format "[%s] %s\n %s" (propertize symbol 'face 'bold) (capitalize type) doc) + loc))) + results))) + +(provide 'cider-xref-backend) +;;; cider-xref-backend.el ends here diff --git a/elpa/cider-20241203.1607/cider-xref.el b/elpa/cider-20241203.1607/cider-xref.el new file mode 100644 index 00000000..453d1ef4 --- /dev/null +++ b/elpa/cider-20241203.1607/cider-xref.el @@ -0,0 +1,185 @@ +;;; cider-xref.el --- Xref functionality for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2019-2024 Bozhidar Batsov and CIDER contributors +;; +;; Author: Bozhidar Batsov + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Xref (find usages) functionality for Clojure. The implementation is based on +;; ideas from this article https://metaredux.com/posts/2019/05/04/discovering-runtime-function-references-in-clojure.html. +;; +;; Keep in mind that you won't get references in namespaces that haven't been loaded yet. + +;;; Code: + +(require 'cider-doc) +(require 'cider-find) +(require 'cider-util) +(require 'subr-x) + +(require 'cider-client) +(require 'cider-popup) +(require 'nrepl-dict) + +(require 'clojure-mode) +(require 'apropos) +(require 'button) + +(defconst cider-xref-buffer "*cider-xref*") + +(defcustom cider-xref-actions '(("display-doc" . cider-doc-lookup) + ("find-def" . cider--find-var) + ("lookup-on-clojuredocs" . cider-clojuredocs-lookup)) + "Controls the actions to be applied on the symbol found by an xref search. +The first action key in the list will be selected as default. If the list +contains only one action key, the associated action function will be +applied automatically. An action function can be any function that receives +the symbol found by the xref search as argument." + :type '(alist :key-type string :value-type function) + :group 'cider + :package-version '(cider . "0.22.0")) + +(defun cider-xref-doc (button) + "Display documentation for the symbol represented at BUTTON." + (cider-doc-lookup (button-get button 'apropos-symbol))) + +(defun cider-xref-result (result) + "Emit a RESULT into current buffer." + (let ((var-name (nrepl-dict-get result "name"))) + (cider-propertize-region (list 'apropos-symbol var-name + 'action #'cider-xref-doc + 'help-echo "Display doc") + (insert-text-button var-name 'type 'apropos-symbol)) + (when-let ((doc (nrepl-dict-get result "doc"))) + (when (not (string-equal "(not documented)" doc)) + (insert "\n ") + (let ((beg (point))) + (insert (propertize doc 'font-lock-face 'font-lock-doc-face)) + (fill-region beg (point))))) + (insert "\n") + (if-let* ((file-url (cider--xref-extract-file result)) + (friendly-file (cider--xref-extract-friendly-file-name result)) + (line (nrepl-dict-get result "line"))) + (progn + (insert " " + (propertize var-name + 'font-lock-face 'font-lock-function-name-face) + " is defined in ") + (insert-text-button friendly-file + 'follow-link t + 'action (lambda (_x) + (cider-xref-source file-url line var-name))) + (insert ".")) + (insert "Definition location unavailable.")) + (insert "\n"))) + +(defun cider-xref-source (file-url line name) + "Find source for FILE-URL, LINE and NAME." + (interactive) + (if file-url + (if-let* ((buffer (and (not (cider--tooling-file-p file-url)) + (cider-find-file file-url)))) + (cider-jump-to buffer (if line + (cons line nil) + name) + nil) + (user-error + (substitute-command-keys + "Can't find the source because it wasn't defined with `cider-eval-buffer'"))) + (error "No source location for %s" name))) + +(declare-function cider-mode "cider-mode") + +(defun cider-show-xref (summary results) + "Show SUMMARY and RESULTS in a pop-up buffer." + (with-current-buffer (cider-popup-buffer cider-xref-buffer 'select 'apropos-mode 'ancillary) + (let ((inhibit-read-only t)) + (if (boundp 'header-line-format) + (setq-local header-line-format summary) + (insert summary "\n\n")) + (dolist (result results) + (cider-xref-result result)) + (goto-char (point-min))))) + +;;;###autoload +(defun cider-xref-fn-refs (&optional ns symbol) + "Show all functions that reference the var matching NS and SYMBOL." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "fn-refs") + (if-let* ((ns (or ns (cider-current-ns))) + (symbol (or symbol (cider-symbol-at-point))) + (results (cider-sync-request:fn-refs ns symbol))) + (cider-show-xref (format "Showing %d functions that reference %s in currently loaded namespaces" (length results) symbol) results) + (message "No references found for %S in currently loaded namespaces" symbol))) + +;;;###autoload +(defun cider-xref-fn-deps (&optional ns symbol) + "Show all functions referenced by the var matching NS and SYMBOL." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "fn-deps") + (if-let* ((ns (or ns (cider-current-ns))) + (symbol (or symbol (cider-symbol-at-point))) + (results (cider-sync-request:fn-deps ns symbol))) + (cider-show-xref (format "Showing %d function dependencies for %s" (length results) symbol) results) + (message "No dependencies found for %S" symbol))) + +(defun cider-xref-act-on-symbol (symbol) + "Apply selected action on SYMBOL." + (let* ((first-action-key (car (car cider-xref-actions))) + (action-key (if (= 1 (length cider-xref-actions)) + first-action-key + (completing-read (format "Choose action to apply to `%s` (default %s): " + symbol first-action-key) + cider-xref-actions nil nil nil nil first-action-key))) + (action-fn (cdr (assoc action-key cider-xref-actions)))) + (if action-fn + (funcall action-fn symbol) + (user-error "Unknown action `%s`" action-key)))) + +;;;###autoload +(defun cider-xref-fn-refs-select (&optional ns symbol) + "Displays the references for NS and SYMBOL using completing read." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "fn-refs") + (if-let* ((ns (or ns (cider-current-ns))) + (symbol (or symbol (cider-symbol-at-point))) + (results (mapcar (lambda (d) (nrepl-dict-get d "name")) (cider-sync-request:fn-refs ns symbol))) + (summary (format "References for %s" symbol))) + (cider-xref-act-on-symbol (completing-read (concat summary ": ") results)) + (message "No references for %S found" symbol))) + +;;;###autoload +(defun cider-xref-fn-deps-select (&optional ns symbol) + "Displays the function dependencies for NS and SYMBOL using completing read." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "fn-deps") + (if-let* ((ns (or ns (cider-current-ns))) + (symbol (or symbol (cider-symbol-at-point))) + (results (mapcar (lambda (d) (nrepl-dict-get d "name")) (cider-sync-request:fn-deps ns symbol))) + (summary (format "Dependencies for %s" symbol))) + (cider-xref-act-on-symbol (completing-read (concat summary ": ") results)) + (message "No dependencies for %S found" symbol))) + +(provide 'cider-xref) + +;;; cider-xref.el ends here diff --git a/elpa/cider-20241203.1607/cider.el b/elpa/cider-20241203.1607/cider.el new file mode 100644 index 00000000..f9e9bdbc --- /dev/null +++ b/elpa/cider-20241203.1607/cider.el @@ -0,0 +1,2229 @@ +;;; cider.el --- Clojure Interactive Development Environment that Rocks -*- lexical-binding: t -*- + +;; Copyright © 2012-2024 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell +;; Maintainer: Bozhidar Batsov +;; URL: https://www.github.com/clojure-emacs/cider +;; Package-Version: 20241203.1607 +;; Package-Revision: 588c5790f0c0 +;; Package-Requires: ((emacs "26") (clojure-mode "5.19") (parseedn "1.2.1") (queue "0.2") (spinner "1.7") (seq "2.22") (sesman "0.3.2") (transient "0.4.1")) +;; Keywords: languages, clojure, cider + +;; 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Provides a Clojure interactive development environment for Emacs, built on +;; top of nREPL. See https://docs.cider.mx for more details. + +;;; Installation: + +;; CIDER is available as a package in melpa.org and stable.melpa.org. First, make sure you've +;; enabled one of the repositories in your Emacs config: + +;; (add-to-list 'package-archives +;; '("melpa" . "https://melpa.org/packages/")) +;; +;; or +;; +;; (add-to-list 'package-archives +;; '("melpa-stable" . "https://stable.melpa.org/packages/") t) + +;; Afterwards, installing CIDER is as easy as: + +;; M-x package-install cider + +;;; Usage: + +;; You can start CIDER with one of the following commands: + +;; M-x cider-jack-in-clj +;; M-x cider-jack-in-cljs +;; +;; M-x cider-connect-sibling-clj +;; M-x cider-connect-sibling-cljs +;; +;; M-x cider-connect-clj +;; M-x cider-connect-cljs + +;;; Code: + +(defgroup cider nil + "Clojure Interactive Development Environment that Rocks." + :prefix "cider-" + :group 'applications + :link '(url-link :tag "GitHub" "https://github.com/clojure-emacs/cider") + :link '(url-link :tag "Homepage" "https://cider.mx") + :link '(url-link :tag "Documentation" "https://docs.cider.mx") + :link '(emacs-commentary-link :tag "Commentary" "cider")) + +(require 'cider-client) +(require 'cider-eldoc) +(require 'cider-repl) +(require 'cider-repl-history) +(require 'cider-connection) +(require 'cider-mode) +(require 'cider-common) +(require 'cider-debug) +(require 'cider-util) + +(require 'cl-lib) +(require 'tramp-sh) +(require 'subr-x) +(require 'seq) +(require 'sesman) +(require 'package) + +(defconst cider-version "1.16.1" + "The current version of CIDER.") + +(defconst cider-codename "Kherson" + "Codename used to denote stable releases.") + +(defcustom cider-lein-command + "lein" + "The command used to execute Leiningen." + :type 'string) + +(defcustom cider-lein-global-options + nil + "Command global options used to execute Leiningen (e.g.: -o for offline)." + :type 'string + :safe #'stringp) + +(defcustom cider-lein-parameters + "repl :headless :host localhost" + "Params passed to Leiningen to start an nREPL server via `cider-jack-in'." + :type 'string + :safe #'stringp) + +(defcustom cider-boot-command + "boot" + "The command used to execute Boot." + :type 'string + :package-version '(cider . "0.9.0")) + +(defcustom cider-boot-global-options + nil + "Command global options used to execute Boot (e.g.: -c for checkouts)." + :type 'string + :safe #'stringp + :package-version '(cider . "0.14.0")) + +(defcustom cider-boot-parameters + "repl -s -b localhost wait" + "Params passed to boot to start an nREPL server via `cider-jack-in'." + :type 'string + :safe #'stringp + :package-version '(cider . "0.9.0")) + +(defcustom cider-clojure-cli-command + (if (and (eq system-type 'windows-nt) + (null (executable-find "clojure"))) + "powershell" + "clojure") + "The command used to execute clojure with tools.deps. +Don't use clj here, as it doesn't work when spawned from Emacs due to it +using rlwrap. If on Windows and no \"clojure\" executable is found we +default to \"powershell\"." + :type 'string + :safe #'stringp + :package-version '(cider . "0.17.0")) + +(defcustom cider-clojure-cli-global-options + nil + "Command line options used to execute clojure with tools.deps." + :type 'string + :safe #'stringp + :package-version '(cider . "0.17.0")) + +(defcustom cider-clojure-cli-parameters + nil + "Params passed to clojure cli to start an nREPL server via `cider-jack-in'." + :type 'string + :safe #'stringp + :package-version '(cider . "1.8.0")) + +(defcustom cider-clojure-cli-aliases + nil + "A list of aliases to include when using the clojure cli. +Alias names should be of the form \":foo:bar\". +Leading \"-A\" \"-M\" \"-T\" or \"-X\" are stripped from aliases +then concatenated into the \"-M[your-aliases]:cider/nrepl\" form." + :type 'string + :safe #'stringp + :package-version '(cider . "1.1")) + +(defcustom cider-clojure-cli-global-aliases + nil + "Global aliases to include when jacking in with the clojure CLI. +This value should be a string of the form \":foo:bar\", and +will be prepended to the value of `cider-clojure-cli-aliases'. +Alias names should be of the form \":foo:bar\". +Leading \"-A\" \"-M\" \"-T\" or \"-X\" are stripped from aliases +then concatenated into the \"-M[your-aliases]:cider/nrepl\" form." + :type 'string + :safe #'stringp + :package-version '(cider . "1.14")) + +(defcustom cider-shadow-cljs-command + "npx shadow-cljs" + "The command used to execute shadow-cljs. + +By default we favor the project-specific shadow-cljs over the system-wide." + :type 'string + :safe #'stringp + :package-version '(cider . "0.17.0")) + +(defcustom cider-shadow-cljs-global-options + "" + "Command line options used to execute shadow-cljs (e.g.: -v for verbose mode)." + :type 'string + :safe #'stringp + :package-version '(cider . "0.17.0")) + +(defcustom cider-shadow-cljs-parameters + "server" + "Params passed to shadow-cljs to start an nREPL server via `cider-jack-in'." + :type 'string + :safe #'stringp + :package-version '(cider . "0.17.0")) + +(defcustom cider-gradle-command + "./gradlew" + "The command used to execute Gradle." + :type 'string + :safe #'stringp + :package-version '(cider . "0.10.0")) + +(defcustom cider-gradle-global-options + "" + "Command line options used to execute Gradle (e.g.: -m for dry run)." + :type 'string + :safe #'stringp + :package-version '(cider . "0.14.0")) + +(defcustom cider-gradle-parameters + "clojureRepl" + "Params passed to gradle to start an nREPL server via `cider-jack-in'." + :type 'string + :safe #'stringp + :package-version '(cider . "0.10.0")) + +(defcustom cider-babashka-command + "bb" + "The command used to execute Babashka." + :type 'string + :safe #'stringp + :package-version '(cider . "1.2.0")) + +(defcustom cider-babashka-global-options + nil + "Command line options used to execute Babashka." + :type 'string + :safe #'stringp + :package-version '(cider . "1.2.0")) + +(defcustom cider-babashka-parameters + "nrepl-server localhost:0" + "Params passed to babashka to start an nREPL server via `cider-jack-in'." + :type 'string + :safe #'stringp + :package-version '(cider . "1.2.0")) + +(defcustom cider-nbb-command + "nbb" + "The command used to execute nbb." + :type 'string + :safe #'stringp + :package-version '(cider . "1.6.0")) + +(defcustom cider-nbb-global-options + nil + "Command line options used to execute nbb." + :type 'string + :safe #'stringp + :package-version '(cider . "1.6.0")) + +(defcustom cider-nbb-parameters + "nrepl-server" + "Params passed to nbb to start an nREPL server via `cider-jack-in'." + :type 'string + :safe #'stringp + :package-version '(cider . "1.6.0")) + +(defcustom cider-basilisp-command + "basilisp" + "The command used to execute Basilisp. + + If Basilisp is installed in a virtual environment, update this to the + full path of the Basilisp executable within that virtual environment." + :type 'string + :safe #'stringp + :package-version '(cider . "1.14.0")) + +(defcustom cider-basilisp-parameters + "nrepl-server" + "Params passed to Basilisp to start an nREPL server via `cider-jack-in'." + :type 'string + :safe #'stringp + :package-version '(cider . "1.14.0")) + +(make-obsolete-variable 'cider-lein-global-options 'cider-lein-parameters "1.8.0") +(make-obsolete-variable 'cider-boot-global-options 'cider-boot-parameters "1.8.0") +(make-obsolete-variable 'cider-clojure-cli-global-options 'cider-clojure-cli-parameters "1.8.0") +(make-obsolete-variable 'cider-shadow-cljs-global-options 'cider-shadow-cljs-parameters "1.8.0") +(make-obsolete-variable 'cider-gradle-global-options 'cider-gradle-parameters "1.8.0") +(make-obsolete-variable 'cider-babashka-global-options 'cider-babashka-parameters "1.8.0") +(make-obsolete-variable 'cider-nbb-global-options 'cider-nbb-parameters "1.8.0") + +(defcustom cider-jack-in-default + (if (executable-find "clojure") 'clojure-cli 'lein) + "The default tool to use when doing `cider-jack-in' outside a project. +This value will only be consulted when no identifying file types, i.e. +project.clj for leiningen or build.boot for boot, could be found. + +As the Clojure CLI is bundled with Clojure itself, it's the default. +In the absence of the Clojure CLI (e.g. on Windows), we fallback +to Leiningen." + :type '(choice (const lein) + (const boot) + (const clojure-cli) + (const shadow-cljs) + (const gradle) + (const babashka) + (const nbb) + (const basilisp)) + :safe #'symbolp + :package-version '(cider . "0.9.0")) + +(defcustom cider-preferred-build-tool + nil + "Allow choosing a build system when there are many. +When there are project markers from multiple build systems (e.g. lein and +boot) the user is prompted to select one of them. When non-nil, this +variable will suppress this behavior and will select whatever build system +is indicated by the variable if present. Note, this is only when CIDER +cannot decide which of many build systems to use and will never override a +command when there is no ambiguity." + :type '(choice (const lein) + (const boot) + (const clojure-cli) + (const shadow-cljs) + (const gradle) + (const babashka) + (const nbb) + (const basilisp) + (const :tag "Always ask" nil)) + :safe #'symbolp + :package-version '(cider . "0.13.0")) + +(defcustom cider-allow-jack-in-without-project 'warn + "Controls what happens when doing `cider-jack-in' outside a project. +When set to 'warn you'd prompted to confirm the command. +When set to t `cider-jack-in' will quietly continue. +When set to nil `cider-jack-in' will fail." + :type '(choice (const :tag "always" t) + (const warn) + (const :tag "never" nil)) + :safe #'symbolp + :package-version '(cider . "0.15.0")) + +(defcustom cider-known-endpoints nil + "A list of connection endpoints where each endpoint is a list. +For example: \\='((\"label\" \"host\" \"port\")). +The label is optional so that \\='(\"host\" \"port\") will suffice. +This variable is used by `cider-connect'." + :type '(repeat (list (string :tag "label") + (string :tag "host") + (string :tag "port")))) + +(defcustom cider-connected-hook nil + "List of functions to call when connected to Clojure nREPL server." + :type 'hook + :package-version '(cider . "0.9.0")) + +(defcustom cider-disconnected-hook nil + "List of functions to call when disconnected from the Clojure nREPL server." + :type 'hook + :package-version '(cider . "0.9.0")) + +(defcustom cider-inject-dependencies-at-jack-in t + "When nil, do not inject repl dependencies at `cider-jack-in' time. +The repl dependendcies are most likely to be nREPL middlewares." + :type 'boolean + :safe #'booleanp + :version '(cider . "0.11.0")) + +(defcustom cider-enable-nrepl-jvmti-agent nil + "When t, add `-Djdk.attach.allowAttachSelf' to the command line arguments. +This allows nREPL JVMTI agent to be loaded. It is needed for evaluation +interruption to properly work on Java 21 and above." + :type 'boolean + :safe #'booleanp + :version '(cider . "1.15.0")) + +(defcustom cider-offer-to-open-cljs-app-in-browser t + "When nil, do not offer to open ClojureScript apps in a browser on connect." + :type 'boolean + :safe #'booleanp + :version '(cider . "0.15.0")) + +(defvar cider-ps-running-lein-nrepls-command "ps u | grep leiningen" + "Process snapshot command used in `cider-locate-running-nrepl-ports'.") + +(defvar cider-ps-running-lein-nrepl-path-regexp-list + '("\\(?:leiningen.original.pwd=\\)\\(.+?\\) -D" + "\\(?:-classpath +:?\\(.+?\\)/self-installs\\)") + "Regexp list to get project paths. +Extract project paths from output of `cider-ps-running-lein-nrepls-command'. +Sub-match 1 must be the project path.") + +(defvar cider-host-history nil + "Completion history for connection hosts.") + +(defvar cider-jack-in-universal-options + '((clojure-cli (:prefix-arg 1 :cmd (:jack-in-type clj :project-type clojure-cli :edit-project-dir t))) + (lein (:prefix-arg 2 :cmd (:jack-in-type clj :project-type lein :edit-project-dir t))) + (babashka (:prefix-arg 3 :cmd (:jack-in-type clj :project-type babashka :edit-project-dir t))) + (nbb (:prefix-arg 4 :cmd (:jack-in-type cljs :project-type nbb :cljs-repl-type nbb :edit-project-dir t))) + (basilisp (:prefix-arg 5 :cmd (:jack-in-type clj :project-type basilisp :edit-project-dir t)))) + "The list of project tools that are supported by the universal jack in command. + +Each item in the list consists of the tool name and its plist options. + +The plist supports the following keys + +- :prefix-arg the numerical prefix arg to use to jack in to the tool. + +- :cmd a plist of instructions how to invoke the jack in command, with keys + + - :jack-in-type 'clj to start a clj repl and 'cljs for a cljs repl. + + - &rest the same set of params supported by the `cider-jack-in-clj' and + `cider-jack-in-cljs' commands.") + +;;;###autoload +(defun cider-version () + "Display CIDER's version." + (interactive) + (message "CIDER %s" (cider--version))) + +(defun cider-jack-in-command (project-type) + "Determine the command `cider-jack-in' needs to invoke for the PROJECT-TYPE." + (pcase project-type + ('lein cider-lein-command) + ('boot cider-boot-command) + ('clojure-cli cider-clojure-cli-command) + ('babashka cider-babashka-command) + ('shadow-cljs cider-shadow-cljs-command) + ('gradle cider-gradle-command) + ('nbb cider-nbb-command) + ('basilisp cider-basilisp-command) + (_ (user-error "Unsupported project type `%S'" project-type)))) + +(defcustom cider-enrich-classpath nil + "If t, use enrich-classpath for adding sources/javadocs to the classpath. + +enrich-classpath is a Clojure CLI shim, and Leiningen plugin. + +This classpath expansion is done in a clean manner, +without interfering with classloaders." + :type 'boolean + :package-version '(cider . "1.2.0") + :safe #'booleanp) + +(defun cider--get-enrich-classpath-lein-script () + "Returns the location of enrich-classpath's lein.sh wrapper script." + (when-let ((cider-location (locate-library "cider.el" t))) + (concat (file-name-directory cider-location) + "lein.sh"))) + +(defun cider--get-enrich-classpath-clojure-cli-script () + "Returns the location of enrich-classpath's clojure.sh wrapper script." + (when-let ((cider-location (locate-library "cider.el" t))) + (concat (file-name-directory cider-location) + "clojure.sh"))) + +(defun cider-jack-in-resolve-command (project-type) + "Determine the resolved file path to `cider-jack-in-command'. +Throws an error if PROJECT-TYPE is unknown." + (pcase project-type + ('lein (let ((r (cider--resolve-command cider-lein-command))) + (if (and cider-enrich-classpath + (not (eq system-type 'windows-nt)) + (executable-find (cider--get-enrich-classpath-lein-script))) + (concat "bash " ;; don't assume lein.sh is executable - MELPA might change that + (cider--get-enrich-classpath-lein-script) + " " + r) + r))) + ('boot (cider--resolve-command cider-boot-command)) + ('clojure-cli (if (and cider-enrich-classpath + (not (eq system-type 'windows-nt)) + (executable-find (cider--get-enrich-classpath-clojure-cli-script))) + (concat "bash " ;; don't assume clojure.sh is executable - MELPA might change that + (cider--get-enrich-classpath-clojure-cli-script) + " " + (cider--resolve-command cider-clojure-cli-command)) + (cider--resolve-command cider-clojure-cli-command))) + ('babashka (cider--resolve-command cider-babashka-command)) + ;; here we have to account for the possibility that the command is either + ;; "npx shadow-cljs" or just "shadow-cljs" + ('shadow-cljs (let ((parts (split-string cider-shadow-cljs-command))) + (when-let* ((command (cider--resolve-command (car parts)))) + (mapconcat #'identity (cons command (cdr parts)) " ")))) + ;; TODO: Address the duplicated code below. + ;; here we have to account for the possibility that the command is either + ;; "nbb" (default) or "npx nbb". + ('nbb (let ((parts (split-string cider-nbb-command))) + (when-let* ((command (cider--resolve-command (car parts)))) + (mapconcat #'identity (cons command (cdr parts)) " ")))) + ;; here we have to account for use of the Gradle wrapper which is + ;; a shell script within their project, so if they have a clearly + ;; relative path like "./gradlew" use locate file instead of checking + ;; the exec-path + ('gradle (cider--resolve-project-command cider-gradle-command)) + ('basilisp (cider--resolve-command cider-basilisp-command)) + (_ (user-error "Unsupported project type `%S'" project-type)))) + +(defun cider-jack-in-global-options (project-type) + "Determine the command line options for `cider-jack-in' for the PROJECT-TYPE." + (pcase project-type + ('lein cider-lein-global-options) + ('boot cider-boot-global-options) + ('clojure-cli cider-clojure-cli-global-options) + ('babashka cider-babashka-global-options) + ('shadow-cljs cider-shadow-cljs-global-options) + ('gradle cider-gradle-global-options) + ('nbb cider-nbb-global-options) + ('basilisp nil) + (_ (user-error "Unsupported project type `%S'" project-type)))) + +(defun cider-jack-in-params (project-type) + "Determine the commands params for `cider-jack-in' for the PROJECT-TYPE." + ;; The format of these command-line strings must consider different shells, + ;; different values of IFS, and the possibility that they'll be run remotely + ;; (e.g. with TRAMP). Using `", "` causes problems with TRAMP, for example. + ;; Please be careful when changing them. + (pcase project-type + ('lein cider-lein-parameters) + ('boot cider-boot-parameters) + ('clojure-cli cider-clojure-cli-parameters) + ('babashka cider-babashka-parameters) + ('shadow-cljs cider-shadow-cljs-parameters) + ('gradle cider-gradle-parameters) + ('nbb cider-nbb-parameters) + ('basilisp cider-basilisp-parameters) + (_ (user-error "Unsupported project type `%S'" project-type)))) + + +;;; Jack-in dependencies injection +(defvar cider-jack-in-dependencies nil + "List of dependencies where elements are lists of artifact name and version.") +(put 'cider-jack-in-dependencies 'risky-local-variable t) + +(defcustom cider-injected-nrepl-version "1.3.0" + "The version of nREPL injected on jack-in. +We inject the newest known version of nREPL just in case +your version of Boot or Leiningen is bundling an older one." + :type 'string + :package-version '(cider . "1.2.0") + :safe #'stringp) + +(defvar cider-jack-in-cljs-dependencies nil + "List of dependencies where elements are lists of artifact name and version. +Added to `cider-jack-in-dependencies' when doing `cider-jack-in-cljs'.") +(put 'cider-jack-in-cljs-dependencies 'risky-local-variable t) +(cider-add-to-alist 'cider-jack-in-cljs-dependencies "cider/piggieback" "0.5.3") + +(defvar cider-jack-in-dependencies-exclusions nil + "List of exclusions for jack in dependencies. +Elements of the list are artifact name and list of exclusions to apply for +the artifact.") +(put 'cider-jack-in-dependencies-exclusions 'risky-local-variable t) + +(defconst cider-clojure-artifact-id "org.clojure/clojure" + "Artifact identifier for Clojure.") + +(defconst cider-minimum-clojure-version "1.10.0" + "Minimum supported version of Clojure.") + +(defconst cider-latest-clojure-version "1.11.3" + "Latest (newest) version of Clojure. + +Used when `cider-jack-in-auto-inject-clojure' is set to `latest'.") + +(defconst cider-required-middleware-version "0.50.3" + "The CIDER nREPL version that's known to work properly with CIDER.") + +(defcustom cider-injected-middleware-version cider-required-middleware-version + "The version of cider-nrepl injected on jack-in. +Should be newer than the required version for optimal results." + :type 'string + :package-version '(cider . "1.2.0") + :safe #'stringp) + +(defcustom cider-jack-in-auto-inject-clojure nil + "Version of clojure to auto-inject into REPL. +If nil, do not inject Clojure into the REPL. If `latest', inject +`cider-latest-clojure-version', which should approximate to the most recent +version of Clojure. If `minimal', inject `cider-minimum-clojure-version', +which will be the lowest version CIDER supports. If a string, use this as +the version number. If it is a list, the first element should be a string, +specifying the artifact ID, and the second element the version number." + :type '(choice (const :tag "None" nil) + (const :tag "Latest" latest) + (const :tag "Minimal" minimal) + (string :tag "Specific Version") + (list :tag "Artifact ID and Version" + (string :tag "Artifact ID") + (string :tag "Version")))) + +(defvar-local cider-jack-in-cmd nil + "The custom command used to start a nrepl server. +This is used by `cider-jack-in`. + +If this variable is set, its value will be +used as the command to start the nrepl server +instead of the default command inferred from +the project type. + +This allows for fine-grained control over the jack-in process. +The value should be a string representing the command to start +the nrepl server, such as \"nbb nrepl-server\".") + +(defvar cider-jack-in-lein-plugins nil + "List of Leiningen plugins to be injected at jack-in. +Each element is a list of artifact name and version, followed optionally by +keyword arguments. The only keyword argument currently accepted is +`:predicate', which should be given a function that takes the list (name, +version, and keyword arguments) and returns non-nil to indicate that the +plugin should actually be injected. (This is useful primarily for packages +that extend CIDER, not for users. For example, a refactoring package might +want to inject some middleware only when within a project context.)") +(put 'cider-jack-in-lein-plugins 'risky-local-variable t) + +(defvar cider-jack-in-lein-middlewares nil + "List of Leiningen :middleware values to be injected at jack-in. + +Necessary for plugins which require an explicit middleware name to be specified. + +Can also facilitate using middleware in a specific order.") +(put 'cider-jack-in-lein-middlewares 'risky-local-variable t) + +(defvar cider-jack-in-cljs-lein-plugins nil + "List of Leiningen plugins to be injected at jack-in. +Added to `cider-jack-in-lein-plugins' (which see) when doing +`cider-jack-in-cljs'.") +(put 'cider-jack-in-cljs-lein-plugins 'risky-local-variable t) + +(defun cider-jack-in-normalized-lein-plugins () + "Return a normalized list of Leiningen plugins to be injected. +See `cider-jack-in-lein-plugins' for the format, except that the list +returned by this function does not include keyword arguments." + (let ((plugins (if cider-enrich-classpath + (append cider-jack-in-lein-plugins + `(("cider/cider-nrepl" ,cider-injected-middleware-version) + ("mx.cider/lein-enrich-classpath" "1.19.3"))) + (append cider-jack-in-lein-plugins + `(("cider/cider-nrepl" ,cider-injected-middleware-version)))))) + (thread-last plugins + (seq-filter + (lambda (spec) + (if-let* ((pred (plist-get (seq-drop spec 2) :predicate))) + (funcall pred spec) + t))) + (mapcar + (lambda (spec) + (seq-take spec 2)))))) + +(defvar cider-jack-in-nrepl-middlewares nil + "List of Clojure variable names. +Each of these Clojure variables should hold a vector of nREPL middlewares. +Instead of a string, an element can be a list containing a string followed +by optional keyword arguments. The only keyword argument currently +accepted is `:predicate', which should be given a function that takes the +list (string and keyword arguments) and returns non-nil to indicate that +the middlewares should actually be injected.") +(put 'cider-jack-in-nrepl-middlewares 'risky-local-variable t) +(add-to-list 'cider-jack-in-nrepl-middlewares "cider.nrepl/cider-middleware") + +(defvar cider-jack-in-cljs-nrepl-middlewares nil + "List of Clojure variable names. +Added to `cider-jack-in-nrepl-middlewares' (which see) when doing +`cider-jack-in-cljs'.") +(put 'cider-jack-in-cljs-nrepl-middlewares 'risky-local-variable t) +(add-to-list 'cider-jack-in-cljs-nrepl-middlewares "cider.piggieback/wrap-cljs-repl") + +(defun cider-jack-in-normalized-nrepl-middlewares () + "Return a normalized list of middleware variable names. +See `cider-jack-in-nrepl-middlewares' for the format, except that the list +returned by this function only contains strings." + (thread-last cider-jack-in-nrepl-middlewares + (seq-filter + (lambda (spec) + (or (not (listp spec)) + (if-let* ((pred (plist-get (cdr spec) :predicate))) + (funcall pred spec) + t)))) + (mapcar + (lambda (spec) + (if (listp spec) + (car spec) + spec))))) + +(defun cider--list-as-boot-artifact (list) + "Return a boot artifact string described by the elements of LIST. +LIST should have the form (ARTIFACT-NAME ARTIFACT-VERSION). The returned +string is quoted for passing as argument to an inferior shell." + (concat "-d " (shell-quote-argument (format "%s:%s" (car list) (cadr list))))) + +(defun cider--jack-in-required-dependencies () + "Returns the required CIDER deps. +They are normally added to `cider-jack-in-dependencies', +unless it's a Lein project." + `(("nrepl/nrepl" ,cider-injected-nrepl-version) + ("cider/cider-nrepl" ,cider-injected-middleware-version))) + +(defun cider-boot-dependencies (dependencies) + "Return a list of boot artifact strings created from DEPENDENCIES." + (concat (mapconcat #'cider--list-as-boot-artifact dependencies " ") + (unless (seq-empty-p dependencies) " "))) + +(defun cider-boot-middleware-task (params middlewares) + "Create a command to add MIDDLEWARES with corresponding PARAMS." + (concat "cider.tasks/add-middleware " + (mapconcat (lambda (middleware) + (format "-m %s" (shell-quote-argument middleware))) + middlewares + " ") + " " params)) + +(defun cider-boot-jack-in-dependencies (global-opts params dependencies middlewares) + "Create boot jack-in dependencies. +Does so by concatenating GLOBAL-OPTS, DEPENDENCIES, +and MIDDLEWARES. PARAMS and MIDDLEWARES are passed on to +`cider-boot-middleware-task` before concatenating and DEPENDENCIES + are passed on to `cider-boot-dependencies`." + (concat global-opts + (unless (seq-empty-p global-opts) " ") + "-i \"(require 'cider.tasks)\" " ;; Note the space at the end here + (cider-boot-dependencies (append (cider--jack-in-required-dependencies) dependencies)) + (cider-boot-middleware-task params middlewares))) + +(defun cider--gradle-dependency-notation (dependency) + "Returns Gradle's GAV dependency syntax. +For a \"group/artifact\" \"version\") DEPENDENCY list +return as group:artifact:version notation." + (let ((group-artifact (replace-regexp-in-string "/" ":" (car dependency))) + (version (cadr dependency))) + (format "%s:%s" group-artifact version))) + +(defun cider--gradle-jack-in-property (dependencies) + "Returns Clojurephant's dependency jack-in property. +For DEPENDENCIES, translates to Gradle's dependency notation +using `cider--gradle-dependency-notation`.''" + (if (seq-empty-p dependencies) + "" + (shell-quote-argument + (concat "-Pdev.clojurephant.jack-in.nrepl=" + (mapconcat #'cider--gradle-dependency-notation dependencies ","))))) + +(defun cider--gradle-middleware-params (middlewares) + "Returns Gradle-formatted middleware params. +Given a list of MIDDLEWARES symbols, this returns +the Gradle parameters expected by Clojurephant's +ClojureNRepl task." + (mapconcat (lambda (middleware) + (shell-quote-argument (concat "--middleware=" middleware))) + middlewares + " ")) + +(defun cider-gradle-jack-in-dependencies (global-opts params dependencies middlewares) + "Create gradle jack in dependencies. +Does so by concatenating GLOBAL-OPTS, DEPENDENCIES, +and MIDDLEWARES. GLOBAL-OPTS and PARAMS are taken as-is. +DEPENDENCIES are translated into Gradle's typical +group:artifact:version notation and MIDDLEWARES are +prepared as arguments to Clojurephant's ClojureNRepl task." + (concat global-opts + (unless (seq-empty-p global-opts) " ") + (when cider-enable-nrepl-jvmti-agent + "-Pjdk.attach.allowAttachSelf ") + (cider--gradle-jack-in-property (append (cider--jack-in-required-dependencies) dependencies)) + " " + params + (unless (seq-empty-p params) " ") + (cider--gradle-middleware-params middlewares))) + +(defun cider--lein-artifact-exclusions (exclusions) + "Return an exclusions vector described by the elements of EXCLUSIONS." + (if exclusions + (format " :exclusions [%s]" (mapconcat #'identity exclusions " ")) + "")) + +(defun cider--list-as-lein-artifact (list &optional exclusions) + "Return an artifact string described by the elements of LIST. +LIST should have the form (ARTIFACT-NAME ARTIFACT-VERSION). Optionally a list +of EXCLUSIONS can be provided as well. The returned +string is quoted for passing as argument to an inferior shell." + (shell-quote-argument (format "[%s %S%s]" (car list) (cadr list) (cider--lein-artifact-exclusions exclusions)))) + +(defun cider--extract-lein-profiles (lein-params) + "Extracts a list of ('with-profile ...' and a repl command from LEIN-PARAMS). + +If no `with-profile' call was found, +returns an empty string as the first member." + (or (when-let* ((pattern "\\(with-profiles?\\s-+\\S-+\\)") + (match-start (string-match pattern lein-params)) + (match-end (match-end 0))) + (list (concat (substring lein-params match-start match-end) " ") + (string-trim (substring lein-params match-end)))) + (list "" lein-params))) + +(defun cider-lein-jack-in-dependencies (global-opts params dependencies dependencies-exclusions lein-plugins &optional lein-middlewares) + "Create lein jack-in dependencies. +Does so by concatenating GLOBAL-OPTS, DEPENDENCIES, with DEPENDENCIES-EXCLUSIONS +removed, LEIN-PLUGINS, LEIN-MIDDLEWARES and finally PARAMS." + (concat + global-opts + (unless (seq-empty-p global-opts) " ") + (mapconcat #'identity + (append (seq-map (lambda (dep) + (let ((exclusions (cadr (assoc (car dep) dependencies-exclusions)))) + (concat "update-in :dependencies conj " + (cider--list-as-lein-artifact dep exclusions)))) + dependencies) + (seq-map (lambda (plugin) + (concat "update-in :plugins conj " + (cider--list-as-lein-artifact plugin))) + lein-plugins) + (seq-map (lambda (middleware) + (concat "update-in :middleware conj " + middleware)) + lein-middlewares) + (when cider-enable-nrepl-jvmti-agent + `(,(concat "update-in :jvm-opts conj '\"-Djdk.attach.allowAttachSelf\"'")))) + " -- ") + " -- " + (if (not cider-enrich-classpath) + params + ;; enrich-classpath must be applied after the `with-profile` call, if present, + ;; so that it can also process the classpath that is typically expanded by the presence of a set of profiles: + (let* ((profiles-and-repl-call (cider--extract-lein-profiles params)) + (profiles (car profiles-and-repl-call)) + (repl-call (nth 1 profiles-and-repl-call))) + (concat profiles + "update-in :middleware conj cider.enrich-classpath.plugin-v2/middleware -- " + repl-call))))) + +(defun cider--dedupe-deps (deps) + "Removes the duplicates in DEPS." + (cl-delete-duplicates deps :test 'equal)) + +(defun cider--jack-in-cmd-powershell-p (command) + "Returns whether COMMAND is PowerShell." + (or (string-equal command "powershell") + (string-equal command "pwsh"))) + +(defun cider--shell-quote-argument (argument &optional command) + "Quotes ARGUMENT like `shell-quote-argument', suitable for use with COMMAND. + +Uses `shell-quote-argument' to quote the ARGUMENT, unless COMMAND is given +and refers to PowerShell, in which case it uses (some limited) PowerShell +rules to quote it." + (if (cider--jack-in-cmd-powershell-p command) + ;; please add more PowerShell quoting rules as necessary. + (format "'%s'" (replace-regexp-in-string "\"" "\"\"" argument)) + (shell-quote-argument argument))) + +(defun cider--powershell-encode-command (cmd-params) + "Base64 encode the powershell command and jack-in CMD-PARAMS for clojure-cli." + (let* ((quoted-params cmd-params) + ;; Also ensure compatibility with pwsh 7.3 quoting rules + ;; + ;; https://stackoverflow.com/a/59036879 + (command (format "$PSNativeCommandArgumentPassing = 'Legacy'; clojure %s" quoted-params)) + (utf-16le-command (encode-coding-string command 'utf-16le))) + (format "-encodedCommand %s" (base64-encode-string utf-16le-command t)))) + + +(defun cider--combined-aliases () + "Creates the combined ailases as stringe separated by ':'." + (let ((final-cider-clojure-cli-aliases + (cond ((and cider-clojure-cli-global-aliases cider-clojure-cli-aliases) + (concat cider-clojure-cli-global-aliases ":" cider-clojure-cli-aliases)) + (cider-clojure-cli-global-aliases cider-clojure-cli-global-aliases) + (t cider-clojure-cli-aliases)))) + (if final-cider-clojure-cli-aliases + ;; remove exec-opts flags -A -M -T or -X from cider-clojure-cli-aliases + ;; concatenated with :cider/nrepl to ensure :cider/nrepl comes last + (let ((aliases (format "%s" (replace-regexp-in-string "^-\\(A\\|M\\|T\\|X\\)" "" final-cider-clojure-cli-aliases)))) + (if (string-prefix-p ":" aliases) + aliases + (concat ":" aliases))) + ""))) + +(defun cider-clojure-cli-jack-in-dependencies (global-options params dependencies &optional command) + "Create Clojure tools.deps jack-in dependencies. +Does so by concatenating DEPENDENCIES, PARAMS and GLOBAL-OPTIONS into a +suitable `clojure` invocation and quoting, also accounting for COMMAND if +provided. The main is placed in an inline alias :cider/nrepl so that if +your aliases contain any mains, the cider/nrepl one will be the one used." + (let* ((all-deps (thread-last dependencies + (append (cider--jack-in-required-dependencies)) + ;; Duplicates are never OK since they would result in + ;; `java.lang.IllegalArgumentException: Duplicate key [...]`: + (cider--dedupe-deps) + (seq-map (lambda (dep) + (if (listp (cadr dep)) + (format "%s {%s}" + (car dep) + (seq-reduce + (lambda (acc v) + (concat acc (format " :%s \"%s\" " (car v) (cdr v)))) + (cadr dep) + "")) + (format "%s {:mvn/version \"%s\"}" (car dep) (cadr dep))))))) + (middleware (mapconcat + (apply-partially #'format "%s") + (cider-jack-in-normalized-nrepl-middlewares) + ",")) + (main-opts (format "\"-m\" \"nrepl.cmdline\" \"--middleware\" \"[%s]\"" middleware)) + (deps (format "{:deps {%s} :aliases {:cider/nrepl {%s:main-opts [%s]}}}" + (string-join all-deps " ") + (if cider-enable-nrepl-jvmti-agent + ":jvm-opts [\"-Djdk.attach.allowAttachSelf\"], " + "") + main-opts)) + (deps-quoted (cider--shell-quote-argument deps command))) + (format "%s-Sdeps %s -M%s:cider/nrepl%s" + ;; TODO: global-options are deprecated and should be removed in CIDER 2.0 + (if global-options (format "%s " global-options) "") + deps-quoted + (cider--combined-aliases) + (if params (format " %s" params) "")))) + +(defun cider-shadow-cljs-jack-in-dependencies (global-opts params dependencies) + "Create shadow-cljs jack-in deps. +Does so by concatenating GLOBAL-OPTS, DEPENDENCIES finally PARAMS." + (let ((dependencies (append (cider--jack-in-required-dependencies) dependencies))) + (concat + global-opts + (unless (seq-empty-p global-opts) " ") + (mapconcat #'identity + (seq-map (lambda (dep) (format "-d %s:%s" (car dep) (cadr dep))) dependencies) + " ") + " " + params))) + +(defun cider-add-clojure-dependencies-maybe (dependencies) + "Return DEPENDENCIES with an added Clojure dependency if requested. +See also `cider-jack-in-auto-inject-clojure'." + (if cider-jack-in-auto-inject-clojure + (if (consp cider-jack-in-auto-inject-clojure) + (cons cider-jack-in-auto-inject-clojure dependencies) + (cons (list cider-clojure-artifact-id + (cond + ((stringp cider-jack-in-auto-inject-clojure) + cider-jack-in-auto-inject-clojure) + ((eq cider-jack-in-auto-inject-clojure 'minimal) + cider-minimum-clojure-version) + ((eq cider-jack-in-auto-inject-clojure 'latest) + cider-latest-clojure-version))) + dependencies)) + dependencies)) + +(defun cider-inject-jack-in-dependencies (global-opts params project-type &optional command) + "Return GLOBAL-OPTS and PARAMS with injected REPL dependencies. +These are set in `cider-jack-in-dependencies', `cider-jack-in-lein-plugins' +and `cider-jack-in-nrepl-middlewares' are injected from the CLI according +to the used PROJECT-TYPE, and COMMAND if provided. Eliminates the need for +hacking profiles.clj or the boot script for supporting CIDER with its nREPL +middleware and dependencies." + (pcase project-type + ('lein (cider-lein-jack-in-dependencies + global-opts + params + (cider-add-clojure-dependencies-maybe + (append `(("nrepl/nrepl" ,cider-injected-nrepl-version)) cider-jack-in-dependencies)) + cider-jack-in-dependencies-exclusions + (cider-jack-in-normalized-lein-plugins) + cider-jack-in-lein-middlewares)) + ('boot (cider-boot-jack-in-dependencies + global-opts + params + (cider-add-clojure-dependencies-maybe + cider-jack-in-dependencies) + (cider-jack-in-normalized-nrepl-middlewares))) + ('clojure-cli (cider-clojure-cli-jack-in-dependencies + global-opts + params + (cider-add-clojure-dependencies-maybe + cider-jack-in-dependencies) + command)) + ('babashka (concat + global-opts + (unless (seq-empty-p global-opts) " ") + params)) + ('shadow-cljs (cider-shadow-cljs-jack-in-dependencies + global-opts + params + (cider-add-clojure-dependencies-maybe + cider-jack-in-dependencies))) + ('gradle (cider-gradle-jack-in-dependencies + global-opts + params + (cider-add-clojure-dependencies-maybe + cider-jack-in-dependencies) + (cider-jack-in-normalized-nrepl-middlewares))) + ('nbb (concat + global-opts + (unless (seq-empty-p global-opts) " ") + params)) + ('basilisp params) + (_ (error "Unsupported project type `%S'" project-type)))) + + +;;; ClojureScript REPL creation + +(defcustom cider-check-cljs-repl-requirements t + "When non-nil will run the requirement checks for the different cljs repls. +Generally you should not disable this unless you run into some faulty check." + :type 'boolean + :safe #'booleanp + :package-version '(cider . "0.17.0")) + +(defun cider-clojurescript-present-p () + "Return non nil when ClojureScript is present." + (or + ;; This is nil for example for nbb. + (cider-library-present-p "cljs.core") + ;; demunge is not defined currently for normal cljs repls. + ;; So we end up making the two checks + (nrepl-dict-get (cider-sync-tooling-eval "cljs.core/demunge") "value"))) + +(defun cider-verify-clojurescript-is-present () + "Check whether ClojureScript is present." + (unless (cider-clojurescript-present-p) + (user-error "ClojureScript is not available. See https://docs.cider.mx/cider/basics/clojurescript for details"))) + +(defun cider-verify-piggieback-is-present () + "Check whether the piggieback middleware is present." + (unless (cider-library-present-p "cider.piggieback") + (user-error "Piggieback 0.4.x (aka cider/piggieback) is not available. See https://docs.cider.mx/cider/basics/clojurescript for details"))) + +(defun cider-check-node-requirements () + "Check whether we can start a Node ClojureScript REPL." + (cider-verify-piggieback-is-present) + (unless (executable-find "node") + (user-error "Node.js is not present on the exec-path. Make sure you've installed it and your exec-path is properly set"))) + +(defun cider-check-figwheel-requirements () + "Check whether we can start a Figwheel ClojureScript REPL." + (cider-verify-piggieback-is-present) + (unless (cider-library-present-p "figwheel-sidecar.repl") + (user-error "Figwheel-sidecar is not available. Please check https://docs.cider.mx/cider/basics/clojurescript for details"))) + +(defun cider-check-figwheel-main-requirements () + "Check whether we can start a Figwheel ClojureScript REPL." + (cider-verify-piggieback-is-present) + (unless (cider-library-present-p "figwheel.main") + (user-error "Figwheel-main is not available. Please check https://docs.cider.mx/cider/basics/clojurescript for details"))) + +(defun cider-check-weasel-requirements () + "Check whether we can start a Weasel ClojureScript REPL." + (cider-verify-piggieback-is-present) + (unless (cider-library-present-p "weasel.repl.server") + (user-error "Weasel in not available. Please check https://docs.cider.mx/cider/basics/clojurescript/#browser-connected-clojurescript-repl for details"))) + +(defun cider-check-boot-requirements () + "Check whether we can start a Boot ClojureScript REPL." + (cider-verify-piggieback-is-present) + (unless (cider-library-present-p "adzerk.boot-cljs-repl") + (user-error "The Boot ClojureScript REPL is not available. Please check https://github.com/adzerk-oss/boot-cljs-repl/blob/master/README.md for details"))) + +(defun cider-check-krell-requirements () + "Check whether we can start a Krell ClojureScript REPL." + (cider-verify-piggieback-is-present) + (unless (cider-library-present-p "krell.repl") + (user-error "The Krell ClojureScript REPL is not available. Please check https://github.com/vouch-opensource/krell for details"))) + +(defun cider-check-shadow-cljs-requirements () + "Check whether we can start a shadow-cljs REPL." + (unless (cider-library-present-p "shadow.cljs.devtools.api") + (user-error "The shadow-cljs ClojureScript REPL is not available. Please check https://docs.cider.mx/cider/basics/clojurescript for details"))) + +(defun cider-normalize-cljs-init-options (options) + "Normalize the OPTIONS string used for initializing a ClojureScript REPL." + (if (or (string-prefix-p "{" options) + (string-prefix-p "(" options) + (string-prefix-p "[" options) + (string-prefix-p ":" options) + (string-prefix-p "\"" options)) + options + (concat ":" options))) + +(defcustom cider-shadow-watched-builds nil + "Defines the list of builds `shadow-cljs' should watch." + :type '(repeat string) + :safe #'listp + :package-version '(cider . "1.0")) + +(defcustom cider-shadow-default-options nil + "Defines default `shadow-cljs' options." + :type 'string + :safe (lambda (s) (or (null s) (stringp s))) + :package-version '(cider . "0.18.0")) + +(defun cider--shadow-parse-builds (hash) + "Parses the build names of a shadow-cljs.edn HASH map. +The default options of `browser-repl' and `node-repl' are also included." + (let* ((builds (when (hash-table-p hash) + (gethash :builds hash))) + (build-keys (when (hash-table-p builds) + (hash-table-keys builds)))) + (append build-keys '(browser-repl node-repl)))) + +(defun cider--shadow-get-builds () + "Extract build names from the shadow-cljs.edn config file in the project root." + (let ((shadow-edn (concat (clojure-project-dir) "shadow-cljs.edn"))) + (when (file-readable-p shadow-edn) + (with-temp-buffer + (insert-file-contents shadow-edn) + (condition-case err + (let ((hash (car (parseedn-read '((shadow/env . identity) + (env . identity)))))) + (cider--shadow-parse-builds hash)) + (error + (user-error "Found an error while reading %s with message: %s" + shadow-edn + (error-message-string err)))))))) + +(defun cider-shadow-select-cljs-init-form () + "Generate the init form for a shadow-cljs select-only REPL. +We have to prompt the user to select a build, that's why this is a command, +not just a string." + (let ((form "(do (require '[shadow.cljs.devtools.api :as shadow]) (shadow/nrepl-select %s))") + (options (or cider-shadow-default-options + (completing-read "Select shadow-cljs build: " + (cider--shadow-get-builds))))) + (format form (cider-normalize-cljs-init-options options)))) + +(defun cider-shadow-cljs-init-form () + "Generate the init form for a shadow-cljs REPL. +We have to prompt the user to select a build, that's why +this is a command, not just a string." + (let* ((shadow-require "(require '[shadow.cljs.devtools.api :as shadow])") + + (default-build (cider-normalize-cljs-init-options + (or cider-shadow-default-options + (car cider-shadow-watched-builds) + (completing-read "Select shadow-cljs build: " + (cider--shadow-get-builds))))) + + (watched-builds (or (mapcar #'cider-normalize-cljs-init-options cider-shadow-watched-builds) + (list default-build))) + + (watched-builds-form (mapconcat (lambda (build) (format "(shadow/watch %s)" build)) + watched-builds + " ")) + ;; form used for user-defined builds + (user-build-form "(do %s %s (shadow/nrepl-select %s))") + ;; form used for built-in builds like :browser-repl and :node-repl + (default-build-form "(do %s (shadow/%s))")) + (if (member default-build '(":browser-repl" ":node-repl")) + (format default-build-form shadow-require (string-remove-prefix ":" default-build)) + (format user-build-form shadow-require watched-builds-form default-build)))) + +(defcustom cider-figwheel-main-default-options nil + "Defines the `figwheel.main/start' options. + +Note that figwheel-main/start can also accept a map of options, refer to +Figwheel for details." + :type 'string + :safe (lambda (s) (or (null s) (stringp s))) + :package-version '(cider . "0.18.0")) + +(defun cider--figwheel-main-get-builds () + "Extract build names from the .cljs.edn config files. +Fetches them in the project root." + (when-let ((project-dir (clojure-project-dir))) + (let ((builds (directory-files project-dir nil ".*\\.cljs\\.edn"))) + (mapcar (lambda (f) (string-match "^\\(.*\\)\\.cljs\\.edn" f) + (match-string 1 f)) + builds)))) + +(defun cider-figwheel-main-init-form () + "Produce the figwheel-main ClojureScript init form." + (let ((form "(do (require 'figwheel.main) (figwheel.main/start %s))") + (builds (cider--figwheel-main-get-builds))) + (cond + (cider-figwheel-main-default-options + (format form (cider-normalize-cljs-init-options (string-trim cider-figwheel-main-default-options)))) + + (builds + (format form (cider-normalize-cljs-init-options (completing-read "Select figwheel-main build: " builds)))) + + (t (user-error "No figwheel-main build files (.cljs.edn) were found"))))) + +(defcustom cider-custom-cljs-repl-init-form nil + "The form used to start a custom ClojureScript REPL. +When set it becomes the return value of the `cider-custom-cljs-repl-init-form' +function, which normally prompts for the init form. + +This defcustom is mostly intended for use with .dir-locals.el for +cases where it doesn't make sense to register a new ClojureScript REPL type." + :type 'string + :safe (lambda (s) (or (null s) (stringp s))) + :package-version '(cider . "0.23.0")) + +(defun cider-custom-cljs-repl-init-form () + "The form used to start a custom ClojureScript REPL. +Defaults to the value of `cider-custom-cljs-repl-init-form'. +If it's nil the function will prompt for a form. +The supplied string will be wrapped in a do form if needed." + (or + cider-custom-cljs-repl-init-form + (let ((form (read-from-minibuffer "Please, provide a form to start a ClojureScript REPL: "))) + ;; TODO: We should probably make this more robust (e.g. by using a regexp or + ;; parsing the form). + (if (string-prefix-p "(do" form) + form + (format "(do %s)" form))))) + +(defvar cider-cljs-repl-types + '((figwheel "(do (require 'figwheel-sidecar.repl-api) (figwheel-sidecar.repl-api/start-figwheel!) (figwheel-sidecar.repl-api/cljs-repl))" + cider-check-figwheel-requirements) + (figwheel-main cider-figwheel-main-init-form cider-check-figwheel-main-requirements) + (figwheel-connected "(figwheel-sidecar.repl-api/cljs-repl)" + cider-check-figwheel-requirements) + (browser "(do (require 'cljs.repl.browser) (cider.piggieback/cljs-repl (cljs.repl.browser/repl-env)))") + (node "(do (require 'cljs.repl.node) (cider.piggieback/cljs-repl (cljs.repl.node/repl-env)))" + cider-check-node-requirements) + (weasel "(do (require 'weasel.repl.websocket) (cider.piggieback/cljs-repl (weasel.repl.websocket/repl-env :ip \"127.0.0.1\" :port 9001)))" + cider-check-weasel-requirements) + (boot "(do (require 'adzerk.boot-cljs-repl) (adzerk.boot-cljs-repl/start-repl))" + cider-check-boot-requirements) + (shadow cider-shadow-cljs-init-form cider-check-shadow-cljs-requirements) + (shadow-select cider-shadow-select-cljs-init-form cider-check-shadow-cljs-requirements) + (krell "(require '[clojure.edn :as edn] + '[clojure.java.io :as io] + '[cider.piggieback] + '[krell.api :as krell] + '[krell.repl]) +(def config (edn/read-string (slurp (io/file \"build.edn\")))) +(apply cider.piggieback/cljs-repl (krell.repl/repl-env) (mapcat identity config))" + cider-check-krell-requirements) + ;; native cljs repl, no form required. + (nbb) + (custom cider-custom-cljs-repl-init-form nil)) + "A list of supported ClojureScript REPLs. + +For each one we have its name, and then, if the repl is not a native +ClojureScript REPL, the form we need to evaluate in a Clojure REPL to +switch to the ClojureScript REPL and functions to verify their +requirements. + +The form, if any, should be either a string or a function producing a +string.") + +(defun cider-register-cljs-repl-type (type &optional init-form requirements-fn) + "Register a new ClojureScript REPL type. + +Types are defined by the following: + +- TYPE - symbol identifier that will be used to refer to the REPL type +- INIT-FORM - (optional) string or function (symbol) producing string +- REQUIREMENTS-FN - function to check whether the REPL can be started. +This param is optional. + +All this function does is modifying `cider-cljs-repl-types'. +It's intended to be used in your Emacs config." + (unless (symbolp type) + (user-error "The REPL type must be a symbol")) + (unless (or (null init-form) (stringp init-form) (symbolp init-form)) + (user-error "The init form must be a string or a symbol referring to a function or nil")) + (unless (or (null requirements-fn) (symbolp requirements-fn)) + (user-error "The requirements-fn must be a symbol referring to a function")) + (add-to-list 'cider-cljs-repl-types (list type init-form requirements-fn))) + +(defcustom cider-default-cljs-repl nil + "The default ClojureScript REPL to start. +This affects commands like `cider-jack-in-cljs'. Generally it's +intended to be set via .dir-locals.el for individual projects, as it's +relatively unlikely you'd like to use the same type of REPL in each project +you're working on." + :type '(choice (const :tag "Figwheel" figwheel) + (const :tag "Figwheel Main" figwheel-main) + (const :tag "Browser" browser) + (const :tag "Node" node) + (const :tag "Weasel" weasel) + (const :tag "Boot" boot) + (const :tag "Shadow" shadow) + (const :tag "Shadow w/o Server" shadow-select) + (const :tag "Krell" krell) + (const :tag "Nbb" nbb) + (const :tag "Basilisp" basilisp) + (const :tag "Custom" custom)) + :safe #'symbolp + :package-version '(cider . "0.17.0")) + +(defvar cider--select-cljs-repl-history nil) +(defun cider-select-cljs-repl (&optional default) + "Select the ClojureScript REPL to use with `cider-jack-in-cljs'. +DEFAULT is the default ClojureScript REPL to offer in completion." + (let ((repl-types (mapcar #'car cider-cljs-repl-types))) + (intern (completing-read "Select ClojureScript REPL type: " repl-types + nil nil nil 'cider--select-cljs-repl-history + (or default (car cider--select-cljs-repl-history)))))) + +(defun cider-cljs-repl-form (repl-type) + "Get the cljs REPL form for REPL-TYPE, if any." + (if-let* ((repl-type-info (seq-find + (lambda (entry) + (eq (car entry) repl-type)) + cider-cljs-repl-types))) + (when-let ((repl-form (cadr repl-type-info))) + ;; repl-form can be either a string or a function producing a string + (if (symbolp repl-form) + (funcall repl-form) + repl-form)) + (user-error "No ClojureScript REPL type %s found. Please make sure that `cider-cljs-repl-types' has an entry for it" repl-type))) + +(defun cider-verify-cljs-repl-requirements (&optional repl-type) + "Verify that the requirements for REPL-TYPE are met. +Return REPL-TYPE if requirements are met." + (let ((repl-type (or repl-type + cider-default-cljs-repl + (cider-select-cljs-repl)))) + (when cider-check-cljs-repl-requirements + (when-let* ((fun (nth 2 (seq-find + (lambda (entry) + (eq (car entry) repl-type)) + cider-cljs-repl-types)))) + (funcall fun))) + repl-type)) + +(defun cider--check-cljs (&optional cljs-type no-error) + "Verify that all cljs requirements are met for CLJS-TYPE connection. +Return REPL-TYPE of requirement are met, and throw an ‘user-error’ otherwise. +When NO-ERROR is non-nil, don't throw an error, issue a message and return +nil." + (if no-error + (condition-case ex + (progn + (cider-verify-clojurescript-is-present) + (cider-verify-cljs-repl-requirements cljs-type)) + (error + (message "Invalid ClojureScript dependency: %S" ex) + nil)) + (cider-verify-clojurescript-is-present) + (cider-verify-cljs-repl-requirements cljs-type))) + +(defun cider--offer-to-open-app-in-browser (server-buffer) + "Look for a server address in SERVER-BUFFER and offer to open it." + (when (buffer-live-p server-buffer) + (with-current-buffer server-buffer + (save-excursion + (goto-char (point-min)) + (when-let* ((url (and (search-forward-regexp "http://localhost:[0-9]+" nil 'noerror) + (match-string 0)))) + (when (y-or-n-p (format "Visit ‘%s’ in a browser? " url)) + (browse-url url))))))) + + +;;; User Level Connectors + +;;;###autoload (autoload 'cider-start-map "cider" "CIDER jack-in and connect keymap." t 'keymap) +(defvar cider-start-map + (let ((map (define-prefix-command 'cider-start-map))) + (define-key map (kbd "x") #'cider) + (define-key map (kbd "C-x") #'cider) + (define-key map (kbd "j j") #'cider-jack-in-clj) + (define-key map (kbd "j s") #'cider-jack-in-cljs) + (define-key map (kbd "j m") #'cider-jack-in-clj&cljs) + (define-key map (kbd "j u") #'cider-jack-in-universal) + (define-key map (kbd "j n") #'cider-start-nrepl-server) + (define-key map (kbd "C-j j") #'cider-jack-in-clj) + (define-key map (kbd "C-j s") #'cider-jack-in-cljs) + (define-key map (kbd "C-j m") #'cider-jack-in-clj&cljs) + (define-key map (kbd "C-j n") #'cider-start-nrepl-server) + (define-key map (kbd "C-j C-j") #'cider-jack-in-clj) + (define-key map (kbd "C-j C-s") #'cider-jack-in-cljs) + (define-key map (kbd "C-j C-m") #'cider-jack-in-clj&cljs) + (define-key map (kbd "C-j C-n") #'cider-start-nrepl-server) + (define-key map (kbd "c j") #'cider-connect-clj) + (define-key map (kbd "c s") #'cider-connect-cljs) + (define-key map (kbd "c m") #'cider-connect-clj&cljs) + (define-key map (kbd "C-c j") #'cider-connect-clj) + (define-key map (kbd "C-c s") #'cider-connect-cljs) + (define-key map (kbd "C-c m") #'cider-connect-clj&cljs) + (define-key map (kbd "C-c C-j") #'cider-connect-clj) + (define-key map (kbd "C-c C-s") #'cider-connect-cljs) + (define-key map (kbd "C-c C-m") #'cider-connect-clj&cljs) + (define-key map (kbd "s j") #'cider-connect-sibling-clj) + (define-key map (kbd "s s") #'cider-connect-sibling-cljs) + (define-key map (kbd "C-s j") #'cider-connect-sibling-clj) + (define-key map (kbd "C-s s") #'cider-connect-sibling-cljs) + (define-key map (kbd "C-s C-j") #'cider-connect-sibling-clj) + (define-key map (kbd "C-s C-s") #'cider-connect-sibling-cljs) + map) + "CIDER jack-in and connect keymap.") + +(defun cider--start-nrepl-server (params &optional on-port-callback) + "Start an nREPL server. +PARAMS is a plist optionally containing :project-dir and :jack-in-cmd. +ON-PORT-CALLBACK (optional) is a function of one argument (server buffer) +which is called by the process filter once the port of the connection has +been determined." + (nrepl-start-server-process + (plist-get params :project-dir) + (plist-get params :jack-in-cmd) + on-port-callback)) + +(defun cider--update-params (params) + "Fill-in the passed in PARAMS plist needed to start an nREPL server. +Updates :project-dir and :jack-in-cmd. +Also checks whether a matching session already exists." + (thread-first params + (cider--update-project-dir) + (cider--check-existing-session) + (cider--update-jack-in-cmd))) + +;;;###autoload +(defun cider-jack-in-clj (params) + "Start an nREPL server for the current project and connect to it. +PARAMS is a plist optionally containing :project-dir and :jack-in-cmd. +With the prefix argument, allow editing of the jack in command; with a +double prefix prompt for all these parameters." + (interactive "P") + (let ((params (cider--update-params params))) + (cider--start-nrepl-server + params + (lambda (server-buffer) + (cider-connect-sibling-clj params server-buffer))))) + +(defun cider-start-nrepl-server (params) + "Start an nREPL server for the current project, but don't connect to it. +PARAMS is a plist optionally containing :project-dir and :jack-in-cmd. +With the prefix argument, allow editing of the start server command; with a +double prefix prompt for all these parameters." + (interactive "P") + (cider--start-nrepl-server (cider--update-params params))) + +;;;###autoload +(defun cider-jack-in-cljs (params) + "Start an nREPL server for the current project and connect to it. +PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and +:cljs-repl-type (e.g. 'shadow, 'node, 'figwheel, etc). + +With the prefix argument, +allow editing of the jack in command; with a double prefix prompt for all +these parameters." + (interactive "P") + (let ((cider-enrich-classpath nil) ;; ensure it's disabled for cljs projects, for now + (cider-jack-in-dependencies (append cider-jack-in-dependencies cider-jack-in-cljs-dependencies)) + (cider-jack-in-lein-plugins (append cider-jack-in-lein-plugins cider-jack-in-cljs-lein-plugins)) + (cider-jack-in-nrepl-middlewares (append cider-jack-in-nrepl-middlewares cider-jack-in-cljs-nrepl-middlewares)) + (orig-buffer (current-buffer))) + ;; cider--update-jack-in-cmd relies indirectly on the above dynamic vars + (let ((params (thread-first params + (cider--update-project-dir) + (cider--check-existing-session) + (cider--update-jack-in-cmd)))) + (nrepl-start-server-process + (plist-get params :project-dir) + (plist-get params :jack-in-cmd) + (lambda (server-buffer) + (with-current-buffer orig-buffer + (cider-connect-sibling-cljs params server-buffer))))))) + +;;;###autoload +(defun cider-jack-in-clj&cljs (&optional params soft-cljs-start) + "Start an nREPL server and connect with clj and cljs REPLs. +PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and +:cljs-repl-type (e.g. 'shadow, 'node, 'fighweel, etc). + +With the prefix argument, allow for editing of the jack in command; +with a double prefix prompt for all these parameters. + +When SOFT-CLJS-START is non-nil, start cljs REPL +only when the ClojureScript dependencies are met." + (interactive "P") + (let ((cider-enrich-classpath nil) ;; ensure it's disabled for cljs projects, for now + (cider-jack-in-dependencies (append cider-jack-in-dependencies cider-jack-in-cljs-dependencies)) + (cider-jack-in-lein-plugins (append cider-jack-in-lein-plugins cider-jack-in-cljs-lein-plugins)) + (cider-jack-in-nrepl-middlewares (append cider-jack-in-nrepl-middlewares cider-jack-in-cljs-nrepl-middlewares)) + (orig-buffer (current-buffer))) + ;; cider--update-jack-in-cmd relies indirectly on the above dynamic vars + (let ((params (thread-first params + (cider--update-project-dir) + (cider--check-existing-session) + (cider--update-jack-in-cmd) + (cider--update-cljs-type) + ;; already asked, don't ask on sibling connect + (plist-put :do-prompt nil)))) + (nrepl-start-server-process + (plist-get params :project-dir) + (plist-get params :jack-in-cmd) + (lambda (server-buffer) + (with-current-buffer orig-buffer + (let ((clj-repl (cider-connect-sibling-clj params server-buffer))) + (if soft-cljs-start + (when (cider--check-cljs (plist-get params :cljs-repl-type) 'no-error) + (cider-connect-sibling-cljs params clj-repl)) + (cider-connect-sibling-cljs params clj-repl))))))))) + +;;;###autoload +(defun cider-connect-sibling-clj (params &optional other-repl) + "Create a Clojure REPL with the same server as OTHER-REPL. +PARAMS is for consistency with other connection commands and is currently +ignored. OTHER-REPL defaults to `cider-current-repl' and in programs can +also be a server buffer, in which case a new session with a REPL for that +server is created." + (interactive "P") + (cider-nrepl-connect + (let* ((other-repl (or other-repl (cider-current-repl 'any 'ensure))) + (other-params (cider--gather-connect-params nil other-repl)) + (ses-name (unless (nrepl-server-p other-repl) + (sesman-session-name-for-object 'CIDER other-repl)))) + (thread-first params + (cider--update-do-prompt) + (append other-params) + (plist-put :repl-init-function nil) + (plist-put :repl-type 'clj) + (plist-put :session-name ses-name))))) + +;;;###autoload +(defun cider-connect-sibling-cljs (params &optional other-repl) + "Create a ClojureScript REPL with the same server as OTHER-REPL. +PARAMS is a plist optionally containing :cljs-repl-type (e.g. 'node, +'figwheel, 'shadow, etc). + +All other parameters are inferred from the OTHER-REPL. +OTHER-REPL defaults to `cider-current-repl' but in programs can also be a +server buffer, in which case a new session for that server is created." + (interactive "P") + (let* ((other-repl (or other-repl (cider-current-repl 'any 'ensure))) + (other-params (cider--gather-connect-params nil other-repl)) + ;; type-related params from the JVM conn are undesired for a cljs conn: + (other-params (thread-first other-params (map-delete :repl-type) (map-delete :cljs-repl-type))) + (ses-name (unless (nrepl-server-p other-repl) + (sesman-session-name-for-object 'CIDER other-repl)))) + (cider-nrepl-connect + (thread-first params + (cider--update-do-prompt) + (append other-params) + (cider--update-cljs-type) + (cider--update-cljs-init-function) + (plist-put :session-name ses-name) + (plist-put :repl-type 'cljs))))) + +;;;###autoload +(defun cider-connect-clj (&optional params) + "Initialize a Clojure connection to an nREPL server. +PARAMS is a plist optionally containing :host, :port and :project-dir. On +prefix argument, prompt for all the parameters." + (interactive "P") + (cider-nrepl-connect + (thread-first params + (cider--update-project-dir) + (cider--update-host-port) + (cider--check-existing-session) + (plist-put :repl-init-function nil) + (plist-put :session-name nil) + (plist-put :repl-type 'clj)))) + +;;;###autoload +(defun cider-connect-cljs (&optional params) + "Initialize a ClojureScript connection to an nREPL server. +PARAMS is a plist optionally containing :host, :port, :project-dir and +:cljs-repl-type (e.g. 'shadow, 'node, 'figwheel, etc). + +On prefix, prompt for all the +parameters regardless of their supplied or default values." + (interactive "P") + (cider-nrepl-connect + (thread-first params + (cider--update-project-dir) + (cider--update-host-port) + (cider--check-existing-session) + (cider--update-cljs-type) + (cider--update-cljs-init-function) + (plist-put :session-name nil) + (plist-put :repl-type 'cljs)))) + +;;;###autoload +(defun cider-connect-clj&cljs (params &optional soft-cljs-start) + "Initialize a Clojure and ClojureScript connection to an nREPL server. +PARAMS is a plist optionally containing :host, :port, :project-dir and +:cljs-repl-type (e.g. 'shadow, 'node, 'figwheel, etc). When SOFT-CLJS-START is +non-nil, don't start if ClojureScript requirements are not met." + (interactive "P") + (let* ((params (thread-first params + (cider--update-project-dir) + (cider--update-host-port) + (cider--check-existing-session) + (cider--update-cljs-type))) + (clj-params (thread-first params + copy-sequence + (map-delete :cljs-repl-type))) + (clj-repl (cider-connect-clj clj-params))) + (when (if soft-cljs-start + (cider--check-cljs (plist-get params :cljs-repl-type) 'no-error) + t) + (cider-connect-sibling-cljs params clj-repl)))) + +(defvar cider-connection-init-commands + '(cider-jack-in-clj + cider-jack-in-cljs + cider-jack-in-clj&cljs + cider-connect-clj + cider-connect-cljs + cider-connect-clj&cljs + cider-connect-sibling-clj + cider-connect-sibling-cljs) + "A list of all user-level connection init commands in CIDER.") + +;;;###autoload +(defun cider () + "Start a connection of any type interactively." + (interactive) + (when-let* ((command (intern (completing-read "Select command: " cider-connection-init-commands)))) + (call-interactively command))) + + +;;; PARAMS updating + +(defun cider--update-do-prompt (params) + "Update :do-prompt in PARAMS." + (cond ((equal params '(4)) (list :edit-jack-in-command t)) + ((equal params '(16)) (list :do-prompt t)) + (t params))) + +(defun cider--update-project-dir (params) + "Update :project-dir in PARAMS. + +Params is a plist with the following keys (non-exhaustive) + + :edit-project-dir prompt (optional) ask user to confirm the project root + directory." + (let* ((params (cider--update-do-prompt params)) + (proj-dir (if (or (plist-get params :do-prompt) + (plist-get params :edit-project-dir)) + (read-directory-name "Project: " + (clojure-project-dir (cider-current-dir))) + (plist-get params :project-dir))) + (orig-buffer (current-buffer))) + (if (or (null proj-dir) + (file-in-directory-p default-directory proj-dir)) + (plist-put params :project-dir + (or proj-dir + (clojure-project-dir (cider-current-dir)))) + ;; If proj-dir is not a parent of default-directory, transfer all local + ;; variables and hack dir-local variables into a temporary buffer and keep + ;; that buffer within `params` for the later use by other --update- + ;; functions. The context buffer should not be used outside of the param + ;; initialization pipeline. Therefore, we don't bother with making it + ;; unique or killing it anywhere. + (let ((context-buf-name " *cider-context-buffer*")) + (when (get-buffer context-buf-name) + (kill-buffer context-buf-name)) + (with-current-buffer (get-buffer-create context-buf-name) + (dolist (pair (buffer-local-variables orig-buffer)) + (pcase pair + (`(,name . ,value) ;ignore unbound variables + (ignore-errors (set (make-local-variable name) value)))) + (setq-local buffer-file-name nil)) + (let ((default-directory proj-dir)) + (hack-dir-local-variables-non-file-buffer) + (thread-first params + (plist-put :project-dir proj-dir) + (plist-put :--context-buffer (current-buffer))))))))) + +(defun cider--update-cljs-type (params) + "Update :cljs-repl-type in PARAMS." + (with-current-buffer (or (plist-get params :--context-buffer) + (current-buffer)) + (let ((params (cider--update-do-prompt params)) + (inferred-type (or (plist-get params :cljs-repl-type) + cider-default-cljs-repl))) + (plist-put params :cljs-repl-type + (if (plist-get params :do-prompt) + (cider-select-cljs-repl inferred-type) + (or inferred-type + (cider-select-cljs-repl))))))) + +(defcustom cider-edit-jack-in-command nil + "When truthy allow the user to edit the command." + :type 'boolean + :safe #'booleanp + :version '(cider . "0.22.0")) + +(defvar cider--jack-in-nrepl-params-history nil + "History list for user-specified jack-in nrepl command params.") + +(defvar cider--jack-in-cmd-history nil + "History list for user-specified jack-in commands.") + +(defun cider--format-cmd (command-resolved command cmd-params) + "Format COMMAND-RESOLVED or COMMAND followed by CMD-PARAMS." + (format "%s %s" command-resolved + (if (cider--jack-in-cmd-powershell-p command) + (cider--powershell-encode-command cmd-params) + cmd-params))) + +(defun cider--update-jack-in-cmd (params) + "Update :jack-in-cmd key in PARAMS. + +PARAMS is a plist with the following keys (non-exhaustive list) + +:project-type optional, the project type to create the command for; see +`cider-jack-in-command' for the list of valid types)." + (cond + ((plist-get params :jack-in-cmd) params) + (cider-jack-in-cmd (plist-put params :jack-in-cmd cider-jack-in-cmd)) + (t (let* ((params (cider--update-do-prompt params)) + (project-dir (plist-get params :project-dir)) + (params-project-type (plist-get params :project-type)) + (project-type (or params-project-type + (cider-project-type project-dir))) + (command (cider-jack-in-command project-type)) + (command-resolved (cider-jack-in-resolve-command project-type)) + ;; TODO: global-options are deprecated and should be removed in CIDER 2.0 + (command-global-opts (cider-jack-in-global-options project-type)) + (command-params (cider-jack-in-params project-type))) + (if command-resolved + (with-current-buffer (or (plist-get params :--context-buffer) + (current-buffer)) + (let* ((command-params (if (plist-get params :do-prompt) + (read-string "nREPL server command: " + command-params + 'cider--jack-in-nrepl-params-history) + command-params)) + (cmd-params (if cider-inject-dependencies-at-jack-in + (cider-inject-jack-in-dependencies command-global-opts command-params + project-type command) + command-params))) + (if (or project-dir cider-allow-jack-in-without-project) + (when (or project-dir + (eq cider-allow-jack-in-without-project t) + (and (null project-dir) + (eq cider-allow-jack-in-without-project 'warn) + (or params-project-type + (y-or-n-p "Are you sure you want to run `cider-jack-in' without a Clojure project? ")))) + (let* ((cmd (cider--format-cmd command-resolved command cmd-params)) + (edited-command (if (or cider-edit-jack-in-command + (plist-get params :edit-jack-in-command)) + (read-string "jack-in command: " cmd 'cider--jack-in-cmd-history) + cmd))) + (plist-put params :jack-in-cmd edited-command))) + (user-error "`cider-jack-in' is not allowed without a Clojure project")))) + (user-error "The %s executable isn't on your `exec-path'" command)))))) + +(defun cider--update-host-port (params) + "Update :host and :port; or :socket-file in PARAMS." + (with-current-buffer (or (plist-get params :--context-buffer) + (current-buffer)) + (let* ((params (cider--update-do-prompt params)) + (host (plist-get params :host)) + (port (plist-get params :port)) + (endpoint (if (plist-get params :do-prompt) + (cider-select-endpoint) + (if (and host port) + (cons host port) + (cider-select-endpoint))))) + (if (equal "local-unix-domain-socket" (car endpoint)) + (plist-put params :socket-file (cdr endpoint)) + (thread-first params + (plist-put :host (car endpoint)) + (plist-put :port (cdr endpoint))))))) + +(defun cider--update-cljs-init-function (params) + "Update repl type and any init PARAMS for cljs connections. + +The updated params are: + +:cider-repl-cljs-upgrade-pending nil if it is a cljs REPL, or t +when the init form is required to be sent to the REPL to switch +over to cljs. + +:repl-init-form The form that can switch the REPL over to cljs. + +:repl-init-function The fn that switches the REPL over to cljs." + (with-current-buffer (or (plist-get params :--context-buffer) + (current-buffer)) + (let* ((cljs-type (plist-get params :cljs-repl-type)) + (repl-init-form (cider-cljs-repl-form cljs-type))) + (if (null repl-init-form) + (plist-put params :cider-repl-cljs-upgrade-pending nil) + + (thread-first params + (plist-put :cider-repl-cljs-upgrade-pending t) + (plist-put :repl-init-function + (lambda () + (cider--check-cljs cljs-type) + (cider-nrepl-send-request + (list "op" "eval" + "ns" (cider-current-ns) + "code" repl-init-form) + (cider-repl-handler (current-buffer))) + (when (and (buffer-live-p nrepl-server-buffer) + cider-offer-to-open-cljs-app-in-browser) + (cider--offer-to-open-app-in-browser nrepl-server-buffer)))) + (plist-put :repl-init-form repl-init-form)))))) + +(defun cider--check-existing-session (params) + "Ask for confirmation if a session with similar PARAMS already exists. +If no session exists or user chose to proceed, return PARAMS. If the user +canceled the action, signal quit." + (let* ((proj-dir (plist-get params :project-dir)) + (host (plist-get params :host)) + (port (plist-get params :port)) + (session (seq-find (lambda (ses) + (let ((ses-params (cider--gather-session-params ses))) + (and (equal proj-dir (plist-get ses-params :project-dir)) + (or (null port) + (equal port (plist-get ses-params :port))) + (or (null host) + (equal host (plist-get ses-params :host)))))) + (sesman-current-sessions 'CIDER '(project))))) + (when session + (unless (y-or-n-p + (concat + "A CIDER session with the same connection parameters already exists (" (car session) "). " + "Are you sure you want to create a new session instead of using `cider-connect-sibling-clj(s)'? ")) + (let ((debug-on-quit nil)) + (signal 'quit nil))))) + params) + + +;;; Aliases + +;;;###autoload +(defalias 'cider-jack-in #'cider-jack-in-clj) +;;;###autoload +(defalias 'cider-connect #'cider-connect-clj) + + +;;; Helpers + +(defun cider-current-host () + "Retrieve the current host." + (or (when (stringp buffer-file-name) + (file-remote-p buffer-file-name 'host)) + "localhost")) + +(defun cider-select-endpoint () + "Interactively select the host and port to connect to." + (dolist (endpoint cider-known-endpoints) + (unless (stringp (or (nth 2 endpoint) + (nth 1 endpoint))) + (user-error "The port for %s in `cider-known-endpoints' should be a string" + (nth 0 endpoint)))) + (let* ((ssh-hosts (cider--ssh-hosts)) + (hosts (seq-uniq (append (when cider-host-history + ;; history elements are strings of the form "host:port" + (list (split-string (car cider-host-history) ":"))) + (list (list (cider-current-host))) + cider-known-endpoints + ssh-hosts + ;; always add localhost + '(("localhost") + ("local-unix-domain-socket"))))) + (sel-host (cider--completing-read-host hosts)) + (host (car sel-host)) + (port (or (cadr sel-host) + (if (equal host "local-unix-domain-socket") + (cider--completing-read-socket-file) + (cider--completing-read-port host (cider--infer-ports host ssh-hosts)))))) + (cons host port))) + +(defun cider--ssh-hosts () + "Retrieve all ssh host from local configuration files." + (seq-map (lambda (s) (list (replace-regexp-in-string ":$" "" s))) + ;; `tramp-completion-mode' is obsoleted in 26 + (cl-progv (if (version< emacs-version "26") + '(tramp-completion-mode) + '(non-essential)) '(t) + (tramp-completion-handle-file-name-all-completions "" "/ssh:")))) + +(defun cider--completing-read-host (hosts) + "Interactively select host from HOSTS. +Each element in HOSTS is one of: (host), (host port) or (label host port). +Return a list of the form (HOST PORT), where PORT can be nil." + (let* ((hosts (cider-join-into-alist hosts)) + (sel-host (completing-read "Host: " hosts nil nil nil + 'cider-host-history (caar hosts))) + (host (or (cdr (assoc sel-host hosts)) (list sel-host)))) + ;; remove the label + (if (= 3 (length host)) (cdr host) host))) + +(defun cider--tramp-file-name (vec) + "A simple compatibility wrapper around `make-tramp-file-name'. +Tramp version starting 26.1 is using a `cl-defstruct' rather than vanilla VEC." + (if (version< emacs-version "26.1") + vec + (with-no-warnings + (make-tramp-file-name :method (elt vec 0) + :host (elt vec 2))))) + +(defcustom cider-infer-remote-nrepl-ports nil + "When true, cider will use ssh to try to infer nREPL ports on remote hosts." + :type 'boolean + :safe #'booleanp + :package-version '(cider . "0.19.0")) + +(defun cider--infer-ports (host ssh-hosts) + "Infer nREPL ports on HOST. +Return a list of elements of the form (directory port). SSH-HOSTS is a list +of remote SSH hosts." + (let ((localp (or (nrepl-local-host-p host) + (not (assoc-string host ssh-hosts))))) + (if localp + ;; change dir: current file might be remote + (let* ((change-dir-p (file-remote-p default-directory)) + (default-directory (if change-dir-p "~/" default-directory))) + (cider-locate-running-nrepl-ports (unless change-dir-p default-directory))) + (when cider-infer-remote-nrepl-ports + (let ((vec (vector "sshx" nil host "" nil)) + ;; change dir: user might want to connect to a different remote + (dir (when (file-remote-p default-directory) + (with-parsed-tramp-file-name default-directory cur + (when (string= cur-host host) default-directory))))) + (tramp-maybe-open-connection (cider--tramp-file-name vec)) + (with-current-buffer (tramp-get-connection-buffer (cider--tramp-file-name vec)) + (cider-locate-running-nrepl-ports dir))))))) + +(defun cider--completing-read-port (host ports) + "Interactively select port for HOST from PORTS." + (let* ((ports (cider-join-into-alist ports)) + (sel-port (completing-read (format "Port for %s: " host) ports + nil nil nil nil (caar ports))) + (port (or (cdr (assoc sel-port ports)) sel-port)) + (port (if (listp port) (cadr port) port))) + (if (stringp port) (string-to-number port) port))) + +(defun cider--completing-read-socket-file () + "Interactively select unix domain socket file name." + (read-file-name "Socket File: " nil nil t nil + (lambda (filename) + "Predicate: auto-complete only socket-files and directories" + (let ((filetype (string-to-char + (file-attribute-modes + (file-attributes + filename))))) + (or (eq ?s filetype) + (eq ?d filetype)))))) + +(defun cider--path->path-port-pairs (path) + "Given PATH, returns all the possible pairs." + (thread-last path + cider--file-path + nrepl-extract-ports + (mapcar (lambda (port) + (list path port))) + ;; remove nils that may have been returned due to permission errors: + (seq-filter #'identity))) + +(defun cider--invoke-running-nrepl-path (f) + "Invokes F safely. + +Necessary since we run some OS-specific commands that may fail." + (condition-case nil + (let* ((x (funcall f))) + (mapcar (lambda (v) + (if (and (listp v) + (not (file-exists-p (car v)))) + nil + v)) + x)) + (error nil))) + +(defun cider-locate-running-nrepl-ports (&optional dir) + "Locate ports of running nREPL servers. +When DIR is non-nil also look for nREPL port files in DIR. Return a list +of list of the form (project-dir port)." + (let* ((pairs (cider--running-nrepl-paths)) + (pairs (if-let (c (and dir (clojure-project-dir dir))) + (append (cider--path->path-port-pairs c) pairs) + pairs))) + (thread-last pairs + (delq nil) + (mapcar (lambda (x) + (list (file-name-nondirectory (directory-file-name (car x))) + (nth 1 x)))) + (seq-uniq)))) + +(defun cider--running-lein-nrepl-paths () + "Retrieve project paths of running lein nREPL servers. +Use `cider-ps-running-lein-nrepls-command' and +`cider-ps-running-lein-nrepl-path-regexp-list'." + (unless (eq system-type 'windows-nt) + (let (paths) + (with-temp-buffer + (insert (shell-command-to-string cider-ps-running-lein-nrepls-command)) + (dolist (regexp cider-ps-running-lein-nrepl-path-regexp-list) + (goto-char 1) + (while (re-search-forward regexp nil t) + (setq paths (cons (match-string 1) paths))))) + (seq-mapcat (lambda (path) + (cider--path->path-port-pairs path)) + paths)))) + +(defun cider--running-non-lein-nrepl-paths () + "Retrieve (directory, port) pairs of running nREPL servers other than Lein ones." + (unless (eq system-type 'windows-nt) + (let* ((bb-indicator "--nrepl-server") + (non-lein-nrepl-pids + (thread-last (split-string + (shell-command-to-string + ;; some of the `ps u` lines we intend to catch: + ;; 15411 0.0 0.0 37915744 16084 s000 S+ 3:02PM 0:00.02 bb --nrepl-server + ;; 13835 0.1 11.2 37159036 7528432 s009 S+ 2:47PM 6:41.29 java -cp src -m nrepl.cmdline + (format "ps u | grep -E 'java|%s' | grep -E 'nrepl.cmdline|%s' | grep -v -E 'leiningen|grep'" + bb-indicator + bb-indicator)) + "\n") + (mapcar (lambda (s) + (nth 1 (split-string s " ")))) + (seq-filter #'identity)))) + (when non-lein-nrepl-pids + (thread-last non-lein-nrepl-pids + (mapcar (lambda (pid) + (let* ( + ;; -a: This flag is used to combine conditions with AND instead of OR + ;; -d: Lists only the file descriptors that match the given + ;; -n: Inhibits the conversion of network numbers to host names. + ;; -Fn: output file entry information as separate lines, with 'n' designating network info. + ;; -p: specifies the . + (directory (thread-last (split-string (shell-command-to-string (concat "lsof -a -d cwd -n -Fn -p " pid)) + "\n") + (seq-map (lambda (s) + (when (string-prefix-p "n" s) + (replace-regexp-in-string "^n" "" s)))) + (seq-filter #'identity) + car)) + ;; -a: This flag is used to combine conditions with AND instead of OR + ;; -n: Inhibits the conversion of network numbers to host names. + ;; -P: (important!) Ensure ports are shown as numbers, even if they have a well-known name. + ;; -Fn: output file entry information as separate lines, with 'n' designating network info. + ;; -i: this option selects the listing of all network files. + ;; -p: specifies the . + (port (thread-last (split-string (shell-command-to-string (concat "lsof -n -P -Fn -i -a -p " pid)) + "\n") + (seq-map (lambda (s) + (when (string-prefix-p "n" s) + (replace-regexp-in-string ".*:" "" s)))) + (seq-filter #'identity) + (seq-filter (lambda (s) + (condition-case nil + (numberp (read s)) + (error nil)))) + car))) + (list directory port)))) + (seq-filter #'cadr)))))) + +(defun cider--running-local-nrepl-paths () + "Retrieve project paths of running nREPL servers. +Do it by looping over the open REPL buffers." + (thread-last (buffer-list) + (seq-filter + (lambda (b) + (string-prefix-p "*cider-repl" (buffer-name b)))) + (seq-map + (lambda (b) + (with-current-buffer b + (when-let ((dir (plist-get (cider--gather-connect-params) :project-dir)) + (port (plist-get (cider--gather-connect-params) :port))) + (list dir (prin1-to-string port)))))) + (seq-filter #'identity))) + +(defun cider--running-nrepl-paths () + "Retrieve project paths of running nREPL servers. +Search for lein or java processes including nrepl.command nREPL." + (append (cider--invoke-running-nrepl-path #'cider--running-lein-nrepl-paths) + (cider--invoke-running-nrepl-path #'cider--running-local-nrepl-paths) + (cider--invoke-running-nrepl-path #'cider--running-non-lein-nrepl-paths))) + +(defun cider--identify-buildtools-present (&optional project-dir) + "Identify build systems present by their build files in PROJECT-DIR. +PROJECT-DIR defaults to current project." + (let* ((default-directory (or project-dir (clojure-project-dir (cider-current-dir)))) + (build-files '((lein . "project.clj") + (boot . "build.boot") + (clojure-cli . "deps.edn") + (babashka . "bb.edn") + (shadow-cljs . "shadow-cljs.edn") + (gradle . "build.gradle") + (gradle . "build.gradle.kts") + (nbb . "nbb.edn") + (basilisp . "basilisp.edn")))) + (delq nil + (mapcar (lambda (candidate) + (when (file-exists-p (cdr candidate)) + (car candidate))) + build-files)))) + +(defun cider-project-type (&optional project-dir) + "Determine the type of the project in PROJECT-DIR. +When multiple project file markers are present, check for a preferred build +tool in `cider-preferred-build-tool', otherwise prompt the user to choose. +PROJECT-DIR defaults to the current project." + (let* ((choices (cider--identify-buildtools-present project-dir)) + (multiple-project-choices (> (length choices) 1)) + ;; this needs to be a string to be used in `completing-read' + (default (symbol-name (car choices))) + ;; `cider-preferred-build-tool' used to be a string prior to CIDER + ;; 0.18, therefore the need for `cider-maybe-intern' + (preferred-build-tool (cider-maybe-intern cider-preferred-build-tool))) + (cond ((and multiple-project-choices + (member preferred-build-tool choices)) + preferred-build-tool) + (multiple-project-choices + (intern + (completing-read + (format "Which command should be used (default %s): " default) + choices nil t nil nil default))) + (choices + (car choices)) + ;; TODO: Move this fallback outside the project-type check + ;; if we're outside a project we fallback to whatever tool + ;; is specified in `cider-jack-in-default' (normally clojure-cli) + ;; `cider-jack-in-default' used to be a string prior to CIDER + ;; 0.18, therefore the need for `cider-maybe-intern' + (t (cider-maybe-intern cider-jack-in-default))))) + +;;;###autoload +(defun cider-jack-in-universal (arg) + "Start and connect to an nREPL server for the current project or ARG project id. + +If a project is found in current dir, call `cider-jack-in' passing ARG as +first parameter, of which see. Otherwise, ask user which project type to +start an nREPL server and connect to without a project. + +But if invoked with a numeric prefix ARG, then start an nREPL server for +the project type denoted by ARG number and connect to it, even if there is +no project for it in the current dir. + +The supported project tools and their assigned numeric prefix ids are +sourced from `cider-jack-in-universal-options', of which see. + +You can pass a numeric prefix argument n with `M-n` or `C-u n`. + +For example, to jack in to leiningen which is assigned to prefix arg 2 type + +M-2 \\[cider-jack-in-universal]." + (interactive "P") + (let ((cpt (clojure-project-dir (cider-current-dir)))) + (if (or (integerp arg) (null cpt)) + (let* ((project-types-available (mapcar #'car cider-jack-in-universal-options)) + (project-type (if (null arg) + (intern (completing-read + "No project found in current dir, select project type to jack in: " + project-types-available + nil t)) + + (or (seq-some (lambda (elt) + (cl-destructuring-bind + (project-type (&key prefix-arg &allow-other-keys)) elt + (when (= arg prefix-arg) + project-type))) + cider-jack-in-universal-options) + (error ":cider-jack-in-universal :unsupported-prefix-argument %S :no-such-project" + arg)))) + (project-options (cadr (seq-find (lambda (elt) (equal project-type (car elt))) + cider-jack-in-universal-options))) + (jack-in-opts (plist-get project-options :cmd)) + (jack-in-type (plist-get jack-in-opts :jack-in-type))) + (pcase jack-in-type + ('clj (cider-jack-in-clj jack-in-opts)) + ('cljs (cider-jack-in-cljs jack-in-opts)) + (_ (error ":cider-jack-in-universal :jack-in-type-unsupported %S" jack-in-type)))) + + (cider-jack-in-clj arg)))) + + +;; TODO: Implement a check for command presence over tramp +(defun cider--resolve-command (command) + "Find COMMAND in exec path (see variable `exec-path'). +Return nil if not found. In case `default-directory' is non-local we +assume the command is available." + (when-let* ((command (or (and (file-remote-p default-directory) command) + (executable-find command) + (executable-find (concat command ".bat"))))) + (shell-quote-argument command))) + +(defun cider--resolve-project-command (command) + "Find COMMAND in project dir or exec path (see variable `exec-path'). +If COMMAND starts with ./ or ../ resolve relative to `clojure-project-dir', +otherwise resolve via `cider--resolve-command'." + (if (string-match-p "\\`\\.\\{1,2\\}/" command) + (locate-file command (list (clojure-project-dir)) '("" ".bat") 'executable) + (cider--resolve-command command))) + +(defcustom cider-connection-message-fn #'cider-random-words-of-inspiration + "The function to use to generate the message displayed on connect. +When set to nil no additional message will be displayed. A good +alternative to the default is `cider-random-tip'." + :type 'function + :group 'cider + :package-version '(cider . "0.11.0")) + +(defun cider--maybe-inspire-on-connect () + "Display an inspiration connection message." + (when cider-connection-message-fn + (message "Connected! %s" (funcall cider-connection-message-fn)))) + +(add-hook 'cider-connected-hook #'cider--maybe-inspire-on-connect) + +;;;###autoload +(defun cider--setup-clojure-major-mode (mode-map mode-hook) + "Setup Cider key bindings on a Clojure mode's MODE-MAP and hooks in MODE-HOOK." + (define-key mode-map (kbd "C-c M-x") #'cider) + (define-key mode-map (kbd "C-c M-j") #'cider-jack-in-clj) + (define-key mode-map (kbd "C-c M-J") #'cider-jack-in-cljs) + (define-key mode-map (kbd "C-c M-c") #'cider-connect-clj) + (define-key mode-map (kbd "C-c M-C") #'cider-connect-cljs) + (define-key mode-map (kbd "C-c C-x") 'cider-start-map) + (define-key mode-map (kbd "C-c C-s") 'sesman-map) + (require 'sesman) + (sesman-install-menu mode-map) + (add-hook mode-hook (lambda () (setq-local sesman-system 'CIDER)))) + +;;;###autoload +(with-eval-after-load 'clojure-mode + (cider--setup-clojure-major-mode clojure-mode-map 'clojure-mode-hook)) + +;;;###autoload +(with-eval-after-load 'clojure-ts-mode + (cider--setup-clojure-major-mode + (with-suppressed-warnings ((free-vars clojure-ts-mode-map)) + clojure-ts-mode-map) + 'clojure-ts-mode-hook)) + +(provide 'cider) + +;;; cider.el ends here diff --git a/elpa/cider-20241203.1607/clojure.sh b/elpa/cider-20241203.1607/clojure.sh new file mode 100755 index 00000000..ee1d9676 --- /dev/null +++ b/elpa/cider-20241203.1607/clojure.sh @@ -0,0 +1,54 @@ +#!/usr/bin/env bash +set -Eeuo pipefail +# This wrapper script adds enrich-classpath's (https://github.com/clojure-emacs/enrich-classpath) functionalities to the `clojure` binary. +# It works by accepting the `clojure` binary as the first argument, and whatever arguments you'd pass to `clojure` as the rest. +# sample usage: clojure.sh clojure -Asome-alias <<< "(System/getProperty \"java.class.path\")" + +clojure="$1" +# remove it from "$@"/"$*": +shift + +file="deps.edn" + +if [ ! -e $file ]; then + echo "$file not found." + $clojure "$@" +elif [[ "$*" == *Spath* ]]; then + echo "-Spath was passed; skipping enrich-classpath." + $clojure "$@" +elif [[ "$*" == *Scp* ]]; then + echo "-Scp was passed; skipping enrich-classpath." + $clojure "$@" +else + + here="$PWD" + there=$(mktemp -d -t mytempdir.XXXXXX) + + # copy any relevant file to the temporary folder + files_to_copy=( ".tool-versions" # asdf runtime versions configuration + ) + for file_to_copy in "${files_to_copy[@]}"; do + if [ -e "$file_to_copy" ]; then + cp "$file_to_copy" "$there" + fi + done + + # don't let local deps.edn files interfere: + cd "$there" + + # enrich-classpath will emit a command starting by "clojure", or print a stacktrace: + output=$(2>&1 "$clojure" -Sforce -Srepro -J-XX:-OmitStackTraceInFastThrow -J-Dclojure.main.report=stderr -Sdeps '{:deps {mx.cider/tools.deps.enrich-classpath {:mvn/version "1.19.3"}}}' -M -m cider.enrich-classpath.clojure "$clojure" "$here" "true" "$@") + cmd=$(tail -n1 <(echo "$output")) + + cd "$here" + + if grep --silent "^$clojure" <<< "$cmd"; then + # eval is necessary because $cmd contains arguments that have been processed through pr-str. + eval "$cmd" + else + # Print errors: + echo "$output" + $clojure "$@" + fi + +fi diff --git a/elpa/cider-20241203.1607/lein.sh b/elpa/cider-20241203.1607/lein.sh new file mode 100755 index 00000000..028e1675 --- /dev/null +++ b/elpa/cider-20241203.1607/lein.sh @@ -0,0 +1,45 @@ +#!/usr/bin/env bash +# there's no -Ee -o pipefail, intentionally + +# This wrapper script invokes lein with the provided args (which must include the enrich-classpath middleware), +# detecting success, and invoking in return the generated `java` command. +# It falls back to lein with the same args, except that the enrich middleware will be replaced with a no-op middleware. +# By having all this logic as a .sh script (vs. inline in Elisp), we can keep using the same process/async machinery, +# which is concise and results in a non-blocking UX. + +lein="$1" +shift + +output=$(2>&1 "$lein" "$@") +cmd=$(grep "\s-cp\s"<<< "$output") + +function cache_root() { + local cache_dir="${XDG_CACHE_HOME:-$HOME/.cache}" + cache_dir="${cache_dir/#\~/$HOME}" + mkdir -p "$cache_dir" 2>/dev/null + if [[ -w "$cache_dir" ]]; then + echo "${cache_dir%/}" + else + return 1 + fi +} + +if grep --silent "\s-cp\s"<<< "$cmd"; then + eval "$cmd" +else + # Print errors: + if cache_dir=$(cache_root); then + logfile="$cache_dir"/cider-enrich-classpath-error.log + echo "$output" >> "$logfile" + echo "Could not activate enrich-classpath. Error report available at $logfile" + fi + no_enrich=() + for arg in "$@"; do + if [ "$arg" == "cider.enrich-classpath.plugin-v2/middleware" ]; then + no_enrich+=("cider.enrich-classpath.fallback/middleware") + else + no_enrich+=("$arg") + fi + done + $lein "${no_enrich[@]}" +fi diff --git a/elpa/cider-20241203.1607/nrepl-client.el b/elpa/cider-20241203.1607/nrepl-client.el new file mode 100644 index 00000000..ed29fc8a --- /dev/null +++ b/elpa/cider-20241203.1607/nrepl-client.el @@ -0,0 +1,1509 @@ +;;; nrepl-client.el --- Client for Clojure nREPL -*- lexical-binding: t -*- + +;; Copyright © 2012-2024 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell +;; Reid McKenzie +;; +;; 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 . +;; +;; This file is not part of GNU Emacs. +;; +;;; Commentary: +;; +;; Provides an Emacs Lisp client to connect to Clojure nREPL servers. +;; +;; A connection is an abstract idea of the communication between Emacs (client) +;; and nREPL server. On the Emacs side connections are represented by two +;; running processes. The two processes are the server process and client +;; process (the connection to the server). Each of these is represented by its +;; own process buffer, filter and sentinel. +;; +;; The nREPL communication process can be broadly represented as follows: +;; +;; 1) The server process is started as an Emacs subprocess (usually by +;; `cider-jack-in', which in turn fires up an nREPL server). Note that +;; if a connection was established using `cider-connect' there won't be +;; a server process. +;; +;; 2) The server's process filter (`nrepl-server-filter') detects the +;; connection port from the first plain text response from the server and +;; starts a communication process (socket connection) as another Emacs +;; subprocess. This is the nREPL client process (`nrepl-client-filter'). +;; All requests and responses handling happens through this client +;; connection. +;; +;; 3) Requests are sent by `nrepl-send-request' and +;; `nrepl-send-sync-request'. A request is simply a list containing a +;; requested operation name and the parameters required by the +;; operation. Each request has an associated callback that is called once +;; the response for the request has arrived. Besides the above functions +;; there are specialized request senders for each type of common +;; operations. Examples are `nrepl-request:eval', `nrepl-request:clone', +;; `nrepl-sync-request:describe'. +;; +;; 4) Responses from the server are decoded in `nrepl-client-filter' and are +;; physically represented by alists whose structure depends on the type of +;; the response. After having been decoded, the data from the response is +;; passed over to the callback that was registered by the original +;; request. +;; +;; Please see the comments in dedicated sections of this file for more detailed +;; description. + +;;; Code: +(require 'seq) +(require 'subr-x) +(require 'cl-lib) +(require 'nrepl-dict) +(require 'queue) +(require 'sesman) +(require 'tramp) + +(require 'cider-util) + +;;; Custom + +(defgroup nrepl nil + "Interaction with the Clojure nREPL Server." + :prefix "nrepl-" + :group 'applications) + +;; (defcustom nrepl-buffer-name-separator " " +;; "Used in constructing the REPL buffer name. +;; The `nrepl-buffer-name-separator' separates cider-repl from the project name." +;; :type '(string) +;; :group 'nrepl) +(make-obsolete-variable 'nrepl-buffer-name-separator 'cider-session-name-template "0.18") + +;; (defcustom nrepl-buffer-name-show-port nil +;; "Show the connection port in the nrepl REPL buffer name, if set to t." +;; :type 'boolean +;; :group 'nrepl) +(make-obsolete-variable 'nrepl-buffer-name-show-port 'cider-session-name-template "0.18") + +(defcustom nrepl-connected-hook nil + "List of functions to call when connecting to the nREPL server." + :type 'hook) + +(defcustom nrepl-disconnected-hook nil + "List of functions to call when disconnected from the nREPL server." + :type 'hook) + +(defcustom nrepl-force-ssh-for-remote-hosts nil + "If non-nil, do not attempt a direct connection for remote hosts." + :type 'boolean) + +(defcustom nrepl-use-ssh-fallback-for-remote-hosts nil + "If non-nil, Use ssh as a fallback to connect to remote hosts. +It will attempt to connect via ssh to remote hosts when unable to connect +directly." + :type 'boolean) + +(defcustom nrepl-sync-request-timeout 10 + "The number of seconds to wait for a sync response. +Setting this to nil disables the timeout functionality." + :type 'integer) + +(defcustom nrepl-hide-special-buffers nil + "Control the display of some special buffers in buffer switching commands. +When true some special buffers like the server buffer will be hidden." + :type 'boolean) + +;;; Buffer Local Declarations + +;; These variables are used to track the state of nREPL connections +(defvar-local nrepl-connection-buffer nil) +(defvar-local nrepl-server-buffer nil) +(defvar-local nrepl-messages-buffer nil) +(defvar-local nrepl-endpoint nil) +(defvar-local nrepl-project-dir nil) +(defvar-local nrepl-is-server nil) +(defvar-local nrepl-server-command nil) +(defvar-local nrepl-tunnel-buffer nil) + +(defvar-local nrepl-session nil + "Current nREPL session id.") + +(defvar-local nrepl-tooling-session nil + "Current nREPL tooling session id. +To be used for tooling calls (i.e. completion, eldoc, etc)") + +(defvar-local nrepl-request-counter 0 + "Continuation serial number counter.") + +(defvar-local nrepl-pending-requests nil) + +(defvar-local nrepl-completed-requests nil) + +(defvar-local nrepl-last-sync-response nil + "Result of the last sync request.") + +(defvar-local nrepl-last-sync-request-timestamp nil + "The time when the last sync request was initiated.") + +(defvar-local nrepl-ops nil + "Available nREPL server ops (from describe).") + +(defvar-local nrepl-versions nil + "Version information received from the describe op.") + +(defvar-local nrepl-aux nil + "Auxiliary information received from the describe op.") + +;;; nREPL Buffer Names + +(defconst nrepl-message-buffer-name-template "*nrepl-messages %s(%r:%S)*") +(defconst nrepl-error-buffer-name "*nrepl-error*") +(defconst nrepl-repl-buffer-name-template "*cider-repl %s(%r:%S)*") +(defconst nrepl-server-buffer-name-template "*nrepl-server %s*") +(defconst nrepl-tunnel-buffer-name-template "*nrepl-tunnel %s*") + +(declare-function cider-format-connection-params "cider-connection") +(defun nrepl-make-buffer-name (template params &optional dup-ok) + "Generate a buffer name using TEMPLATE and PARAMS. +TEMPLATE and PARAMS are as in `cider-format-connection-params'. If +optional DUP-OK is non-nil, the returned buffer is not \"uniquified\" by a +call to `generate-new-buffer-name'." + (let ((name (cider-format-connection-params template params))) + (if dup-ok + name + (generate-new-buffer-name name)))) + +(defun nrepl--make-hidden-name (buffer-name) + "Apply a prefix to BUFFER-NAME that will hide the buffer." + (concat (if nrepl-hide-special-buffers " " "") buffer-name)) + +(defun nrepl-repl-buffer-name (params &optional dup-ok) + "Return the name of the repl buffer. +PARAMS and DUP-OK are as in `nrepl-make-buffer-name'." + (nrepl-make-buffer-name nrepl-repl-buffer-name-template params dup-ok)) + +(defun nrepl-server-buffer-name (params) + "Return the name of the server buffer. +PARAMS is as in `nrepl-make-buffer-name'." + (nrepl-make-buffer-name (nrepl--make-hidden-name nrepl-server-buffer-name-template) + params)) + +(defun nrepl-tunnel-buffer-name (params) + "Return the name of the tunnel buffer. +PARAMS is as in `nrepl-make-buffer-name'." + (nrepl-make-buffer-name (nrepl--make-hidden-name nrepl-tunnel-buffer-name-template) + params)) + +(defun nrepl-messages-buffer-name (params) + "Return the name for the message buffer given connection PARAMS." + (nrepl-make-buffer-name nrepl-message-buffer-name-template params)) + +;;; Utilities +(defun nrepl-op-supported-p (op connection) + "Return t iff the given operation OP is supported by the nREPL CONNECTION." + (when (buffer-live-p connection) + (with-current-buffer connection + (and nrepl-ops (nrepl-dict-get nrepl-ops op))))) + +(defun nrepl-aux-info (key connection) + "Return KEY's aux info, as returned via the :describe op for CONNECTION." + (with-current-buffer connection + (and nrepl-aux (nrepl-dict-get nrepl-aux key)))) + +(defun nrepl-local-host-p (host) + "Return t if HOST is local." + (string-match-p tramp-local-host-regexp host)) + +(defun nrepl-extract-port (dir) + "Read port from applicable repl-port file in directory DIR." + (condition-case nil + (or (nrepl--port-from-file (expand-file-name "repl-port" dir)) + (nrepl--port-from-file (expand-file-name ".nrepl-port" dir)) + (nrepl--port-from-file (expand-file-name "target/repl-port" dir)) + (nrepl--port-from-file (expand-file-name ".shadow-cljs/nrepl.port" dir))) + ;; This operation can hit permission errors, particularly on macOS: + (error nil))) + +(defun nrepl-extract-ports (dir) + "Read ports from applicable repl-port files in directory DIR." + (condition-case nil + (delq nil + (list (nrepl--port-from-file (expand-file-name "repl-port" dir)) + (nrepl--port-from-file (expand-file-name ".nrepl-port" dir)) + (nrepl--port-from-file (expand-file-name "target/repl-port" dir)) + (nrepl--port-from-file (expand-file-name ".shadow-cljs/nrepl.port" dir)))) + ;; This operation can hit permission errors, particularly on macOS: + (error nil))) + +(make-obsolete 'nrepl-extract-port 'nrepl-extract-ports "1.5.0") + +(defun nrepl--port-string-to-number (s) + "Converts `S' from string to number when suitable." + (when (string-match "^\\([0-9]+\\)" s) + (string-to-number (match-string 0 s)))) + +(defun nrepl--port-from-file (file) + "Attempts to read port from a file named by FILE. + +Discards it if it can be determined that the port is not active." + (when (file-exists-p file) + (when-let* ((port-string (with-temp-buffer + (insert-file-contents file) + (buffer-string))) + ;; extract the number, most of all for not passing garbage to `lsof' (which might even be a security risk): + (port-number (nrepl--port-string-to-number port-string))) + (if (eq system-type 'windows-nt) + port-string + (when (not (equal "" + (shell-command-to-string (format "lsof -i:%s" port-number)))) + port-string))))) + +(defun nrepl--ssh-file-name-matches-host-p (file-name host) + "Return t, if FILE-NAME is a tramp-file-name on HOST via ssh." + (when (tramp-tramp-file-p file-name) + (with-parsed-tramp-file-name file-name v + (and (member v-method '("ssh" "sshx")) + (member host (list v-host (concat v-host "#" v-port))))))) + +;;; Bencode + +(cl-defstruct (nrepl-response-queue + (:include queue) + (:constructor nil) + (:constructor nrepl-response-queue (&optional stub))) + stub) + +(put 'nrepl-response-queue 'function-documentation + "Create queue object used by nREPL to store decoded server responses. +The STUB slot stores a stack of nested, incompletely parsed objects.") + +(defun nrepl--bdecode-list (&optional stack) + "Decode a bencode list or dict starting at point. +STACK is as in `nrepl--bdecode-1'." + ;; skip leading l or d + (forward-char 1) + (let* ((istack (nrepl--bdecode-1 stack)) + (pos0 (point)) + (info (car istack))) + (while (null info) + (setq istack (nrepl--bdecode-1 (cdr istack)) + pos0 (point) + info (car istack))) + (cond ((eq info :e) + (cons nil (cdr istack))) + ((eq info :stub) + (goto-char pos0) + istack) + (t istack)))) + +(defun nrepl--bdecode-1 (&optional stack) + "Decode one elementary bencode object starting at point. +Bencoded object is either list, dict, integer or string. See +http://en.wikipedia.org/wiki/Bencode#Encoding_algorithm for the encoding +rules. + +STACK is a list of so far decoded components of the current message. Car +of STACK is the innermost incompletely decoded object. The algorithm pops +this list when inner object was completely decoded or grows it by one when +new list or dict was encountered. + +The returned value is of the form (INFO . STACK) where INFO is +:stub, nil, :end or :eob and STACK is either an incomplete parsing state as +above (INFO is :stub, nil or :eob) or a list of one component representing +the completely decoded message (INFO is :end). INFO is nil when an +elementary non-root object was successfully decoded. INFO is :end when this +object is a root list or dict." + (cond + ;; list + ((eq (char-after) ?l) + (nrepl--bdecode-list (cons () stack))) + ;; dict + ((eq (char-after) ?d) + (nrepl--bdecode-list (cons '(dict) stack))) + ;; end of a list or a dict + ((eq (char-after) ?e) + (forward-char 1) + (cons (if (cdr stack) :e :end) + (nrepl--push (nrepl--nreverse (car stack)) + (cdr stack)))) + ;; string + ((looking-at "\\([0-9]+\\):") + (let ((pos0 (point)) + (beg (goto-char (match-end 0))) + (end (byte-to-position (+ (position-bytes (point)) + (string-to-number (match-string 1)))))) + (if (null end) + (progn (goto-char pos0) + (cons :stub stack)) + (goto-char end) + ;; normalise any platform-specific newlines + (let* ((original (buffer-substring-no-properties beg end)) + (result (replace-regexp-in-string "\r\n\\|\n\r\\|\r" "\n" original))) + (cons nil (nrepl--push result stack)))))) + ;; integer + ((looking-at "i\\(-?[0-9]+\\)e") + (goto-char (match-end 0)) + (cons nil (nrepl--push (string-to-number (match-string 1)) + stack))) + ;; should happen in tests only as eobp is checked in nrepl-bdecode. + ((eobp) + (cons :eob stack)) + ;; truncation in the middle of an integer or in 123: string prefix + ((looking-at-p "[0-9i]") + (cons :stub stack)) + ;; else, throw a quiet error + (t + (message "Invalid bencode message detected. See the %s buffer for details." + nrepl-error-buffer-name) + (nrepl-log-error + (format "Decoder error at position %d (`%s'):" + (point) (buffer-substring (point) (min (+ (point) 10) (point-max))))) + (nrepl-log-error (buffer-string)) + (ding) + ;; Ensure loop break and clean queues' states in nrepl-bdecode: + (goto-char (point-max)) + (cons :end nil)))) + +(defun nrepl--bdecode-message (&optional stack) + "Decode one full message starting at point. +STACK is as in `nrepl--bdecode-1'. Return a cons (INFO . STACK)." + (let* ((istack (nrepl--bdecode-1 stack)) + (info (car istack)) + (stack (cdr istack))) + (while (or (null info) + (eq info :e)) + (setq istack (nrepl--bdecode-1 stack) + info (car istack) + stack (cdr istack))) + istack)) + +(defun nrepl--ensure-fundamental-mode () + "Enable `fundamental-mode' if it is not enabled already." + (when (not (eq 'fundamental-mode major-mode)) + (fundamental-mode))) + +(defun nrepl-bdecode (string-q &optional response-q) + "Decode STRING-Q and place the results into RESPONSE-Q. +STRING-Q is either a queue of strings or a string. RESPONSE-Q is a queue of +server requests (nREPL dicts). STRING-Q and RESPONSE-Q are modified by side +effects. + +Return a cons (STRING-Q . RESPONSE-Q) where STRING-Q is the original queue +containing the remainder of the input strings which could not be +decoded. RESPONSE-Q is the original queue with successfully decoded messages +enqueued and with slot STUB containing a nested stack of an incompletely +decoded message or nil if the strings were completely decoded." + (with-current-buffer (get-buffer-create " *nrepl-decoding*") + ;; Don't needlessly call `fundamental-mode', to prevent needlessly firing + ;; hooks. This fixes an issue with evil-mode where the cursor loses its + ;; correct color. + (nrepl--ensure-fundamental-mode) + (erase-buffer) + (if (queue-p string-q) + (while (queue-head string-q) + (insert (queue-dequeue string-q))) + (insert string-q) + (setq string-q (queue-create))) + (goto-char 1) + (unless response-q + (setq response-q (nrepl-response-queue))) + (let ((istack (nrepl--bdecode-message + (nrepl-response-queue-stub response-q)))) + (while (and (eq (car istack) :end) + (not (eobp))) + (queue-enqueue response-q (cadr istack)) + (setq istack (nrepl--bdecode-message))) + (unless (eobp) + (queue-enqueue string-q (buffer-substring (point) (point-max)))) + (if (not (eq (car istack) :end)) + (setf (nrepl-response-queue-stub response-q) (cdr istack)) + (queue-enqueue response-q (cadr istack)) + (setf (nrepl-response-queue-stub response-q) nil)) + (erase-buffer) + (cons string-q response-q)))) + +(defun nrepl-bencode (object) + "Encode OBJECT with bencode. +Integers, lists and nrepl-dicts are treated according to bencode +specification. Everything else is encoded as string." + (cond + ((integerp object) (format "i%de" object)) + ((nrepl-dict-p object) (format "d%se" (mapconcat #'nrepl-bencode (cdr object) ""))) + ((listp object) (format "l%se" (mapconcat #'nrepl-bencode object ""))) + (t (format "%s:%s" (string-bytes object) object)))) + +;;; Client: Process Filter + +(defvar nrepl-response-handler-functions nil + "List of functions to call on each nREPL message. +Each of these functions should be a function with one argument, which will +be called by `nrepl-client-filter' on every response received. The current +buffer will be connection (REPL) buffer of the process. These functions +should take a single argument, a dict representing the message. See +`nrepl--dispatch-response' for an example. + +These functions are called before the message's own callbacks, so that they +can affect the behavior of the callbacks. Errors signaled by these +functions are demoted to messages, so that they don't prevent the +callbacks from running.") + +(defun nrepl-client-filter (proc string) + "Decode message(s) from PROC contained in STRING and dispatch them." + (let ((string-q (process-get proc :string-q))) + (queue-enqueue string-q string) + ;; Start decoding only if the last letter is 'e' + (when (eq ?e (aref string (1- (length string)))) + (let ((response-q (process-get proc :response-q))) + (nrepl-bdecode string-q response-q) + (while (queue-head response-q) + (with-current-buffer (process-buffer proc) + (let ((response (queue-dequeue response-q))) + (with-demoted-errors "Error in one of the `nrepl-response-handler-functions': %s" + (run-hook-with-args 'nrepl-response-handler-functions response)) + (nrepl--dispatch-response response)))))))) + +(defun nrepl--dispatch-response (response) + "Dispatch the RESPONSE to associated callback. +First we check the callbacks of pending requests. If no callback was found, +we check the completed requests, since responses could be received even for +older requests with \"done\" status." + (nrepl-dbind-response response (id) + (nrepl-log-message response 'response) + (let ((callback (or (gethash id nrepl-pending-requests) + (gethash id nrepl-completed-requests)))) + (if callback + (funcall callback response) + (error "[nREPL] No response handler with id %s found for %s" id (buffer-name)))))) + +(defun nrepl-client-sentinel (process message) + "Handle sentinel events from PROCESS. +Notify MESSAGE and if the process is closed run `nrepl-disconnected-hook' +and kill the process buffer." + (if (string-match "deleted\\b" message) + (message "[nREPL] Connection closed") + (message "[nREPL] Connection closed unexpectedly (%s)" + (substring message 0 -1))) + (when (equal (process-status process) 'closed) + (when-let* ((client-buffer (process-buffer process))) + (sesman-remove-object 'CIDER nil client-buffer + (not (process-get process :keep-server)) + 'no-error) + (nrepl--clear-client-sessions client-buffer) + (with-current-buffer client-buffer + (goto-char (point-max)) + (insert-before-markers + (propertize + (format "\n*** Closed on %s ***\n" (replace-regexp-in-string " +" + " " + (current-time-string))) + 'face 'cider-repl-stderr-face)) + (run-hooks 'nrepl-disconnected-hook) + (let ((server-buffer nrepl-server-buffer)) + (when (and (buffer-live-p server-buffer) + (not (process-get process :keep-server))) + (setq nrepl-server-buffer nil) + (nrepl--maybe-kill-server-buffer server-buffer))))))) + +;;; Network + +(defun nrepl--unix-connect (socket-file &optional no-error) + "If SOCKET-FILE is given, try to `make-network-process'. +If NO-ERROR is non-nil, show messages instead of throwing an error." + (if (not socket-file) + (unless no-error + (error "[nREPL] Socket file not provided")) + (message "[nREPL] Establishing unix socket connection to %s ..." socket-file) + (condition-case nil + (prog1 (list :proc (make-network-process :name "nrepl-connection" :buffer nil + :family 'local :service socket-file) + :host "local-unix-domain-socket" + :port socket-file + :socket-file socket-file) + (message "[nREPL] Unix socket connection to %s established" socket-file)) + (error (let ((msg (format "[nREPL] Unix socket connection to %s failed" socket-file))) + (if no-error + (message msg) + (error msg)) + nil))))) + +(defun nrepl-connect (host port) + "Connect to the nREPL server identified by HOST and PORT. +For local hosts use a direct connection. For remote hosts, if +`nrepl-force-ssh-for-remote-hosts' is nil, attempt a direct connection +first. If `nrepl-force-ssh-for-remote-hosts' is non-nil or the direct +connection failed (and `nrepl-use-ssh-fallback-for-remote-hosts' is +non-nil), try to start a SSH tunneled connection. Return a plist of the +form (:proc PROC :host \"HOST\" :port PORT) that might contain additional +key-values depending on the connection type." + (let ((localp (if host + (nrepl-local-host-p host) + (not (file-remote-p default-directory))))) + (if localp + (nrepl--direct-connect (or host "localhost") port) + ;; we're dealing with a remote host + (if (and host (not nrepl-force-ssh-for-remote-hosts)) + (or (nrepl--direct-connect host port 'no-error) + ;; direct connection failed + ;; fallback to ssh tunneling if enabled + (and nrepl-use-ssh-fallback-for-remote-hosts + (message "[nREPL] Falling back to SSH tunneled connection ...") + (nrepl--ssh-tunnel-connect host port)) + ;; fallback is either not enabled or it failed as well + (if (and (null nrepl-use-ssh-fallback-for-remote-hosts) + (not localp)) + (error "[nREPL] Direct connection to %s:%s failed; try setting `nrepl-use-ssh-fallback-for-remote-hosts' to t" + host port) + (error "[nREPL] Cannot connect to %s:%s" host port))) + ;; `nrepl-force-ssh-for-remote-hosts' is non-nil + (nrepl--ssh-tunnel-connect host port))))) + +(defun nrepl--direct-connect (host port &optional no-error) + "If HOST and PORT are given, try to `open-network-stream'. +If NO-ERROR is non-nil, show messages instead of throwing an error." + (if (not (and host port)) + (unless no-error + (unless host + (error "[nREPL] Host not provided")) + (unless port + (error "[nREPL] Port not provided"))) + (message "[nREPL] Establishing direct connection to %s:%s ..." host port) + (condition-case nil + (prog1 (list :proc (open-network-stream "nrepl-connection" nil host port) + :host host :port port) + (message "[nREPL] Direct connection to %s:%s established" host port)) + (error (let ((msg (format "[nREPL] Direct connection to %s:%s failed" host port))) + (if no-error + (message msg) + (error msg)) + nil))))) + +(defun nrepl--ssh-tunnel-connect (host port) + "Connect to a remote machine identified by HOST and PORT through SSH tunnel." + (message "[nREPL] Establishing SSH tunneled connection to %s:%s ..." host port) + (let* ((file-name (or (buffer-file-name) nrepl-project-dir)) + (remote-dir (cond + ;; If current buffer is a TRAMP buffer and its host is + ;; the same as HOST, reuse its connection parameters for + ;; SSH tunnel. + ((nrepl--ssh-file-name-matches-host-p file-name host) file-name) + ;; Otherwise, if HOST was provided, use it for connection. + (host (format "/ssh:%s:" host)) + ;; Use default directory as fallback. + (t default-directory))) + (ssh (or (executable-find "ssh") + (error "[nREPL] Cannot locate 'ssh' executable"))) + (cmd (nrepl--ssh-tunnel-command ssh remote-dir port)) + (tunnel-buf (nrepl-tunnel-buffer-name + `((:host ,host) (:port ,port)))) + (tunnel (start-process-shell-command "nrepl-tunnel" tunnel-buf cmd))) + (process-put tunnel :waiting-for-port t) + (set-process-filter tunnel (nrepl--ssh-tunnel-filter port)) + (while (and (process-live-p tunnel) + (process-get tunnel :waiting-for-port)) + (accept-process-output nil 0.005)) + (if (not (process-live-p tunnel)) + (error "[nREPL] SSH port forwarding failed. Check the '%s' buffer" tunnel-buf) + (message "[nREPL] SSH port forwarding established to localhost:%s" port) + (let ((endpoint (nrepl--direct-connect "localhost" port))) + (thread-first + endpoint + (plist-put :tunnel tunnel) + (plist-put :remote-host host)))))) + +(defun nrepl--ssh-tunnel-command (ssh dir port) + "Command string to open SSH tunnel to the host associated with DIR's PORT." + (with-parsed-tramp-file-name dir v + ;; this abuses the -v option for ssh to get output when the port + ;; forwarding is set up, which is used to synchronise on, so that + ;; the port forwarding is up when we try to connect. + (format-spec + "%s -v -N -L %p:localhost:%p %u'%h' %n" + `((?s . ,ssh) + (?p . ,port) + (?h . ,v-host) + (?u . ,(if v-user (format "-l '%s' " v-user) "")) + (?n . ,(if v-port (format "-p '%s' " v-port) "")))))) + +(autoload 'comint-watch-for-password-prompt "comint" "(autoload).") + +(defun nrepl--ssh-tunnel-filter (port) + "Return a process filter that waits for PORT to appear in process output." + (let ((port-string (format "LOCALHOST:%s" port))) + (lambda (proc string) + (when (string-match-p port-string string) + (process-put proc :waiting-for-port nil)) + (when (and (process-live-p proc) + (buffer-live-p (process-buffer proc))) + (with-current-buffer (process-buffer proc) + (let ((moving (= (point) (process-mark proc)))) + (save-excursion + (goto-char (process-mark proc)) + (insert string) + (set-marker (process-mark proc) (point)) + (comint-watch-for-password-prompt string)) + (if moving (goto-char (process-mark proc))))))))) + +;;; Client: Process Handling + +(defun nrepl--kill-process (proc) + "Attempt to kill PROC tree. +On MS-Windows, using the standard API is highly likely to leave the child +processes still running in the background as orphans. As a workaround, an +attempt is made to delegate the task to the `taskkill` program, which comes +with windows since at least Windows XP, and fallback to the Emacs API if it +can't be found. + +It is expected that the `(process-status PROC)` return value after PROC is +killed is `exit` when `taskkill` is used and `signal` otherwise." + (cond + ((and (eq system-type 'windows-nt) + (process-live-p proc) + (executable-find "taskkill")) + ;; try to use `taskkill` if available + (with-temp-buffer + (call-process-shell-command (format "taskkill /PID %s /T /F" (process-id proc)) + nil (buffer-name) ) + ;; useful for debugging. + ;;(message ":PROCESS-KILL-OUPUT %s" (buffer-string)) + )) + + ((memq system-type '(cygwin windows-nt)) + ;; fallback, this is considered to work better than `kill-process` on + ;; MS-Windows. + (interrupt-process proc)) + + (t (kill-process proc)))) + +(defun nrepl-kill-server-buffer (server-buf) + "Kill SERVER-BUF and its process." + (when (buffer-live-p server-buf) + (let ((proc (get-buffer-process server-buf))) + (when (process-live-p proc) + (set-process-query-on-exit-flag proc nil) + (nrepl--kill-process proc)) + (kill-buffer server-buf)))) + +(defun nrepl--maybe-kill-server-buffer (server-buf) + "Kill SERVER-BUF and its process. +Do not kill the server if there is a REPL connected to that server." + (when (buffer-live-p server-buf) + (with-current-buffer server-buf + ;; Don't kill if there is at least one REPL connected to it. + (when (not (seq-find (lambda (b) + (eq (buffer-local-value 'nrepl-server-buffer b) + server-buf)) + (buffer-list))) + (nrepl-kill-server-buffer server-buf))))) + +(defun nrepl-start-client-process (&optional host port server-proc buffer-builder socket-file) + "Create new client process identified by either HOST and PORT or SOCKET-FILE. +If SOCKET-FILE is non-nil, it takes precedence. In remote buffers, HOST +and PORT are taken from the current tramp connection. SERVER-PROC must be +a running nREPL server process within Emacs. BUFFER-BUILDER is a function +of one argument (endpoint returned by `nrepl-connect') which returns a +client buffer. Return the newly created client process." + (let* ((endpoint (if socket-file + (nrepl--unix-connect (expand-file-name socket-file)) + (nrepl-connect host port))) + (client-proc (plist-get endpoint :proc)) + (builder (or buffer-builder (error "`buffer-builder' must be provided"))) + (client-buf (funcall builder endpoint))) + + (set-process-buffer client-proc client-buf) + + (set-process-filter client-proc #'nrepl-client-filter) + (set-process-sentinel client-proc #'nrepl-client-sentinel) + (set-process-coding-system client-proc 'utf-8-unix 'utf-8-unix) + + (process-put client-proc :string-q (queue-create)) + (process-put client-proc :response-q (nrepl-response-queue)) + + (with-current-buffer client-buf + (when-let* ((server-buf (and server-proc (process-buffer server-proc)))) + (setq nrepl-project-dir (buffer-local-value 'nrepl-project-dir server-buf) + nrepl-server-buffer server-buf)) + (setq nrepl-endpoint endpoint + nrepl-tunnel-buffer (when-let* ((tunnel (plist-get endpoint :tunnel))) + (process-buffer tunnel)) + nrepl-pending-requests (make-hash-table :test 'equal) + nrepl-completed-requests (make-hash-table :test 'equal))) + + (with-current-buffer client-buf + (nrepl--init-client-sessions client-proc) + (nrepl--init-capabilities client-buf) + (run-hooks 'nrepl-connected-hook)) + + client-proc)) + +(defun nrepl--init-client-sessions (client) + "Initialize CLIENT connection nREPL sessions. +We create two client nREPL sessions per connection - a main session and a +tooling session. The main session is general purpose and is used for pretty +much every request that needs a session. The tooling session is used only +for functionality that's implemented in terms of the \"eval\" op, so that +eval requests for functionality like pretty-printing won't clobber the +values of *1, *2, etc." + (let* ((client-conn (process-buffer client)) + (response-main (nrepl-sync-request:clone client-conn)) + (response-tooling (nrepl-sync-request:clone client-conn t))) ; t for tooling + (nrepl-dbind-response response-main (new-session err) + (if new-session + (with-current-buffer client-conn + (setq nrepl-session new-session)) + (error "Could not create new session (%s)" err))) + (nrepl-dbind-response response-tooling (new-session err) + (if new-session + (with-current-buffer client-conn + (setq nrepl-tooling-session new-session)) + (error "Could not create new tooling session (%s)" err))))) + +(defun nrepl--init-capabilities (conn-buffer) + "Store locally in CONN-BUFFER the capabilities of nREPL server." + (let ((description (nrepl-sync-request:describe conn-buffer))) + (nrepl-dbind-response description (ops versions aux) + (with-current-buffer conn-buffer + (setq nrepl-ops ops) + (setq nrepl-versions versions) + (setq nrepl-aux aux))))) + +(defun nrepl--clear-client-sessions (conn-buffer) + "Clear information about nREPL sessions in CONN-BUFFER. +CONN-BUFFER refers to a (presumably) dead connection, +which we can eventually reuse." + (with-current-buffer conn-buffer + (setq nrepl-session nil) + (setq nrepl-tooling-session nil))) + +;;; Client: Response Handling +;; After being decoded, responses (aka, messages from the server) are dispatched +;; to handlers. Handlers are constructed with `nrepl-make-response-handler'. + +(defvar nrepl-err-handler nil + "Evaluation error handler.") + +(defun nrepl--mark-id-completed (id) + "Move ID from `nrepl-pending-requests' to `nrepl-completed-requests'. +It is safe to call this function multiple times on the same ID." + ;; FIXME: This should go away eventually when we get rid of + ;; pending-request hash table + (when-let* ((handler (gethash id nrepl-pending-requests))) + (puthash id handler nrepl-completed-requests) + (remhash id nrepl-pending-requests))) + +(declare-function cider-repl--emit-interactive-output "cider-repl") +(defun nrepl-notify (msg type) + "Handle \"notification\" server request. +MSG is a string to be displayed. TYPE is the type of the message. All +notifications are currently displayed with `message' function and emitted +to the REPL." + (let* ((face (pcase type + ((or "message" `nil) 'font-lock-builtin-face) + ("warning" 'warning) + ("error" 'error))) + (msg (if face + (propertize msg 'face face) + (format "%s: %s" (upcase type) msg)))) + (cider-repl--emit-interactive-output msg (or face 'font-lock-builtin-face)) + (message msg))) + +(defvar cider-buffer-ns) +(defvar cider-print-quota) +(defvar cider-special-mode-truncate-lines) +(declare-function cider-need-input "cider-client") +(declare-function cider-set-buffer-ns "cider-mode") + +(defun nrepl-make-response-handler (buffer value-handler stdout-handler + stderr-handler done-handler + &optional eval-error-handler + content-type-handler + truncated-handler) + "Make a response handler for connection BUFFER. +A handler is a function that takes one argument - response received from +the server process. The response is an alist that contains at least 'id' +and 'session' keys. Other standard response keys are 'value', 'out', 'err', +and 'status'. + +The presence of a particular key determines the type of the response. For +example, if 'value' key is present, the response is of type 'value', if +'out' key is present the response is 'stdout' etc. + +Depending on the type, the handler dispatches the appropriate value to one +of the supplied handlers: VALUE-HANDLER, STDOUT-HANDLER, STDERR-HANDLER, +DONE-HANDLER, EVAL-ERROR-HANDLER, CONTENT-TYPE-HANDLER, and +TRUNCATED-HANDLER. + +Handlers are functions of the buffer and the value they handle, except for +the optional CONTENT-TYPE-HANDLER which should be a function of the buffer, +content, the content-type to be handled as a list `(type attrs)'. + +If the optional EVAL-ERROR-HANDLER is nil, the default `nrepl-err-handler' +is used. If any of the other supplied handlers are nil nothing happens for +the corresponding type of response." + (lambda (response) + (nrepl-dbind-response response (content-type content-transfer-encoding body + value ns out err status id) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when (and ns (not (cider-clojure-major-mode-p))) + (cider-set-buffer-ns ns)))) + (cond ((and content-type content-type-handler) + (funcall content-type-handler buffer + (if (string= content-transfer-encoding "base64") + (base64-decode-string body) + body) + content-type)) + (value + (when value-handler + (funcall value-handler buffer value))) + (out + (when stdout-handler + (funcall stdout-handler buffer out))) + (err + (when stderr-handler + (funcall stderr-handler buffer err))) + (status + (when (and truncated-handler (member "nrepl.middleware.print/truncated" status)) + (let ((warning (format "\n... output truncated to %sB ..." + (file-size-human-readable cider-print-quota)))) + (funcall truncated-handler buffer warning))) + (when (member "notification" status) + (nrepl-dbind-response response (msg type) + (nrepl-notify msg type))) + (when (member "interrupted" status) + (message "Evaluation interrupted.")) + (when (member "eval-error" status) + (funcall (or eval-error-handler nrepl-err-handler))) + (when (member "namespace-not-found" status) + (message "Namespace `%s' not found." ns)) + (when (member "need-input" status) + (cider-need-input buffer)) + (when (member "done" status) + (nrepl--mark-id-completed id) + (when done-handler + (funcall done-handler buffer)))))))) + +;;; Client: Request Core API + +;; Requests are messages from an nREPL client (like CIDER) to an nREPL server. +;; Requests can be asynchronous (sent with `nrepl-send-request') or +;; synchronous (send with `nrepl-send-sync-request'). The request is a pair list +;; of operation name and operation parameters. The core operations are described +;; at https://github.com/nrepl/nrepl/blob/master/doc/ops.md. CIDER adds +;; many more operations through nREPL middleware. See +;; https://github.com/clojure-emacs/cider-nrepl#supplied-nrepl-middleware for +;; the up-to-date list. + +(defun nrepl-next-request-id (connection) + "Return the next request id for CONNECTION." + (with-current-buffer connection + (number-to-string (cl-incf nrepl-request-counter)))) + +(defun nrepl-send-request (request callback connection &optional tooling) + "Send REQUEST and register response handler CALLBACK using CONNECTION. +REQUEST is a pair list of the form (\"op\" \"operation\" \"par1-name\" +\"par1\" ... ). See the code of `nrepl-request:clone', +`nrepl-request:stdin', etc. This expects that the REQUEST does not have a +session already in it. This code will add it as appropriate to prevent +connection/session drift. +Return the ID of the sent message. +Optional argument TOOLING Set to t if desiring the tooling session rather than +the standard session." + (with-current-buffer connection + (when-let* ((session (if tooling nrepl-tooling-session nrepl-session))) + (setq request (append request `("session" ,session)))) + (let* ((id (nrepl-next-request-id connection)) + (request (cons 'dict (lax-plist-put request "id" id))) + (message (nrepl-bencode request))) + (nrepl-log-message request 'request) + (puthash id callback nrepl-pending-requests) + (process-send-string nil message) + id))) + +(defvar nrepl-ongoing-sync-request nil + "Dynamically bound to t while a sync request is ongoing.") + +(declare-function cider-repl-emit-interactive-stderr "cider-repl") +(declare-function cider--render-stacktrace-causes "cider-eval") + +(defun nrepl-send-sync-request (request connection &optional abort-on-input tooling) + "Send REQUEST to the nREPL server synchronously using CONNECTION. +Hold till final \"done\" message has arrived and join all response messages +of the same \"op\" that came along. +If ABORT-ON-INPUT is non-nil, the function will return nil at the first +sign of user input, so as not to hang the interface. +If TOOLING, use the tooling session rather than the standard session." + (let* ((time0 (current-time)) + (response (cons 'dict nil)) + (nrepl-ongoing-sync-request t) + status) + (nrepl-send-request request + (lambda (resp) (nrepl--merge response resp)) + connection + tooling) + (while (and (not (member "done" status)) + (not (and abort-on-input + (input-pending-p)))) + (setq status (nrepl-dict-get response "status")) + ;; If we get a need-input message then the repl probably isn't going + ;; anywhere, and we'll just timeout. So we forward it to the user. + (if (member "need-input" status) + (progn (cider-need-input (current-buffer)) + ;; If the used took a few seconds to respond, we might + ;; unnecessarily timeout, so let's reset the timer. + (setq time0 (current-time))) + ;; break out in case we don't receive a response for a while + (when (and nrepl-sync-request-timeout + (time-less-p + nrepl-sync-request-timeout + (time-subtract nil time0))) + (error "Sync nREPL request timed out %s after %s secs" request nrepl-sync-request-timeout))) + ;; Clean up the response, otherwise we might repeatedly ask for input. + (nrepl-dict-put response "status" (remove "need-input" status)) + (accept-process-output nil 0.01)) + ;; If we couldn't finish, return nil. + (when (member "done" status) + (nrepl-dbind-response response (ex err eval-error pp-stacktrace id) + (when (and ex err) + (cond (eval-error (funcall nrepl-err-handler)) + (pp-stacktrace (cider--render-stacktrace-causes + pp-stacktrace (remove "done" status))))) ;; send the error type + (when id + (with-current-buffer connection + (nrepl--mark-id-completed id))) + response)))) + +(defun nrepl-request:stdin (input callback connection) + "Send a :stdin request with INPUT using CONNECTION. +Register CALLBACK as the response handler." + (nrepl-send-request `("op" "stdin" + "stdin" ,input) + callback + connection)) + +(defun nrepl-request:interrupt (pending-request-id callback connection) + "Send an :interrupt request for PENDING-REQUEST-ID. +The request is dispatched using CONNECTION. +Register CALLBACK as the response handler." + (nrepl-send-request `("op" "interrupt" + "interrupt-id" ,pending-request-id) + callback + connection)) + +(define-minor-mode cider-enlighten-mode nil + :lighter (cider-mode " light") + :global t) + +(defun nrepl--eval-request (input &optional ns line column) + "Prepare :eval request message for INPUT. +NS provides context for the request. +If LINE and COLUMN are non-nil and current buffer is a file buffer, \"line\", +\"column\" and \"file\" are added to the message." + (nconc (and ns `("ns" ,ns)) + `("op" "eval" + "code" ,(substring-no-properties input)) + (when cider-enlighten-mode + '("enlighten" "true")) + (let ((file (or (buffer-file-name) (buffer-name)))) + (when (and line column file) + `("file" ,file + "line" ,line + "column" ,column))))) + +(defun nrepl-request:eval (input callback connection &optional ns line column additional-params tooling) + "Send the request INPUT and register the CALLBACK as the response handler. +The request is dispatched via CONNECTION. If NS is non-nil, +include it in the request. LINE and COLUMN, if non-nil, define the position +of INPUT in its buffer. A CONNECTION uniquely determines two connections +available: the standard interaction one and the tooling session. If the +tooling is desired, set TOOLING to true. +ADDITIONAL-PARAMS is a plist to be appended to the request message." + (nrepl-send-request (append (nrepl--eval-request input ns line column) additional-params) + callback + connection + tooling)) + +(defun nrepl-sync-request:clone (connection &optional tooling) + "Sent a :clone request to create a new client session. +The request is dispatched via CONNECTION. +Optional argument TOOLING Tooling is set to t if wanting the tooling session +from CONNECTION." + (nrepl-send-sync-request '("op" "clone") + connection + nil tooling)) + +(defun nrepl-sync-request:close (connection) + "Sent a :close request to close CONNECTION's SESSION." + (nrepl-send-sync-request '("op" "close") connection) + (nrepl-send-sync-request '("op" "close") connection nil t)) ;; close tooling session + +(defun nrepl-sync-request:describe (connection) + "Perform :describe request for CONNECTION and SESSION." + (nrepl-send-sync-request '("op" "describe") + connection)) + +(defun nrepl-sync-request:ls-sessions (connection) + "Perform :ls-sessions request for CONNECTION." + (nrepl-send-sync-request '("op" "ls-sessions") connection)) + +(defun nrepl-sync-request:ls-middleware (connection) + "Perform :ls-middleware request for CONNECTION." + (nrepl-send-sync-request '("op" "ls-middleware") connection)) + +(defun nrepl-sync-request:eval (input connection &optional ns tooling) + "Send the INPUT to the nREPL server synchronously. +The request is dispatched via CONNECTION. +If NS is non-nil, include it in the request +If TOOLING is non-nil the evaluation is done using the tooling nREPL +session." + (nrepl-send-sync-request + (nrepl--eval-request input ns) + connection + nil + tooling)) + +(defun nrepl-sessions (connection) + "Get a list of active sessions on the nREPL server using CONNECTION." + (nrepl-dict-get (nrepl-sync-request:ls-sessions connection) "sessions")) + +(defun nrepl-middleware (connection) + "Get a list of middleware on the nREPL server using CONNECTION." + (nrepl-dict-get (nrepl-sync-request:ls-middleware connection) "middleware")) + +;;; Server + +;; The server side process is started by `nrepl-start-server-process' and has a +;; very simple filter that pipes its output directly into its process buffer +;; (*nrepl-server*). The main purpose of this process is to start the actual +;; nrepl communication client (`nrepl-client-filter') when the message "nREPL +;; server started on port ..." is detected. + +;; internal variables used for state transfer between nrepl-start-server-process +;; and nrepl-server-filter. +(defvar-local nrepl-on-port-callback nil) + +(defun nrepl-server-p (buffer-or-process) + "Return t if BUFFER-OR-PROCESS is an nREPL server." + (let ((buffer (if (processp buffer-or-process) + (process-buffer buffer-or-process) + buffer-or-process))) + (buffer-local-value 'nrepl-is-server buffer))) + +(defun nrepl-start-server-process (directory cmd on-port-callback) + "Start nREPL server process in DIRECTORY using shell command CMD. +Return a newly created process. Set `nrepl-server-filter' as the process +filter, which starts REPL process with its own buffer once the server has +started. ON-PORT-CALLBACK is a function of one argument (server buffer) +which is called by the process filter once the port of the connection has +been determined." + (let* ((default-directory (or directory default-directory)) + (serv-buf (get-buffer-create + (nrepl-server-buffer-name + `(:project-dir ,default-directory))))) + (with-current-buffer serv-buf + (setq nrepl-is-server t + nrepl-project-dir default-directory + nrepl-server-command cmd + nrepl-on-port-callback on-port-callback)) + (let ((serv-proc (start-file-process-shell-command + "nrepl-server" serv-buf cmd))) + (set-process-filter serv-proc #'nrepl-server-filter) + (set-process-sentinel serv-proc #'nrepl-server-sentinel) + (set-process-coding-system serv-proc 'utf-8-unix 'utf-8-unix) + (message "[nREPL] Starting server via %s" + (propertize cmd 'face 'font-lock-keyword-face)) + serv-proc))) + +(defconst nrepl-listening-unix-address-regexp + (rx + (and "nREPL server listening on" (+ " ") + "nrepl+unix:" (group-n 1 (+ not-newline))))) + +(defconst nrepl-listening-inet-address-regexp + (rx (or + ;; standard + (and "nREPL server started on port " (group-n 1 (+ (any "0-9")))) + ;; babashka + (and "Started nREPL server at " + (group-n 2 (+? any)) ":" (group-n 1 (+ (any "0-9")))))) + "A regexp to search an nREPL's stdout for the address it is listening on. + +If it matches, the address components can be extracted using the following +match groups: +1 for the port, and +2 for the host (babashka only).") + +(defun cider--process-plist-put (proc prop val) + "Change value in PROC's plist of PROP to VAL. +Value is changed using `plist-put`, of which see." + (thread-first + proc + (process-plist) + (plist-put prop val) + (thread-last (set-process-plist proc)))) + +(defun nrepl-server-filter (process output) + "Process nREPL server output from PROCESS contained in OUTPUT. + +The PROCESS plist is updated as (non-exhaustive list): + +:cider--nrepl-server-ready set to t when the server is successfully brought +up." + ;; In Windows this can be false: + (let ((server-buffer (process-buffer process))) + (when (buffer-live-p server-buffer) + (with-current-buffer server-buffer + ;; auto-scroll on new output + (let ((moving (= (point) (process-mark process)))) + (save-excursion + (goto-char (process-mark process)) + (insert output) + (ansi-color-apply-on-region (process-mark process) (point)) + (set-marker (process-mark process) (point))) + (when moving + (goto-char (process-mark process)) + (when-let* ((win (get-buffer-window))) + (set-window-point win (point))))) + ;; detect the port the server is listening on from its output + (when (null nrepl-endpoint) + (let ((end (cond + ((string-match nrepl-listening-unix-address-regexp output) + (let ((path (match-string 1 output))) + (message "[nREPL] server started on nrepl+unix:%s" path) + (list :host "local-unix-domain-socket" + :port path + :socket-file path))) + ((string-match nrepl-listening-inet-address-regexp output) + (let ((host (or (match-string 2 output) + (file-remote-p default-directory 'host) + "localhost")) + (port (string-to-number (match-string 1 output)))) + (message "[nREPL] server started on %s" port) + (list :host host :port port)))))) + (when end + (setq nrepl-endpoint end) + (cider--process-plist-put process :cider--nrepl-server-ready t) + (when nrepl-on-port-callback + (funcall nrepl-on-port-callback (process-buffer process)))))))))) + +(defmacro emacs-bug-46284/when-27.1-windows-nt (&rest body) + "Only evaluate BODY when Emacs bug #46284 has been detected." + (when (and (eq system-type 'windows-nt) + (string= emacs-version "27.1")) + (cons 'progn body))) + + +(declare-function cider--close-connection "cider-connection") +(defun nrepl-server-sentinel (process event) + "Handle nREPL server PROCESS EVENT. +If the nREPL PROCESS failed to initiate and encountered a fatal EVENT +signal, raise an 'error'. Additionally, if the EVENT signal is SIGHUP, +close any existing client connections." + ;; only interested on fatal signals. + (when (not (process-live-p process)) + (emacs-bug-46284/when-27.1-windows-nt + ;; There is a bug in emacs 27.1 (since fixed) that sets all EVENT + ;; descriptions for signals to "unknown signal". We correct this by + ;; resetting it back to its canonical value. + (when (eq (process-status process) 'signal) + (cl-case (process-exit-status process) + ;; SIGHUP==1 emacs nt/inc/ms-w32.h + (1 (setq event "Hangup")) + ;; SIGINT==2 x86_64-w64-mingw32/include/signal.h + (2 (setq event "Interrupt")) + ;; SIGKILL==9 emacs nt/inc/ms-w32.h + (9 (setq event "Killed"))))) + (let* ((server-buffer (process-buffer process)) + (clients (seq-filter (lambda (b) + (eq (buffer-local-value 'nrepl-server-buffer b) + server-buffer)) + (buffer-list)))) + + ;; see https://github.com/clojure-emacs/cider/pull/3333 + (when (string-match-p "^hangup" event) + (mapc #'cider--close-connection clients)) + + (if (process-get process :cider--nrepl-server-ready) + (progn + (when server-buffer (kill-buffer server-buffer)) + (message "nREPL server exited.")) + (let ((problem (when (and server-buffer (buffer-live-p server-buffer)) + (with-current-buffer server-buffer + (buffer-substring (point-min) (point-max)))))) + (error "Could not start nREPL server: %s (%S)" problem (string-trim event))))))) + +;;; Messages + +(defcustom nrepl-log-messages nil + "If non-nil, log protocol messages to an nREPL messages buffer. +This is extremely useful for debug purposes, as it allows you to inspect +the communication between Emacs and an nREPL server. Enabling the logging +might have a negative impact on performance, so it's not recommended to +keep it enabled unless you need to debug something." + :type 'boolean + :safe #'booleanp) + +(defconst nrepl-message-buffer-max-size 1000000 + "Maximum size for the nREPL message buffer. +Defaults to 1000000 characters, which should be an insignificant +memory burden, while providing reasonable history.") + +(defconst nrepl-message-buffer-reduce-denominator 4 + "Divisor by which to reduce message buffer size. +When the maximum size for the nREPL message buffer is exceeded, the size of +the buffer is reduced by one over this value. Defaults to 4, so that 1/4 +of the buffer is removed, which should ensure the buffer's maximum is +reasonably utilized, while limiting the number of buffer shrinking +operations.") + +(defvar nrepl-messages-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "n") #'next-line) + (define-key map (kbd "p") #'previous-line) + (define-key map (kbd "TAB") #'forward-button) + (define-key map (kbd "RET") #'nrepl-log-expand-button) + (define-key map (kbd "e") #'nrepl-log-expand-button) + (define-key map (kbd "E") #'nrepl-log-expand-all-buttons) + (define-key map (kbd "") #'backward-button) + map)) + +(define-derived-mode nrepl-messages-mode special-mode "nREPL Messages" + "Major mode for displaying nREPL messages. + +\\{nrepl-messages-mode-map}" + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t)) + (setq-local sesman-system 'CIDER) + (setq-local electric-indent-chars nil) + (setq-local comment-start ";") + (setq-local comment-end "") + (setq-local paragraph-start "(-->\\|(<--") + (setq-local paragraph-separate "(<--")) + +(defun nrepl-decorate-msg (msg type) + "Decorate nREPL MSG according to its TYPE." + (pcase type + (`request (cons '--> (cdr msg))) + (`response (cons '<-- (cdr msg))))) + +(defun nrepl-log-message (msg type) + "Log the nREPL MSG. +TYPE is either request or response. The message is logged to a buffer +described by `nrepl-message-buffer-name-template'." + (when nrepl-log-messages + ;; append a time-stamp to the message before logging it + ;; the time-stamps are quite useful for debugging + (setq msg (cons (car msg) + (lax-plist-put (cdr msg) "time-stamp" + (format-time-string "%Y-%m-%0d %H:%M:%S.%N")))) + (with-current-buffer (nrepl-messages-buffer (current-buffer)) + (setq buffer-read-only nil) + (when (> (buffer-size) nrepl-message-buffer-max-size) + (goto-char (/ (buffer-size) nrepl-message-buffer-reduce-denominator)) + (re-search-forward "^(" nil t) + (delete-region (point-min) (- (point) 1))) + (goto-char (point-max)) + (nrepl-log-pp-object (nrepl-decorate-msg msg type) + (nrepl-log--message-color (lax-plist-get (cdr msg) "id")) + t) + (when-let* ((win (get-buffer-window))) + (set-window-point win (point-max))) + (setq buffer-read-only t)))) + +(defun nrepl-toggle-message-logging () + "Toggle the value of `nrepl-log-messages' between nil and t. + +This in effect enables or disables the logging of nREPL messages." + (interactive) + (setq nrepl-log-messages (not nrepl-log-messages)) + (if nrepl-log-messages + (message "nREPL message logging enabled") + (message "nREPL message logging disabled"))) + +(defcustom nrepl-message-colors + '("red" "brown" "coral" "orange" "green" "deep sky blue" "blue" "dark violet") + "Colors used in the messages buffer." + :type '(repeat color)) + +(defun nrepl-log-expand-button (&optional button) + "Expand the objects hidden in BUTTON's :nrepl-object property. +BUTTON defaults the button at point." + (interactive) + (if-let* ((button (or button (button-at (point))))) + (let* ((start (overlay-start button)) + (end (overlay-end button)) + (obj (overlay-get button :nrepl-object)) + (inhibit-read-only t)) + (save-excursion + (goto-char start) + (delete-overlay button) + (delete-region start end) + (nrepl-log-pp-object obj) + (delete-char -1))) + (error "No button at point"))) + +(defun nrepl-log-expand-all-buttons () + "Expand all buttons in nREPL log buffer." + (interactive) + (if (not (eq major-mode 'nrepl-messages-mode)) + (user-error "Not in a `nrepl-messages-mode'") + (save-excursion + (let* ((pos (point-min)) + (button (next-button pos))) + (while button + (setq pos (overlay-start button)) + (nrepl-log-expand-button button) + (setq button (next-button pos))))))) + +(defun nrepl-log--expand-button-mouse (event) + "Expand the text hidden under overlay button. +EVENT gives the button position on window." + (interactive "e") + (pcase (elt event 1) + (`(,window ,_ ,_ ,_ ,_ ,point . ,_) + (with-selected-window window + (nrepl-log-expand-button (button-at point)))))) + +(defun nrepl-log-insert-button (label object) + "Insert button with LABEL and :nrepl-object property as OBJECT." + (insert-button label + :nrepl-object object + 'action #'nrepl-log-expand-button + 'face 'link + 'help-echo "RET: Expand object." + ;; Workaround for bug#1568 (don't use local-map here; it + ;; overwrites major mode map.) + 'keymap `(keymap (mouse-1 . nrepl-log--expand-button-mouse))) + (insert "\n")) + +(defun nrepl-log--message-color (id) + "Return the color to use when pretty-printing the nREPL message with ID. +If ID is nil, return nil." + (when id + (thread-first + (string-to-number id) + (mod (length nrepl-message-colors)) + (nth nrepl-message-colors)))) + +(defun nrepl-log--pp-listlike (object &optional foreground button) + "Pretty print nREPL list like OBJECT. +FOREGROUND and BUTTON are as in `nrepl-log-pp-object'." + (cl-flet ((color (str) + (propertize str 'face + (append '(:weight ultra-bold) + (when foreground `(:foreground ,foreground)))))) + (let ((head (format "(%s" (car object)))) + (insert (color head)) + (if (null (cdr object)) + (insert ")\n") + (let* ((indent (+ 2 (- (current-column) (length head)))) + (sorted-pairs (sort (seq-partition (cl-copy-list (cdr object)) 2) + (lambda (a b) + (string< (car a) (car b))))) + (name-lengths (seq-map (lambda (pair) (length (car pair))) sorted-pairs)) + (longest-name (seq-max name-lengths)) + ;; Special entries are displayed first + (specialq (lambda (pair) (member (car pair) '("id" "op" "session" "time-stamp")))) + (special-pairs (seq-filter specialq sorted-pairs)) + (not-special-pairs (seq-remove specialq sorted-pairs)) + (all-pairs (seq-concatenate 'list special-pairs not-special-pairs)) + (sorted-object (apply #'seq-concatenate 'list all-pairs))) + (insert "\n") + (cl-loop for l on sorted-object by #'cddr + do (let ((indent-str (make-string indent ?\s)) + (name-str (propertize (car l) 'face + ;; Only highlight top-level keys. + (unless (eq (car object) 'dict) + 'font-lock-keyword-face))) + (spaces-str (make-string (- longest-name (length (car l))) ?\s))) + (insert (format "%s%s%s " indent-str name-str spaces-str)) + (nrepl-log-pp-object (cadr l) nil button))) + (when (eq (car object) 'dict) + (delete-char -1)) + (insert (color ")\n"))))))) + +(defun nrepl-log-pp-object (object &optional foreground button) + "Pretty print nREPL OBJECT, delimited using FOREGROUND. +If BUTTON is non-nil, try making a button from OBJECT instead of inserting +it into the buffer." + (let ((min-dict-fold-size 1) + (min-list-fold-size 10) + (min-string-fold-size 60)) + (if-let* ((head (car-safe object))) + ;; list-like objects + (cond + ;; top level dicts (always expanded) + ((memq head '(<-- -->)) + (nrepl-log--pp-listlike object foreground button)) + ;; inner dicts + ((eq head 'dict) + (if (and button (> (length object) min-dict-fold-size)) + (nrepl-log-insert-button "(dict ...)" object) + (nrepl-log--pp-listlike object foreground button))) + ;; lists + (t + (if (and button (> (length object) min-list-fold-size)) + (nrepl-log-insert-button (format "(%s ...)" (prin1-to-string head)) object) + (pp object (current-buffer))))) + ;; non-list objects + (if (stringp object) + (if (and button (> (length object) min-string-fold-size)) + (nrepl-log-insert-button (format "\"%s...\"" (substring object 0 min-string-fold-size)) object) + (insert (prin1-to-string object) "\n")) + (pp object (current-buffer)) + (insert "\n"))))) + +(declare-function cider--gather-connect-params "cider-connection") +(defun nrepl-messages-buffer (conn) + "Return or create the buffer for CONN. +The default buffer name is *nrepl-messages connection*." + (with-current-buffer conn + (or (and (buffer-live-p nrepl-messages-buffer) + nrepl-messages-buffer) + (setq nrepl-messages-buffer + (let ((buffer (get-buffer-create + (nrepl-messages-buffer-name + (cider--gather-connect-params))))) + (with-current-buffer buffer + (buffer-disable-undo) + (nrepl-messages-mode) + buffer)))))) + +(defun nrepl-error-buffer () + "Return or create the buffer. +The default buffer name is *nrepl-error*." + (or (get-buffer nrepl-error-buffer-name) + (let ((buffer (get-buffer-create nrepl-error-buffer-name))) + (with-current-buffer buffer + (buffer-disable-undo) + (nrepl--ensure-fundamental-mode) + buffer)))) + +(defun nrepl-log-error (msg) + "Log the given MSG to the buffer given by `nrepl-error-buffer'." + (with-current-buffer (nrepl-error-buffer) + (setq buffer-read-only nil) + (goto-char (point-max)) + (insert msg) + (when-let* ((win (get-buffer-window))) + (set-window-point win (point-max))) + (setq buffer-read-only t))) + +(make-obsolete 'nrepl-default-client-buffer-builder nil "0.18") + +(provide 'nrepl-client) + +;;; nrepl-client.el ends here diff --git a/elpa/cider-20241203.1607/nrepl-dict.el b/elpa/cider-20241203.1607/nrepl-dict.el new file mode 100644 index 00000000..d8daeb5c --- /dev/null +++ b/elpa/cider-20241203.1607/nrepl-dict.el @@ -0,0 +1,214 @@ +;;; nrepl-dict.el --- Dictionary functions for Clojure nREPL -*- lexical-binding: t -*- + +;; Copyright © 2012-2024 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell +;; +;; 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 . +;; +;; This file is not part of GNU Emacs. +;; +;;; Commentary: +;; +;; Provides functions to interact with and create `nrepl-dict's. These are +;; simply plists with an extra element at the head, and using `equal' for +;; comparison of string keys. + +;;; Code: +(require 'cl-lib) + + +(defun nrepl-dict (&rest key-vals) + "Create nREPL dict from KEY-VALS." + (cons 'dict key-vals)) + +(defun nrepl-dict-from-hash (hash) + "Create nREPL dict from HASH." + (let ((dict (nrepl-dict))) + (maphash (lambda (k v) (nrepl-dict-put dict k v)) hash) + dict)) + +(defsubst nrepl-dict-p (object) + "Return t if OBJECT is an nREPL dict." + (eq (car-safe object) 'dict)) + +(defsubst nrepl-dict-empty-p (dict) + "Return t if nREPL dict DICT is empty." + (null (cdr dict))) + +(defun nrepl-dict-contains (dict key) + "Return nil if nREPL dict DICT doesn't contain KEY. +If DICT does contain KEY, then a non-nil value is returned. Due to the +current implementation, this return value is the tail of DICT's key-list +whose car is KEY. Comparison is done with `equal'." + (member key (nrepl-dict-keys dict))) + +(defun nrepl-dict-get (dict key &optional default) + "Get from DICT value associated with KEY. +If DICT is nil, return nil. +If DICT is not an nREPL dict object, an error is thrown. + +If KEY is not in DICT, return DEFAULT (if provided). +Note that the use of DEFAULT is deprecated and will be +removed in a future release." + (declare (advertised-calling-convention (dict key) "1.16")) + (when dict + (if (nrepl-dict-p dict) + ;; Note: The structure of the following expression avoids the + ;; expensive containment check in nearly all cases, see #3717 + (or (lax-plist-get (cdr dict) key) + ;; TODO: remove DEFAULT argument and the following clause + (when default + (and (not (nrepl-dict-contains dict key)) + default))) + (error "Not an nREPL dict object: %s" dict)))) + +(defun nrepl-dict-put (dict key value) + "Associate in DICT, KEY to VALUE. +Return new dict. Dict is modified by side effects." + (if (null dict) + `(dict ,key ,value) + (if (not (nrepl-dict-p dict)) + (error "Not an nREPL dict object: %s" dict) + (setcdr dict (lax-plist-put (cdr dict) key value)) + dict))) + +(defun nrepl-dict-keys (dict) + "Return all the keys in the nREPL DICT." + (if (nrepl-dict-p dict) + (cl-loop for l on (cdr dict) by #'cddr + collect (car l)) + (error "Not an nREPL dict object: %s" dict))) + +(defun nrepl-dict-vals (dict) + "Return all the values in the nREPL DICT." + (if (nrepl-dict-p dict) + (cl-loop for l on (cdr dict) by #'cddr + collect (cadr l)) + (error "Not an nREPL dict object: %s" dict))) + +(defun nrepl-dict-map (fn dict) + "Map FN on nREPL DICT. +FN must accept two arguments key and value." + (if (nrepl-dict-p dict) + (cl-loop for l on (cdr dict) by #'cddr + collect (funcall fn (car l) (cadr l))) + (error "Not an nREPL dict object: %s" dict))) + +(defun nrepl-dict-merge (dict1 dict2) + "Destructively merge DICT2 into DICT1. +Keys in DICT2 override those in DICT1." + (let ((base (or dict1 '(dict)))) + (nrepl-dict-map (lambda (k v) + (nrepl-dict-put base k v)) + (or dict2 '(dict))) + base)) + +(defun nrepl-dict-get-in (dict keys) + "Return the value in a nested DICT. +KEYS is a list of keys. Return nil if any of the keys is not present or if +any of the values is nil." + (let ((out dict)) + (while (and keys out) + (setq out (nrepl-dict-get out (pop keys)))) + out)) + +(defun nrepl-dict-flat-map (function dict) + "Map FUNCTION over DICT and flatten the result. +FUNCTION follows the same restrictions as in `nrepl-dict-map', and it must +also always return a sequence (since the result will be flattened)." + (when dict + (apply #'append (nrepl-dict-map function dict)))) + +(defun nrepl-dict-filter (function dict) + "For all key-values of DICT, return new dict where FUNCTION returns non-nil. + +FUNCTION should be a function taking two arguments, key and value." + (let ((new-map (nrepl-dict)) + (keys (nrepl-dict-keys dict))) + (dolist (key keys) + (let ((val (nrepl-dict-get dict key))) + (when (funcall function key val) + (nrepl-dict-put new-map key val)))) + new-map)) + + +;;; More specific functions +(defun nrepl--cons (car list-or-dict) + "Generic cons of CAR to LIST-OR-DICT." + (if (eq (car list-or-dict) 'dict) + (cons 'dict (cons car (cdr list-or-dict))) + (cons car list-or-dict))) + +(defun nrepl--nreverse (list-or-dict) + "Generic `nreverse' which works on LIST-OR-DICT." + (if (eq (car list-or-dict) 'dict) + (cons 'dict (nreverse (cdr list-or-dict))) + (nreverse list-or-dict))) + +(defun nrepl--push (obj stack) + "Cons OBJ to the top element of the STACK." + ;; stack is assumed to be a list + (if (eq (caar stack) 'dict) + (cons (cons 'dict (cons obj (cdar stack))) + (cdr stack)) + (cons (if (null stack) + obj + (cons obj (car stack))) + (cdr stack)))) + +(defun nrepl--merge (dict1 dict2 &optional no-join) + "Join nREPL dicts DICT1 and DICT2 in a meaningful way. +String values for non \"id\" and \"session\" keys are concatenated. Lists +are appended. nREPL dicts merged recursively. All other objects are +accumulated into a list. DICT1 is modified destructively and +then returned. +If NO-JOIN is given, return the first non nil dict." + (if no-join + (or dict1 dict2) + (cond ((null dict1) dict2) + ((null dict2) dict1) + ((stringp dict1) (concat dict1 dict2)) + ((nrepl-dict-p dict1) + (nrepl-dict-map + (lambda (k2 v2) + (nrepl-dict-put dict1 k2 + (nrepl--merge (nrepl-dict-get dict1 k2) v2 + (member k2 '("id" "session"))))) + dict2) + dict1) + ((and (listp dict2) (listp dict1)) (append dict1 dict2)) + ((listp dict1) (append dict1 (list dict2))) + (t `(,dict1 ,dict2))))) + + +;;; Destructuring-bind of string keys +(defmacro nrepl-dbind-response (response keys &rest body) + "Destructure an nREPL RESPONSE dict. +Bind the value of the provided KEYS and execute BODY." + (declare (debug (form (&rest symbolp) body))) + `(let ,(cl-loop for key in keys + collect `(,key (nrepl-dict-get ,response ,(format "%s" key)))) + ,@body)) +(put 'nrepl-dbind-response 'lisp-indent-function 2) + +(provide 'nrepl-dict) + +;;; nrepl-dict.el ends here