+++ /dev/null
-;;; cider-apropos.el --- Apropos functionality for Clojure -*- lexical-binding: t -*-
-
-;; Copyright © 2014-2024 Jeff Valk, Bozhidar Batsov and CIDER contributors
-;;
-;; Author: Jeff Valk <jvNOSPAMjeffvalk.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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 <query> 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 <query> 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
+++ /dev/null
-;;; 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)))
-
-
-\f
-;;; 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-"))
-
-\f
-;;; 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 <query> 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 <query> nil t)." t)
-(register-definition-prefixes "cider-apropos" '("apropos-special-form" "cider-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; Generated autoloads from cider-client.el
-
-(register-definition-prefixes "cider-client" '("cider-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; Generated autoloads from cider-common.el
-
-(register-definition-prefixes "cider-common" '("cider-"))
-
-\f
-;;; Generated autoloads from cider-completion.el
-
-(register-definition-prefixes "cider-completion" '("cider-"))
-
-\f
-;;; Generated autoloads from cider-completion-context.el
-
-(register-definition-prefixes "cider-completion-context" '("cider-completion-"))
-
-\f
-;;; Generated autoloads from cider-connection.el
-
-(register-definition-prefixes "cider-connection" '("cider-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; Generated autoloads from cider-doc.el
-
-(register-definition-prefixes "cider-doc" '("cider-"))
-
-\f
-;;; Generated autoloads from cider-docstring.el
-
-(register-definition-prefixes "cider-docstring" '("cider-"))
-
-\f
-;;; Generated autoloads from cider-eldoc.el
-
-(register-definition-prefixes "cider-eldoc" '("cider-"))
-
-\f
-;;; Generated autoloads from cider-eval.el
-
-(register-definition-prefixes "cider-eval" '("cider-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; Generated autoloads from cider-jar.el
-
-(register-definition-prefixes "cider-jar" '("cider-jar-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; Generated autoloads from cider-overlays.el
-
-(register-definition-prefixes "cider-overlays" '("cider-"))
-
-\f
-;;; Generated autoloads from cider-popup.el
-
-(register-definition-prefixes "cider-popup" '("cider-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; Generated autoloads from cider-repl.el
-
-(register-definition-prefixes "cider-repl" '("cider-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; Generated autoloads from cider-resolve.el
-
-(register-definition-prefixes "cider-resolve" '("cider-resolve-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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"))
-
-\f
-;;; Generated autoloads from cider-stacktrace.el
-
-(register-definition-prefixes "cider-stacktrace" '("cider-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; 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-"))
-
-\f
-;;; Generated autoloads from cider-xref-backend.el
-
-(register-definition-prefixes "cider-xref-backend" '("cider--"))
-
-\f
-;;; Generated autoloads from nrepl-client.el
-
-(register-definition-prefixes "nrepl-client" '("cider-" "emacs-bug-46284/when-27.1-windows-nt" "nrepl-"))
-
-\f
-;;; Generated autoloads from nrepl-dict.el
-
-(register-definition-prefixes "nrepl-dict" '("nrepl-"))
-\f
-;;; 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
+++ /dev/null
-;;; cider-browse-ns.el --- CIDER namespace browser -*- lexical-binding: t; -*-
-
-;; Copyright © 2014-2024 John Andrews, Bozhidar Batsov and CIDER contributors
-
-;; Author: John Andrews <john.m.andrewsNOSPAMgmail.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; M-x cider-browse-ns
-;;
-;; Display a list of all vars in a namespace.
-;; Pressing <enter> 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 <enter> 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
+++ /dev/null
-;;; cider-browse-spec.el --- CIDER spec browser -*- lexical-binding: t; -*-
-
-;; Copyright © 2017-2024 Juan Monetta, Bozhidar Batsov and CIDER contributors
-
-;; Author: Juan Monetta <jpmonettasNOSPAMgmail.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; M-x cider-browse-spec
-;;
-;; Display a spec description you can browse.
-;; Pressing <enter> 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 <enter> 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
+++ /dev/null
-;;; cider-cheatsheet.el --- Quick reference for Clojure -*- lexical-binding: t -*-
-
-;; Copyright © 2019-2024 Kris Jenkins, Bozhidar Batsov and CIDER contributors
-;;
-;; Author: Kris Jenkins <krisajenkinsNOSPAMgmail.com>
-;; Kato Muso <mNOSPAMkatomuso.io>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; 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 <http://www.gnu.org/licenses/>.
-
-;; 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
+++ /dev/null
-;;; cider-client.el --- A layer of abstraction above low-level nREPL client code. -*- lexical-binding: t -*-
-
-;; Copyright © 2013-2024 Bozhidar Batsov
-;;
-;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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)
-
-\f
-;;; 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)))))
-
-\f
-;;; 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"))
-
-\f
-;;; 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))))
-
-\f
-;;; 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))
-
-\f
-;;; 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
+++ /dev/null
-;;; cider-clojuredocs.el --- ClojureDocs integration -*- lexical-binding: t -*-
-
-;; Copyright © 2014-2024 Bozhidar Batsov and CIDER contributors
-;;
-;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; cider-common.el --- Common use functions -*- lexical-binding: t; -*-
-
-;; Copyright © 2015-2024 Artur Malabarba
-
-;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; 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
+++ /dev/null
-;;; cider-completion-context.el --- Context parsing -*- lexical-binding: t -*-
-
-;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Bozhidar Batsov <bozhidar@batsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; cider-completion.el --- Smart REPL-powered code completion -*- lexical-binding: t -*-
-
-;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; 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 <bruce.connor.amNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Vitalie Spinu <spinuvitNOSPAMgmail.com>
-;;
-;; 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 <http://www.gnu.org/licenses/>.
-;;
-;; 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))
-
-\f
-;;; 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) "<no project>")
- (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) "<no project>")
- (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) "<no project>")
- (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)))
-
-\f
-;;; 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*")))
-
-\f
-;;; 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))
-
-\f
-;;; 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))))
-
-\f
-;;; 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
+++ /dev/null
-;;; 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 <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; 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)
-
-\f
-;;; 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")
-
-\f
-;;; 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))
-
-\f
-;;; 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))))
-
-\f
-;;; 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")))
-
-\f
-;;; 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))))))))
-
-\f
-;;; 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"))))))
-
-\f
-;;; 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
+++ /dev/null
-;;; cider-doc.el --- CIDER documentation functionality -*- lexical-binding: t -*-
-
-;; Copyright © 2014-2024 Bozhidar Batsov, Jeff Valk and CIDER contributors
-
-;; Author: Jeff Valk <jvNOSPAMjeffvalk.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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")
-
-\f
-;;; 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.")
-
-\f
-;;; 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"))
-
-\f
-;; 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"))
-
-\f
-;; 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)))
-\f
-;; 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 "<backtab>") #'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))
-
-\f
-;;; 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))
-
-\f
-;;; 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)))))
-
-\f
-;;; 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
- (when fetched-doc
- (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
+++ /dev/null
-;;; cider-docstring.el --- Docstring rendering -*- lexical-binding: t -*-
-
-;; Copyright © 2013-2024 Bozhidar Batsov and CIDER contributors
-;;
-;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; 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 <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; eldoc support for Clojure.
-
-;;; Code:
-
-(require 'cider-client)
-(require 'cider-common) ; for cider-symbol-at-point
-(require '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
+++ /dev/null
-;;; 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 <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-;; Arne Brasseur <arneNOSPAMarnebraasseur.net>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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"))
-
-\f
-;;; 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))))
-
-\f
-;;; 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)))))))))
-
-\f
-;;; 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)))))
-
-\f
-;;; 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
+++ /dev/null
-;;; cider-find.el --- Functionality for finding things -*- lexical-binding: t -*-
-
-;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; cider-format.el --- Code and EDN formatting functionality -*- lexical-binding: t -*-
-
-;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Middleware-powered code and EDN formatting functionality.
-
-;;; Code:
-
-(require 'map)
-(require 'seq)
-(require 'subr-x)
-
-(require 'cider-client)
-(require 'cider-util)
-
-\f
-;; 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)))
-
-\f
-;;; 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))))
-
-\f
-;;; 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))))
-
-\f
-;;; 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))))
-
-\f
-;;; 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
+++ /dev/null
-;;; 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 <ianNOSPAMvitalreactor.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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 "<non-inspectable value>")
- ""
- 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
+++ /dev/null
-;;; cider-jar.el --- Jar functionality for Clojure -*- lexical-binding: t -*-
-
-;; Copyright © 2022-2024 Arne Brasseur
-;;
-;; Author: Arne Brasseur <arne@arnebrasseur.net>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; cider-log.el --- Log inspection functionality for Clojure -*- lexical-binding: t -*-
-
-;; Copyright © 2023-2024 Bozhidar Batsov and CIDER contributors
-
-;; Author: r0man <romanNOSPAMburningswell.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; 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 <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; 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 <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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) "<no project>")
- (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"))
-
-\f
-;;; 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))
-
-
-\f
-;;; 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 <mouse-8> and <mouse-9>.
-
-As it stands Emacs fires these events on <mouse-8> and <mouse-9> on 'x' and
-'w32'systems while on macOS it presents them on <mouse-4> and <mouse-5>.")
-
-(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 "<mouse-8>" "<mouse-4>")) #'xref-pop-marker-stack)
- (define-key map (kbd (if cider--has-many-mouse-buttons "<mouse-9>" "<mouse-5>")) #'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))))))
-
-\f
-;;; 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)))
-
-\f
-;;; 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)))
-
-\f
-;;; 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
+++ /dev/null
-;;; cider-ns.el --- Namespace manipulation functionality -*- lexical-binding: t -*-
-
-;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; cider-overlays.el --- Managing CIDER overlays -*- lexical-binding: t; -*-
-
-;; Copyright © 2015-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-
-;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; 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)
-
-\f
-;;; 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"))
-
-\f
-;;; 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)))))))
-
-\f
-;;; 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)))))))
-
-\f
-;;; 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
+++ /dev/null
-;; -*- no-byte-compile: t; lexical-binding: nil -*-
-(define-package "cider" "20241223.1320"
- "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 "430cfd40c57ad3ba4ef39262acf411531dc734f5"
- :revdesc "430cfd40c57a"
- :keywords '("languages" "clojure" "cider")
- :authors '(("Tim King" . "kingtimNOSPAMgmail.com")
- ("Phil Hagelberg" . "technomancyNOSPAMgmail.com")
- ("Bozhidar Batsov" . "bozhidarNOSPAMbatsov.dev")
- ("Artur Malabarba" . "bruce.connor.amNOSPAMgmail.com")
- ("Hugo Duncan" . "hugoNOSPAMhugoduncan.org")
- ("Steve Purcell" . "steveNOSPAMsanityinc.com"))
- :maintainers '(("Bozhidar Batsov" . "bozhidarNOSPAMbatsov.dev")))
+++ /dev/null
-;;; cider-popup.el --- Creating and quitting popup buffers -*- lexical-binding: t; -*-
-
-;; Copyright © 2015-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-
-;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; 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
+++ /dev/null
-;;; cider-profile.el --- CIDER support for profiling -*- lexical-binding: t; -*-
-
-;; Copyright © 2014-2024 Edwin Watkeys and CIDER contributors
-
-;; Author: Edwin Watkeys <edwNOSPAMposeur.com>
-;; Juan E. Maya <jmayaalvNOSPAMgmail.com>
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; 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
+++ /dev/null
-;;; 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 <http://www.gnu.org/licenses/>.
-
-;; 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
+++ /dev/null
-;;; 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 <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-;; Reid McKenzie <meNOSPAMarrdem.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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")
-
-\f
-(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"))
-
-\f
-;;;; 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))))
-
-\f
-;;; 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: <C-c C-q>
-;; 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: <C-c C-q>
-;; 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 <M-x cider-view-manual> 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 <M-x customize-group cider> to
-;; get a feel for this. If you're thirsty for knowledge you should try
-;; <M-x cider-drink-a-sip>.
-;;
-;; If you think you've encountered a bug (or have some suggestions for
-;; improvements) use <M-x cider-report-bug> 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 <M-x cider-repl-clear-help-banner> command.
-;; You can disable it from appearing on start by setting
-;; `cider-repl-display-help-banner' to nil.
-;; ======================================================================
-"))
-
-\f
-;;; 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))))))
-
-\f
-;;; 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))
-
-\f
-;;; 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))
-
-\f
-;;; 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))
-
-\f
-;;;;; 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-<return>") #'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-<up>") #'cider-repl-backward-input)
- (define-key map (kbd "C-<down>") #'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
+++ /dev/null
-;;; 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 <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; 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
+++ /dev/null
-;;; cider-scratch.el --- *scratch* buffer for Clojure -*- lexical-binding: t -*-
-
-;; Copyright © 2014-2024 Bozhidar Batsov and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; 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 <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*-
-
-;; Copyright © 2014-2024 Jeff Valk, Bozhidar Batsov and CIDER contributors
-
-;; Author: Jeff Valk <jvNOSPAMjeffvalk.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*-
-
-;; Copyright © 2014-2024 Jeff Valk, Bozhidar Batsov and CIDER contributors
-
-;; Author: Jeff Valk <jvNOSPAMjeffvalk.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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 "<backtab>") #'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
+++ /dev/null
-;;; cider-tracing.el --- Executing tracing functionality -*- lexical-binding: t -*-
-
-;; Copyright © 2013-2024 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;; 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 <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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))))
-
-\f
-;;; 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)))))
-
-\f
-;;; 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)))
-\f
-;;; 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")))
-
-\f
-;;; 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))
-
-\f
-;;; 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 "^\e\\[" 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)))))))
-
-\f
-;;; 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)))
-
-\f
-;;; 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))
-
-\f
-;;; 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 <C-u \\[cider-inspect]> to inspect the defun at point's result."
- "Press <C-u C-u \\[cider-inspect]> 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 <M-x customize-group RET cider RET> to see every possible setting you can customize."
- "Use <M-x customize-group RET cider-repl RET> 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
+++ /dev/null
-;;; 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 <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; cider-xref.el --- Xref functionality for Clojure -*- lexical-binding: t -*-
-
-;; Copyright © 2019-2024 Bozhidar Batsov and CIDER contributors
-;;
-;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; 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
+++ /dev/null
-;;; 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 <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-;; Maintainer: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; URL: https://www.github.com/clojure-emacs/cider
-;; Package-Version: 20241223.1320
-;; Package-Revision: 430cfd40c57a
-;; 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 <http://www.gnu.org/licenses/>.
-
-;; 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))))
-
-\f
-;;; 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))))
-
-\f
-;;; 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 <build-id>.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 (<build-id>.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)))))))
-
-\f
-;;; 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)))
-
-\f
-;;; 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)
-
-\f
-;;; Aliases
-
-;;;###autoload
-(defalias 'cider-jack-in #'cider-jack-in-clj)
-;;;###autoload
-(defalias 'cider-connect #'cider-connect-clj)
-
-\f
-;;; 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 <path, port> 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:
- ;; <username> 15411 0.0 0.0 37915744 16084 s000 S+ 3:02PM 0:00.02 bb --nrepl-server
- ;; <username> 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 <descriptor>
- ;; -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 <PID>.
- (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 <PID>.
- (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
+++ /dev/null
-#!/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
+++ /dev/null
-#!/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
+++ /dev/null
-;;; 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 <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-;; Reid McKenzie <meNOSPAMarrdem.com>
-;;
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-;;
-;; This file is not part of GNU Emacs.
-;;
-;;; Commentary:
-;;
-;; 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 "<backtab>") #'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
+++ /dev/null
-;;; 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 <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-;;
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-;;
-;; This file is not part of GNU Emacs.
-;;
-;;; Commentary:
-;;
-;; 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))
-
-\f
-;;; 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)))))
-
-\f
-;;; 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
--- /dev/null
+;;; cider-apropos.el --- Apropos functionality for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2025 Jeff Valk, Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Jeff Valk <jvNOSPAMjeffvalk.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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 <query> 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 <query> 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
--- /dev/null
+;;; 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)))
+
+
+\f
+;;; 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-"))
+
+\f
+;;; 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 <query> 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 <query> nil t)." t)
+(register-definition-prefixes "cider-apropos" '("apropos-special-form" "cider-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; Generated autoloads from cider-client.el
+
+(register-definition-prefixes "cider-client" '("cider-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; Generated autoloads from cider-common.el
+
+(register-definition-prefixes "cider-common" '("cider-"))
+
+\f
+;;; Generated autoloads from cider-completion.el
+
+(register-definition-prefixes "cider-completion" '("cider-"))
+
+\f
+;;; Generated autoloads from cider-completion-context.el
+
+(register-definition-prefixes "cider-completion-context" '("cider-completion-"))
+
+\f
+;;; Generated autoloads from cider-connection.el
+
+(register-definition-prefixes "cider-connection" '("cider-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; Generated autoloads from cider-doc.el
+
+(register-definition-prefixes "cider-doc" '("cider-"))
+
+\f
+;;; Generated autoloads from cider-docstring.el
+
+(register-definition-prefixes "cider-docstring" '("cider-"))
+
+\f
+;;; Generated autoloads from cider-eldoc.el
+
+(register-definition-prefixes "cider-eldoc" '("cider-"))
+
+\f
+;;; Generated autoloads from cider-eval.el
+
+(register-definition-prefixes "cider-eval" '("cider-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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)
+(register-definition-prefixes "cider-inspector" '("cider-"))
+
+\f
+;;; Generated autoloads from cider-jar.el
+
+(register-definition-prefixes "cider-jar" '("cider-jar-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; Generated autoloads from cider-overlays.el
+
+(register-definition-prefixes "cider-overlays" '("cider-"))
+
+\f
+;;; Generated autoloads from cider-popup.el
+
+(register-definition-prefixes "cider-popup" '("cider-"))
+
+\f
+;;; Generated autoloads from cider-profile.el
+
+(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-clear "cider-profile" "\
+Clear any collected profile data." t)
+(register-definition-prefixes "cider-profile" '("cider-profile-"))
+
+\f
+;;; Generated autoloads from cider-repl.el
+
+(register-definition-prefixes "cider-repl" '("cider-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; Generated autoloads from cider-resolve.el
+
+(register-definition-prefixes "cider-resolve" '("cider-resolve-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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"))
+
+\f
+;;; Generated autoloads from cider-stacktrace.el
+
+(register-definition-prefixes "cider-stacktrace" '("cider-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; 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-"))
+
+\f
+;;; Generated autoloads from cider-xref-backend.el
+
+(register-definition-prefixes "cider-xref-backend" '("cider--"))
+
+\f
+;;; Generated autoloads from nrepl-client.el
+
+(register-definition-prefixes "nrepl-client" '("cider-" "emacs-bug-46284/when-27.1-windows-nt" "nrepl-"))
+
+\f
+;;; Generated autoloads from nrepl-dict.el
+
+(register-definition-prefixes "nrepl-dict" '("nrepl-"))
+\f
+;;; 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
--- /dev/null
+;;; cider-browse-ns.el --- CIDER namespace browser -*- lexical-binding: t; -*-
+
+;; Copyright © 2014-2025 John Andrews, Bozhidar Batsov and CIDER contributors
+
+;; Author: John Andrews <john.m.andrewsNOSPAMgmail.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; M-x cider-browse-ns
+;;
+;; Display a list of all vars in a namespace.
+;; Pressing <enter> 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 <enter> 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
--- /dev/null
+;;; cider-browse-spec.el --- CIDER spec browser -*- lexical-binding: t; -*-
+
+;; Copyright © 2017-2025 Juan Monetta, Bozhidar Batsov and CIDER contributors
+
+;; Author: Juan Monetta <jpmonettasNOSPAMgmail.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; M-x cider-browse-spec
+;;
+;; Display a spec description you can browse.
+;; Pressing <enter> 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 <enter> 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
--- /dev/null
+;;; cider-cheatsheet.el --- Quick reference for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2019-2025 Kris Jenkins, Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Kris Jenkins <krisajenkinsNOSPAMgmail.com>
+;; Kato Muso <mNOSPAMkatomuso.io>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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
--- /dev/null
+;;; cider-classpath.el --- Basic Java classpath browser -*- lexical-binding: t; -*-
+
+;; Copyright © 2014-2025 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 <http://www.gnu.org/licenses/>.
+
+;; 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
--- /dev/null
+;;; cider-client.el --- A layer of abstraction above low-level nREPL client code. -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2025 Bozhidar Batsov
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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)
+
+\f
+;;; 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)))))
+
+\f
+;;; 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 callback)
+ "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.
+if CALLBACK is non-nil, it will additionally be called on all received messages."
+ (nrepl-send-sync-request request
+ (or connection (cider-current-repl 'any 'ensure))
+ abort-on-input
+ nil
+ callback))
+
+(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 '(repeat sexp)
+ :group 'cider
+ :package-version '(cider . "1.1.0"))
+
+(defun cider--nrepl-format-code-request-options (&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)))))
+ (nrepl-dict
+ `(,@(when indents-dict
+ `("indents" ,indents-dict))
+ ,@(when alias-map-dict
+ `("alias-map" ,alias-map-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 '(repeat sexp)
+ :group 'cider
+ :package-version '(cider . "0.21.0"))
+
+(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"))
+
+(defcustom cider-download-java-sources t
+ "Whether to automatically download source artifacts for 3rd-party Java classes.
+
+When enabled, CIDER will attempt to download source JARs from Maven for
+Java classes if the source file is not found locally. This downloading only
+happens once per artifact, and only when the user jumps to definition or
+requests `cider-doc' on a Java class or a member of the class."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "1.17.1"))
+
+(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-plist (&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))))
+ `("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-plist ()
+ "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))))
+ `("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-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"))
+
+\f
+;;; 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))))
+
+\f
+;;; 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))
+
+\f
+;;; 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
+ "sort-order" "by-name"
+ ,@(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* ((req
+ `("op" "info"
+ "ns" ,(cider-current-ns)
+ ,@(when symbol `("sym" ,symbol))
+ ,@(when class `("class" ,class))
+ ,@(when member `("member" ,member))
+ ,@(when context `("context" ,context))
+ ,@(when cider-download-java-sources `("download-sources-jar" "1"))))
+ (callback
+ (lambda (resp)
+ (let ((status (nrepl-dict-get resp "status"))
+ (coords (nrepl-dict-get resp "coords")))
+ (when (member "download-sources-jar" status)
+ (message "Local source not found, downloading Java sources for artifact %s/%s %s..."
+ (nrepl-dict-get coords "group")
+ (nrepl-dict-get coords "artifact")
+ (nrepl-dict-get coords "version"))))))
+ (var-info
+ (cider-nrepl-send-sync-request req (cider-current-repl) nil callback)))
+ (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-options 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 `("op" "format-edn"
+ "edn" ,edn
+ ,@(cider--nrepl-print-request-plist right-margin)))
+ (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
--- /dev/null
+;;; cider-clojuredocs.el --- ClojureDocs integration -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2025 Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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
--- /dev/null
+;;; cider-common.el --- Common use functions -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2025 Artur Malabarba
+
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
+;;; cider-completion-context.el --- Context parsing -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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-mark-and-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-mark-and-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
--- /dev/null
+;;; cider-completion.el --- Smart REPL-powered code completion -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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.
+ (display-sort-function . identity))) ;; don't override sorting done by backend
+ ((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 (cider-plist-get eldoc-info "ns"))
+ (symbol (cider-plist-get eldoc-info "symbol"))
+ (arglists (cider-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 (&optional arg)
+ "Enables or disables `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. If ARG
+is `1' or nil, enables the custom completion style; if `-1', disables it."
+ (interactive)
+ (if (eq arg -1)
+ (setq completion-category-overrides
+ (assq-delete-all 'cider completion-category-overrides))
+ (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)
+ (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
--- /dev/null
+;;; cider-connection.el --- Connection and session life-cycle management for CIDER -*- lexical-binding: t -*-
+;;
+;; Copyright © 2019-2025 Artur Malabarba, Bozhidar Batsov, Vitalie Spinu and CIDER contributors
+;;
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Vitalie Spinu <spinuvitNOSPAMgmail.com>
+;;
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; 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))
+
+\f
+;;; 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) "<no project>")
+ (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) "<no project>")
+ (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) "<no project>")
+ (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)))
+
+\f
+;;; 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*")))
+
+\f
+;;; 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))
+
+\f
+;;; 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))))
+
+\f
+;;; 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)))))
+
+(defvar-local cider--ancillary-buffer-repl nil
+ "Special buffer-local variable that contains reference to the REPL connection.
+This should be set in ancillary CIDER buffers that originate from some
+event (e.g. *cider-inspector*, *cider-error*) and which never change the
+REPL (connection) which produced them.")
+
+(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)
+ (or cider--ancillary-buffer-repl
+ (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
--- /dev/null
+;;; cider-debug.el --- CIDER interaction with the cider.debug nREPL middleware -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; 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)
+
+\f
+;;; 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"))
+
+\f
+;;; 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
+ `("op" "init-debugger"
+ ,@(cider--nrepl-print-request-plist fill-column))
+ #'cider--debug-response-handler))
+
+\f
+;;; 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))))
+
+\f
+;;; 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")))
+
+\f
+;;; 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
+ (cider-inspector--render-value inspect :next-inspectable)))
+ ;; 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))))))))
+
+\f
+;;; 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"))))))
+
+\f
+;;; 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
--- /dev/null
+;;; cider-doc.el --- CIDER documentation functionality -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2025 Bozhidar Batsov, Jeff Valk and CIDER contributors
+
+;; Author: Jeff Valk <jvNOSPAMjeffvalk.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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")
+
+\f
+;;; 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.")
+
+\f
+;;; 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"))
+
+\f
+;; 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"))
+
+\f
+;; 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)))
+\f
+;; 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 "<backtab>") #'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))
+
+\f
+;;; 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))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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
+ (when fetched-doc
+ (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
--- /dev/null
+;;; cider-docstring.el --- Docstring rendering -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2025 Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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 (cider-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 (cider-plist-get eldoc-info "doc-first-sentence-fragments"))
+ (body-fragments (cider-plist-get eldoc-info "doc-fragments"))
+ (block-tags-fragments (cider-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."
+ (when string
+ (replace-regexp-in-string "\n " "\n" string)))
+
+(provide 'cider-docstring)
+;;; cider-docstring.el ends here
--- /dev/null
+;;; cider-eldoc.el --- eldoc support for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2025 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; eldoc support for Clojure.
+
+;;; Code:
+
+(require 'cider-client)
+(require 'cider-common) ; for cider-symbol-at-point
+(require '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 (cider-plist-get eldoc-info "ns"))
+ (symbol (cider-plist-get eldoc-info "symbol"))
+ (docstring (or (cider--render-docstring-first-sentence eldoc-info)
+ (cider--render-docstring eldoc-info)
+ (when-let (docstring (cider-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 (cider-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 (cider-plist-get eldoc-info "ns"))
+ (symbol (cider-plist-get eldoc-info "symbol"))
+ (arglists (cider-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 (cider-plist-get eldoc-info "ns"))
+ (special-form-symbol (cider-plist-get eldoc-info "symbol"))
+ (arglists (mapcar (lambda (arglist)
+ (if (equal (car arglist) special-form-symbol)
+ (cdr arglist)
+ arglist))
+ (cider-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 (cider-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 (cider-plist-get eldoc-plist "arglists")))
+ (cider-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 (cider-plist-get sexp-eldoc-info "eldoc-info"))
+ (pos (cider-plist-get sexp-eldoc-info "pos"))
+ (thing (cider-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
--- /dev/null
+;;; cider-eval.el --- Interactive evaluation (compilation) functionality -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2025 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+;; Arne Brasseur <arneNOSPAMarnebraasseur.net>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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 :tag "Prompt to save the file if it's been modified" prompt)
+ (const :tag "Don't save the file" nil)
+ (const :tag "Save the file without confirmation" t))
+ :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"))
+
+\f
+;;; 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))))
+
+\f
+;;; 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 dont-show)
+ "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, and the value of DONT-SHOW.
+
+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 dont-show)
+ (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
+ is-compilation repl)
+ "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.
+If IS-COMPILATION is true, render the stacktrace into the error buffer but
+don't bring it forward.
+REPL connection can be provided to set it as the connection for the created
+*cider-error* buffer."
+ (when causes
+ (let* ((repl (or repl (cider-current-repl)))
+ (error-buffer (cider-new-error-buffer #'cider-stacktrace-mode
+ error-types is-compilation)))
+ (with-current-buffer error-buffer
+ (setq cider--ancillary-buffer-repl repl))
+ (cider-stacktrace-render error-buffer 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--display-error-unobtrusively (buffer err)
+ "Display ERR as a minibuffer message and/or as a temporary overlay in BUFFER."
+ (let ((cider-result-use-clojure-font-lock nil)
+ (trimmed-err (funcall cider-inline-error-message-function err)))
+ (with-current-buffer buffer
+ (cider--display-interactive-eval-result trimmed-err
+ 'error
+ (save-excursion (end-of-line) (point))
+ 'cider-error-overlay-face))))
+
+(defun cider--handle-stacktrace-response (causes ex-phase source-buffer)
+ "Handle stacktrace response provided as aggregated CAUSES.
+For EX-PHASE that represents compilation errors, don't show *cider-error*
+buffer but render an error overlay instead in the SOURCE-BUFFER.
+For others, pop up *cider-error* buffer."
+ ;; Handle special "notification" server messages.
+ (dolist (cause causes)
+ (nrepl-dbind-response cause (msg status type)
+ (when (member "notification" status)
+ (nrepl-notify msg type))))
+ ;; Render stacktrace in *cider-error* buffer if it is a runtime error.
+ (cider--render-stacktrace-causes
+ causes nil (member ex-phase (cider-clojure-compilation-error-phases))
+ (with-current-buffer source-buffer (cider-current-repl)))
+ ;; If the error is a compilation error (which we normally don't show
+ ;; *cider-error* buffer for), or the error buffer is disabled, compensate for
+ ;; the lack of info with a overlay error. Verify that the provided buffer is
+ ;; not a REPL buffer but either visits a Clojure source file or is
+ ;; e.g. cider-scratch.
+ (when (and source-buffer
+ (with-current-buffer source-buffer
+ (or (cider-clojure-major-mode-p)
+ (cider-clojurec-major-mode-p)
+ (cider-clojurescript-major-mode-p)))
+ (or (member ex-phase (cider-clojure-compilation-error-phases))
+ (not (cider--show-error-buffer-p))
+ (not (cider-connection-has-capability-p 'jvm-compilation-errors))))
+ ;; Search if any of the received causes contains a "triage" field. Append it
+ ;; to the inline error message if found.
+ (let* ((triage (seq-some (lambda (cause) (nrepl-dict-get cause "triage")) causes))
+ (err-message (mapconcat (lambda (cause) (nrepl-dict-get cause "message"))
+ causes "\n"))
+ (err-message (if triage
+ (concat err-message "\n" triage)
+ err-message)))
+ (cider--display-error-unobtrusively source-buffer err-message))))
+
+(defun cider--analyze-last-stacktrace (callback)
+ "Send `analyze-last-stacktrace' to server and invoke CALLBACK on the result.
+Accumulates a list of causes and then calls CALLBACK on causes and phase."
+ ;; Causes are returned as a series of messages, which we aggregate in `causes'
+ (let (causes ex-phase)
+ (cider-nrepl-send-request
+ `("op" "analyze-last-stacktrace")
+ (lambda (response)
+ (nrepl-dbind-response response (status phase)
+ (if (member "done" status)
+ (funcall callback causes ex-phase)
+ (when phase
+ (setq ex-phase phase))
+ (setq causes (append causes (list response)))))))))
+
+(defun cider-default-err-op-handler (buffer)
+ "Display the last exception, with middleware support.
+Show error overlay in BUFFER if needed."
+ (cider--analyze-last-stacktrace
+ (lambda (causes phase) (cider--handle-stacktrace-response causes phase buffer))))
+
+(defun cider-default-err-handler (&optional buffer)
+ "This function determines how the error buffer is shown.
+It delegates the actual error content to the eval or op handler.
+Show error overlay in BUFFER if needed."
+ (cond ((cider-nrepl-op-supported-p "analyze-last-stacktrace")
+ (cider-default-err-op-handler buffer))
+ ((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.")
+
+(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-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-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 (error-info)
+ "Return the location (begin end buffer) from the parsed ERROR-INFO.
+If location could not be found, return nil."
+ (save-excursion
+ (when error-info
+ (let ((file (nth 0 error-info))
+ (line (nth 1 error-info))
+ (col (nth 2 error-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)
+ "Parse a possible compiler error MESSAGE and highlight it in EVAL-BUFFER.
+If MESSAGE is an error or warning from the compiler, parse the location
+data from the message and put an overlay on the given location in the code
+buffer.
+If `cider-auto-jump-to-error' is enabled and not NO-JUMP, jump to the
+parsed location."
+ (when-let* ((info (cider-extract-error-info cider-compilation-regexp message))
+ (loc (cider--find-last-error-location info))
+ (overlay (make-overlay (nth 0 loc) (nth 1 loc) (nth 2 loc))))
+ (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)))))))))
+
+\f
+;;; 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))
+ (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)
+ (cider-repl-emit-interactive-stderr err)
+ ;; Don't jump
+ (cider-handle-compilation-errors err eval-buffer t))
+ ;; 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)))
+ ;; eval-error handler
+ (lambda (_buffer)
+ (setq failed t)
+ (funcall nrepl-err-handler source-buffer)))))
+
+(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)))))
+
+(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)))
+
+(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)
+ ;; 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)
+ (cider-handle-compilation-errors
+ err eval-buffer
+ ;; Disable jumping behavior when compiling a single form because
+ ;; lines tend to be spurious (e.g. 0:0) and the jump brings us to
+ ;; the beginning of the same form anyway.
+ t))
+ ;; 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 ""))
+ (nrepl-make-response-handler (or buffer eval-buffer)
+ ;; value
+ (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))))
+ ;; stdout
+ (lambda (_buffer value)
+ (cider-emit-interactive-eval-output value))
+ ;; stderr
+ (lambda (_buffer err)
+ (cider-emit-interactive-eval-err-output err)
+ (cider-handle-compilation-errors err eval-buffer))
+ ;; done
+ (lambda (buffer)
+ (when cider-eval-register
+ (set-register cider-eval-register res))
+ (when done-handler
+ (funcall done-handler buffer))))))
+
+(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))))
+ (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))
+ ;; done handler:
+ nil
+ ;; eval-error handler:
+ (lambda (buffer)
+ (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 buffer)))
+ ;; content type handler:
+ nil
+ ;; truncated handler:
+ (lambda (buffer warning)
+ (cider-emit-into-popup-buffer buffer warning 'font-lock-warning-face t)))))
+
+\f
+;;; 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 plist 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)))
+ (additional-params (nrepl--alist-to-plist additional-params))
+ (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))
+ 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-plist)))
+
+(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-plist)))
+
+(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-plist))))
+
+(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-plist))))
+
+(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-plist))))
+
+(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-plist))))
+
+(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-plist 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-plist)))
+
+(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-plist 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-plist fill-column)
+ (cider--nrepl-pr-request-plist))))
+
+(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-plist 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-plist))))
+
+(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-plist))))
+
+(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-plist))))
+
+(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-plist))))))
+
+(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
--- /dev/null
+;;; cider-find.el --- Functionality for finding things -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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)
+ (cider-keyword-at-point-p (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
--- /dev/null
+;;; cider-format.el --- Code and EDN formatting functionality -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Middleware-powered code and EDN formatting functionality.
+
+;;; Code:
+
+(require 'map)
+(require 'seq)
+(require 'subr-x)
+
+(require 'cider-client)
+(require 'cider-util)
+
+\f
+;; 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)))
+
+\f
+;;; 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))))
+
+\f
+;;; 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))))
+
+\f
+;;; 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))))
+
+\f
+;;; 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
--- /dev/null
+;;; cider-inspector.el --- Object inspector -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2025 Vital Reactor, LLC
+;; Copyright © 2014-2025 Bozhidar Batsov and CIDER contributors
+
+;; Author: Ian Eslick <ianNOSPAMvitalreactor.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Clojure object inspector inspired by SLIME.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'easymenu)
+(require 'seq)
+(require 'cider-client)
+(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-pretty-print nil
+ "When true, pretty print values in the inspector."
+ :type 'boolean
+ :package-version '(cider . "1.18.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"))
+
+(defcustom cider-inspector-display-analytics-hint t
+ "When true, display hint about analytics feature for eligible objects.
+Can be turned to nil once the user sees and acknowledges the feature."
+ :type 'boolean
+ :package-version '(cider . "1.18.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 "y" #'cider-inspector-display-analytics)
+ (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 "P" #'cider-inspector-toggle-pretty-print)
+ (define-key map (kbd "C-c C-p") #'cider-inspector-print-current-value)
+ (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.")
+
+;; 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)))
+ (let ((result (cider-sync-request:inspect-expr expr ns)))
+ (when (nrepl-dict-get result "value")
+ (setq cider-inspector-location-stack nil)
+ (cider-inspector--render-value result :next-inspectable))))
+
+(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)
+ (let ((result (cider-sync-request:inspect-pop)))
+ (when (nrepl-dict-get result "value")
+ (cider-inspector--render-value result :pop))))
+
+(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)))
+ (when (nrepl-dict-get result "value")
+ (push (point) cider-inspector-location-stack)
+ (cider-inspector--render-value result :next-inspectable))))
+
+(defun cider-inspector-inspect-last-exception (index &optional ex-data)
+ "Inspects the exception in the cause stack identified by INDEX.
+If EX-DATA is true, inspect ex-data of the exception instead."
+ (interactive)
+ (cl-assert (numberp index))
+ (let ((result (cider-nrepl-send-sync-request
+ `("op" "inspect-last-exception"
+ "index" ,index
+ ,@(when ex-data
+ `("ex-data" "true")))
+ (cider-current-repl))))
+ (when (nrepl-dict-get result "value")
+ (setq cider-inspector-location-stack nil)
+ (cider-inspector--render-value result :next-inspectable))))
+
+(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)))
+ (when (nrepl-dict-get result "value")
+ (cider-inspector--render-value result))))
+
+(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)))
+ (when (nrepl-dict-get result "value")
+ (cider-inspector--render-value result))))
+
+(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-current-repl))))
+ (when (nrepl-dict-get result "value")
+ (cider-inspector--render-value result))))
+
+(defun cider-inspector-refresh ()
+ "Re-render the currently inspected 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)
+ (let ((result (cider-sync-request:inspect-next-page)))
+ (when (nrepl-dict-get result "value")
+ (cider-inspector--render-value result))))
+
+(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)
+ (let ((result (cider-sync-request:inspect-prev-page)))
+ (when (nrepl-dict-get result "value")
+ (cider-inspector--render-value result))))
+
+(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-display-analytics ()
+ "Toggle the display of analytics for the inspected object."
+ (interactive)
+ ;; Disable hint about analytics feature so that it is never displayed again.
+ (when cider-inspector-display-analytics-hint
+ (customize-set-variable 'cider-inspector-display-analytics-hint nil))
+ (let ((result (cider-nrepl-send-sync-request `("op" "inspect-display-analytics")
+ (cider-current-repl))))
+ (when (nrepl-dict-get result "value")
+ (cider-inspector--render-value result :next-inspectable))))
+
+(defun cider-inspector-toggle-pretty-print ()
+ "Toggle the pretty printing of values in the inspector."
+ (interactive)
+ (let ((result (cider-nrepl-send-sync-request
+ `("op" "inspect-toggle-pretty-print")
+ (cider-current-repl))))
+ (when (nrepl-dict-get result "value")
+ (cider-inspector--render-value result))))
+
+(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-current-repl))))
+ (when (nrepl-dict-get result "value")
+ (cider-inspector--render-value result :next-inspectable))))
+
+(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)))
+ (cider-inspector--render-value result)
+ (message "Defined current inspector value as #'%s/%s" ns var-name)))
+
+(defun cider-inspector-print-current-value ()
+ "Print the current value of the inspector."
+ (interactive)
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "inspect-print-current-value")
+ (let ((buffer (cider-popup-buffer cider-result-buffer nil 'clojure-mode 'ancillary)))
+ (cider-nrepl-send-request
+ `("op" "inspect-print-current-value"
+ ,@(cider--nrepl-print-request-plist fill-column))
+ (cider-popup-eval-handler buffer)
+ (cider-current-repl))))
+
+(defun cider-inspector-tap-current-val ()
+ "Sends the current Inspector current value to `tap>'."
+ (interactive)
+ (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)))))
+
+(defun cider-inspector-tap-at-point ()
+ "Sends the current Inspector current sub-value (per POINT) to `tap>'."
+ (interactive)
+ (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")))))
+
+;; nREPL interactions
+
+(defun cider-sync-request:inspect-pop ()
+ "Move one level up in the inspector stack."
+ (cider-nrepl-send-sync-request `("op" "inspect-pop")
+ (cider-current-repl)))
+
+(defun cider-sync-request:inspect-push (idx)
+ "Inspect the inside value specified by IDX."
+ (cider-nrepl-send-sync-request `("op" "inspect-push"
+ "idx" ,idx)
+ (cider-current-repl)))
+
+(defun cider-sync-request:inspect-previous-sibling ()
+ "Inspect the previous sibling value within a sequential parent."
+ (cider-nrepl-send-sync-request `("op" "inspect-previous-sibling")
+ (cider-current-repl)))
+
+(defun cider-sync-request:inspect-next-sibling ()
+ "Inspect the next sibling value within a sequential parent."
+ (cider-nrepl-send-sync-request `("op" "inspect-next-sibling")
+ (cider-current-repl)))
+
+(defun cider-sync-request:inspect-next-page ()
+ "Jump to the next page in paginated collection view."
+ (cider-nrepl-send-sync-request '("op" "inspect-next-page")
+ (cider-current-repl)))
+
+(defun cider-sync-request:inspect-prev-page ()
+ "Jump to the previous page in paginated collection view."
+ (cider-nrepl-send-sync-request '("op" "inspect-prev-page")
+ (cider-current-repl)))
+
+(defun cider-sync-request:inspect-set-page-size (page-size)
+ "Set the page size in paginated view to PAGE-SIZE."
+ (declare (obsolete "use `inspect-refresh' op instead." "1.15.0"))
+ (cider-nrepl-send-sync-request `("op" "inspect-set-page-size"
+ "page-size" ,page-size)
+ (cider-current-repl)))
+
+(defun cider-sync-request:inspect-set-max-atom-length (max-length)
+ "Set the max length of nested atoms to MAX-LENGTH."
+ (declare (obsolete "use `inspect-refresh' op instead." "1.15.0"))
+ (cider-nrepl-send-sync-request `("op" "inspect-set-max-atom-length"
+ "max-atom-length" ,max-length)
+ (cider-current-repl)))
+
+(defun cider-sync-request:inspect-set-max-coll-size (max-size)
+ "Set the maximum number of nested collection members to display to MAX-SIZE."
+ (declare (obsolete "use `inspect-refresh' op instead." "1.15.0"))
+ (cider-nrepl-send-sync-request `("op" "inspect-set-max-coll-size"
+ "max-coll-size" ,max-size)
+ (cider-current-repl)))
+
+(defun cider-sync-request:inspect-set-max-nested-depth (max-nested-depth)
+ "Set the level of nesting to display before truncating to MAX-NESTED-DEPTH."
+ (declare (obsolete "use `inspect-refresh' op instead." "1.15.0"))
+ (cider-nrepl-send-sync-request `("op" "inspect-set-max-nested-depth"
+ "max-nested-depth" ,max-nested-depth)
+ (cider-current-repl)))
+
+(defun cider-sync-request:inspect-def-current-val (ns var-name)
+ "Defines a var with VAR-NAME in NS with the current inspector value."
+ (cider-nrepl-send-sync-request `("op" "inspect-def-current-value"
+ "ns" ,ns
+ "var-name" ,var-name)
+ (cider-current-repl)))
+
+(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-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-current-repl)))
+
+(defun cider-sync-request:inspect-expr (expr ns)
+ "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 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))
+ ,@(when cider-inspector-display-analytics-hint
+ `("display-analytics-hint" "true"))
+ ,@(when cider-inspector-pretty-print
+ `("pretty-print" "true"))))
+ (cider-nrepl-send-sync-request (cider-current-repl))))
+
+(declare-function cider-set-buffer-ns "cider-mode")
+
+;; Render Inspector from Structured Values
+(defun cider-inspector--render-value (dict-or-value &optional point-action)
+ "Render DICT-OR-VALUE.
+It can either be a value directly or a inspector response that contains
+`value' field.
+POINT-ACTION can either be nil (leave point where it is now), `:pop' (pop point
+from stack), `:next-inspectable' (move point to next inspectable object)."
+ (let* ((value (if (nrepl-dict-p dict-or-value)
+ (nrepl-dict-get dict-or-value "value")
+ dict-or-value))
+ (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)))
+ (repl (cider-current-repl))
+ (current-point (point)))
+ (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)
+ (cider-popup-buffer-display cider-inspector-buffer cider-inspector-auto-select-buffer)
+ (when cider-inspector-fill-frame (delete-other-windows))
+ (with-current-buffer cider-inspector-buffer
+ (setq cider--ancillary-buffer-repl repl)
+ (cider-set-buffer-ns ns)
+ (cond ((eq point-action nil) (goto-char current-point))
+ ((eq point-action :next-inspectable) (ignore-errors (cider-inspector-next-inspectable-object 1)))
+ ((eq point-action :pop)
+ (goto-char (or (when cider-inspector-location-stack
+ (pop cider-inspector-location-stack))
+ current-point)))))))
+
+(cl-defun cider-inspector-render (buffer str &key font-size truncate-lines-defined truncate-lines-p)
+ "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)))
+ (error (insert "\nInspector error for: " str))))
+ (goto-char (point-min))))
+
+(defvar cider-inspector-looking-at-java-p nil)
+
+(defun cider-inspector-render* (elements)
+ "Render ELEMENTS."
+ (setq cider-inspector-looking-at-java-p nil)
+ (dolist (el elements)
+ (cider-inspector-render-el* el)))
+
+(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 "<non-inspectable value>")
+ ""
+ 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
--- /dev/null
+;;; cider-jar.el --- Jar functionality for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2022-2025 Arne Brasseur
+;;
+;; Author: Arne Brasseur <arneNOSPAMarnebrasseur.net>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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
--- /dev/null
+;;; cider-log.el --- Log inspection functionality for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2023-2025 Bozhidar Batsov and CIDER contributors
+
+;; Author: r0man <romanNOSPAMburningswell.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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-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
+ `("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-print-request-plist fill-column))
+ (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-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-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 "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
+(defun cider-log-show-stacktrace (&rest _)
+ "Removed."
+ (interactive)
+ (message "This function has been removed.
+You can jump to functions and methods directly from the printed stacktrace now."))
+(make-obsolete 'cider-log-show-stacktrace nil "1.18")
+
+(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)
+ ("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)
+ ("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
--- /dev/null
+;;; cider-macroexpansion.el --- Macro expansion support -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2025 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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
--- /dev/null
+;;; cider-mode.el --- Minor mode for REPL interactions -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2025 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidar@batsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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) "<no project>")
+ (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"))
+
+\f
+;;; 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))
+
+
+\f
+;;; 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 <mouse-8> and <mouse-9>.
+
+As it stands Emacs fires these events on <mouse-8> and <mouse-9> on 'x' and
+'w32'systems while on macOS it presents them on <mouse-4> and <mouse-5>.")
+
+(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 "<mouse-8>" "<mouse-4>")) #'xref-pop-marker-stack)
+ (define-key map (kbd (if cider--has-many-mouse-buttons "<mouse-9>" "<mouse-5>")) #'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))))))
+
+\f
+;;; 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 functions being traced or profiled."
+ :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)))
+ ;; FIXME: This matches values too, not just keys.
+ (when (or (nrepl-dict-get meta "orchard.trace/traced")
+ (nrepl-dict-get meta "orchard.profile/profiled"))
+ (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 (nrepl-dict-get meta "fn")))
+ (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)))
+
+\f
+;;; 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)
+ ;; In `clojure-ts-mode', when `backward-up-list' is used,
+ ;; `user-error' is signaled instead of `scan-error' because
+ ;; the operation is delegated to the `treesit-up-list'
+ ;; function.
+ (user-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)))
+
+\f
+;;; 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)
+ (with-suppressed-warnings ((free-vars clojure-ts-get-indent-function))
+ (setq-local clojure-ts-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))
+ (cider-enable-cider-completion-style 1)
+ (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
+ clojure-ts-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
--- /dev/null
+;;; cider-ns.el --- Namespace manipulation functionality -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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 :tag "Prompt to save files if they have been modified" prompt)
+ (const :tag "Don't save the files" nil)
+ (const :tag "Save the files without confirmation" t))
+ :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 (repeat :tag "Enable for specific modes" symbol)
+ (const :tag "Always" 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."
+ (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 `("op" ,(cider-ns--reload-op "reload-clear")) conn))
+ (cider-nrepl-send-request
+ `("op" ,(cider-ns--reload-op (if all? "reload-all" "reload"))
+ ,@(cider--nrepl-print-request-plist 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)))
+ (lambda (response)
+ (cider-ns-refresh--handle-response response log-buffer))
+ conn))))))
+
+(provide 'cider-ns)
+;;; cider-ns.el ends here
--- /dev/null
+;;; cider-overlays.el --- Managing CIDER overlays -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; 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)
+
+\f
+;;; 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"))
+
+\f
+;;; 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))
+ ;; Maximum value width at which we truncate it.
+ (truncation-threshold (* 3 (window-width)))
+ (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 can be very slow on large results, so check
+ ;; with a cheaper predicate first. Conservatively limit to
+ ;; truncation threshold.
+ (> (length display-string) truncation-threshold)
+ (> (string-width display-string)
+ (- (window-width) (current-column))))
+ (setq display-string (concat " \n" display-string)))
+ (when (or (> (length display-string) truncation-threshold)
+ (> (string-width display-string) truncation-threshold))
+ (setq display-string
+ (concat (substring display-string 0 truncation-threshold)
+ (substitute-command-keys
+ "...\nResult truncated. Type `\\[cider-inspect-last-result]' to inspect it."))))
+ ;; 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)
+ ;; 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 display-string))
+ (window-width win))
+ (not truncate-lines)))
+ o)))))))
+
+\f
+;;; 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)))))))
+
+\f
+;;; 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
--- /dev/null
+;; -*- no-byte-compile: t; lexical-binding: nil -*-
+(define-package "cider" "20250520.1110"
+ "Clojure Interactive Development Environment that Rocks."
+ '((emacs "27")
+ (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://www.github.com/clojure-emacs/cider"
+ :commit "f83d7684185b1a8e6acdf6be6cd8d304a92f4874"
+ :revdesc "f83d7684185b"
+ :keywords '("languages" "clojure" "cider")
+ :authors '(("Tim King" . "kingtimNOSPAMgmail.com")
+ ("Phil Hagelberg" . "technomancyNOSPAMgmail.com")
+ ("Bozhidar Batsov" . "bozhidarNOSPAMbatsov.dev")
+ ("Artur Malabarba" . "bruce.connor.amNOSPAMgmail.com")
+ ("Hugo Duncan" . "hugoNOSPAMhugoduncan.org")
+ ("Steve Purcell" . "steveNOSPAMsanityinc.com"))
+ :maintainers '(("Bozhidar Batsov" . "bozhidarNOSPAMbatsov.dev")))
--- /dev/null
+;;; cider-popup.el --- Creating and quitting popup buffers -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
+;;; cider-profile.el --- CIDER support for profiling -*- lexical-binding: t; -*-
+
+;; Copyright © 2014-2025 Edwin Watkeys and CIDER contributors
+
+;; Author: Edwin Watkeys <edwNOSPAMposeur.com>
+;; Juan E. Maya <jmayaalvNOSPAMgmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; 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)
+(require 'cider-inspector)
+
+(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 "n") #'cider-profile-ns-toggle)
+ (define-key map (kbd "C-n") #'cider-profile-ns-toggle)
+ map)
+ "CIDER profiler keymap.")
+
+(defconst cider-profile-menu
+ '("Profile"
+ ["Toggle var profiling" cider-profile-toggle]
+ ["Toggle namespace profiling" cider-profile-ns-toggle]
+ "--"
+ ["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-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 "cider/profile-toggle-ns")
+ (let ((ns (if query
+ (completing-read "Toggle profiling for ns: "
+ (cider-sync-request:ns-list))
+ (cider-current-ns))))
+ (cider-nrepl-send-request
+ `("op" "cider/profile-toggle-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 "cider/profile-toggle-var")
+ (cider-read-symbol-name
+ "Toggle profiling for var: "
+ (lambda (sym)
+ (let ((ns (cider-current-ns)))
+ (cider-nrepl-send-request
+ `("op" "cider/profile-toggle-var"
+ "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)))))))))
+ query)
+
+(defun cider-profile--send-to-inspector (summary-response)
+ "Displays SUMMARY-RESPONSE using the inspector."
+ (let ((value (nrepl-dict-get summary-response "value")))
+ (cider-inspector--render-value value)))
+
+;;;###autoload
+(defun cider-profile-summary ()
+ "Display a summary of currently collected profile data."
+ (interactive)
+ (cider-ensure-op-supported "cider/profile-summary")
+ (cider-inspector--render-value
+ (cider-nrepl-send-sync-request '("op" "cider/profile-summary"))))
+
+;;;###autoload
+(defun cider-profile-clear ()
+ "Clear any collected profile data."
+ (interactive)
+ (cider-ensure-op-supported "cider/profile-clear")
+ (cider-nrepl-send-request
+ '("op" "cider/profile-clear")
+ (cider-profile--make-response-handler
+ (lambda (_buffer value)
+ (when (equal value "cleared")
+ (message "Cleared profile data"))))))
+
+(provide 'cider-profile)
+
+;;; cider-profile.el ends here
--- /dev/null
+;;; cider-repl-history.el --- REPL input history browser -*- lexical-binding: t; -*-
+
+;; Copyright (c) 2017-2025 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 <http://www.gnu.org/licenses/>.
+
+;; 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-delete-entry-at-point ()
+ "Delete history entry (at point)."
+ (interactive)
+ (let* ((orig (point))
+ (str (cider-repl-history-current-string orig)))
+ (with-current-buffer cider-repl-history-repl-buffer
+ (delete str cider-repl-input-history))
+ (cider-repl-history-update)
+ (goto-char orig)))
+
+(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* ((history-length (length cider-command-history))
+ (entry (if (= 1 history-length)
+ "entry"
+ "entries")))
+ (concat
+ (if (and (not regexp)
+ cider-repl-history-display-duplicates)
+ (format "%s %s in the command history."
+ history-length entry)
+ (format "%s (of %s) %s in the command history shown."
+ (length items) history-length 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 "D") #'cider-repl-history-delete-entry-at-point)
+ (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
--- /dev/null
+;;; cider-repl.el --- CIDER REPL mode interactions -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2025 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+;; Reid McKenzie <meNOSPAMarrdem.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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")
+
+\f
+(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)
+
+(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)
+
+(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)
+
+(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"))
+
+\f
+;;;; 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-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))))
+
+\f
+;;; 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
+ (cider-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 `(,@(cider--repl-request-plist)
+ "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))
+ request)))
+
+(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: <C-c C-q>
+;; 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: <C-c C-q>
+;; 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 <M-x cider-view-manual> 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 <M-x customize-group cider> to
+;; get a feel for this. If you're thirsty for knowledge you should try
+;; <M-x cider-drink-a-sip>.
+;;
+;; If you think you've encountered a bug (or have some suggestions for
+;; improvements) use <M-x cider-report-bug> 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 <M-x cider-repl-clear-help-banner> command.
+;; You can disable it from appearing on start by setting
+;; `cider-repl-display-help-banner' to nil.
+;; ======================================================================
+"))
+
+\f
+;;; 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
+ (cider-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
+ (cider-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-plist ()
+ "Plist to be merged into REPL eval requests."
+ `(,@(cider--nrepl-print-request-plist fill-column)
+ ,@(unless cider-repl-use-pretty-printing
+ `("nrepl.middleware.print/print" "cider.nrepl.pprint/pr"))
+ ,@(when cider-repl-use-content-types
+ `("content-type" "true"))))
+
+(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)
+ (cider--repl-request-plist))))))
+
+(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))))))
+
+\f
+;;; 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))
+
+\f
+;;; 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.")
+
+(defvar cider-repl-input-history '()
+ "History list of strings read from the REPL buffer.")
+
+(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)))
+
+(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.
+If this is set to a path the history will be global to all projects. If this is
+set to `per-project', the history will be stored in a file (.cider-history) at
+the root of each project."
+ :type '(choice string symbol))
+
+(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--find-dir-for-history ()
+ "Find the first suitable directory to store the project's history."
+ (seq-find
+ (lambda (dir) (and (not (null dir)) (not (tramp-tramp-file-p dir))))
+ (list nrepl-project-dir (clojure-project-dir) default-directory)))
+
+(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)))
+ (cond
+ (filename (setq cider-repl-history-file filename))
+ ((equal 'per-project cider-repl-history-file)
+ (make-local-variable 'cider-repl-input-history)
+ (when-let ((dir (cider-repl--find-dir-for-history)))
+ (setq-local
+ cider-repl-history-file (expand-file-name ".cider-history" dir)))))
+ (when cider-repl-history-file
+ (condition-case nil
+ ;; 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 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-save-all)))
+
+(defun cider-repl--history-write (filename)
+ "Write history to FILENAME.
+Currently coding system for writing the contents is hardwired to
+utf-8-unix."
+ (let* ((end (min (length cider-repl-input-history) cider-repl-history-size))
+ ;; newest items are at the beginning of the list, thus 0
+ (hist (cl-subseq cider-repl-input-history 0 end)))
+ (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))
+
+(defun cider-repl-history-save-all ()
+ "Save all histories."
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (equal major-mode 'cider-repl-mode)
+ (cider-repl-history-just-save)))))
+
+\f
+;;; 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))
+
+\f
+;;;;; 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-<return>") #'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-<up>") #'cider-repl-backward-input)
+ (define-key map (kbd "C-<down>") #'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)
+ (cider-repl-history-load)
+ (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
--- /dev/null
+;;; cider-resolve.el --- Resolve clojure symbols according to current nREPL connection -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
+;;; cider-scratch.el --- *scratch* buffer for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2025 Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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
--- /dev/null
+;;; cider-selector.el --- Buffer selection command inspired by SLIME's selector -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2025 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Buffer selection command inspired by SLIME's selector.
+
+;;; Code:
+
+(require 'cider-client)
+(require 'cider-eval)
+(require 'cider-scratch)
+
+(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'."
+ (declare (indent 1))
+ (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 ?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
--- /dev/null
+;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2025 Jeff Valk, Bozhidar Batsov and CIDER contributors
+
+;; Author: Jeff Valk <jvNOSPAMjeffvalk.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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 '(radio
+ (integer :tag "Fill Column")
+ (const :tag "None" nil)
+ (const :tag "Use default fill-column" t))
+ :package-version '(cider . "0.7.0"))
+
+(defcustom cider-stacktrace-default-filters '(tooling dup)
+ "Frame types to omit from initial stacktrace display."
+ :type '(repeat symbol)
+ :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"))
+
+(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*")
+
+(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 string)
+ :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)
+ ;; Expand all exception causes to "detail level 1" by default, meaning they
+ ;; will show the message and the data (but not the stacktrace).
+ (setq-local cider-stacktrace-cause-visibility (make-vector 10 1))
+ (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)))))))))
+
+(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-mouse (event &optional ex-data)
+ "Mouse handler for EVENT.
+If EX-DATA is true, inspect ex-data of the exception instead."
+ (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 ex-data)))
+
+(defun cider-stacktrace--inspect-kbd (&optional ex-data)
+ "Keyboard handler.
+If EX-DATA is true, inspect ex-data of the exception instead."
+ (interactive)
+ (when-let ((inspect-index (get-text-property (point) 'inspect-index)))
+ (cider-inspector-inspect-last-exception inspect-index ex-data)))
+
+(defun cider-stacktrace--inspect-ex-data-mouse (event)
+ "Mouse handler for EVENT."
+ (interactive "e")
+ (cider-stacktrace--inspect-mouse event t))
+
+(defun cider-stacktrace--inspect-ex-data-kbd ()
+ "Keyboard handler."
+ (interactive)
+ (cider-stacktrace--inspect-kbd t))
+
+(defvar cider-stacktrace-exception-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] #'cider-stacktrace--inspect-mouse)
+ (define-key map (kbd "p") #'cider-stacktrace--inspect-kbd)
+ (define-key map (kbd "i") #'cider-stacktrace--inspect-kbd)
+ (define-key map (kbd "RET") #'cider-stacktrace--inspect-kbd)
+ map))
+
+(defvar cider-stacktrace-ex-data-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] #'cider-stacktrace--inspect-ex-data-mouse)
+ (define-key map (kbd "p") #'cider-stacktrace--inspect-ex-data-kbd)
+ (define-key map (kbd "i") #'cider-stacktrace--inspect-ex-data-kbd)
+ (define-key map (kbd "RET") #'cider-stacktrace--inspect-ex-data-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 triage 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))
+ (when triage
+ (insert "\n")
+ (cider-stacktrace-emit-indented
+ (propertize (string-trim triage) 'font-lock-face message-face)
+ indent nil))
+ (when spec
+ (insert "\n")
+ (cider-stacktrace--emit-spec-problems spec (concat indent " ")))
+ (when data
+ (insert "\n")
+ (cider-propertize-region `(inspect-index
+ ,inspect-index
+ keymap
+ ,cider-stacktrace-ex-data-map
+ mouse-face
+ highlight)
+ (cider-stacktrace-emit-indented data indent nil t)))
+ (insert "\n"))
+ ;; Detail level 2: stacktrace
+ (cider-propertize-region '(detail 2)
+ (let ((beg (point))
+ (bg `(:background ,cider-stacktrace-frames-background-color :extend t)))
+ (dolist (frame stacktrace)
+ (cider-stacktrace-render-frame buffer frame)
+ (insert "\n"))
+ (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")))
+ ;; 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-at-point ()
+ "Removed."
+ (interactive)
+ (message "This function has been removed.
+You can jump to functions and methods directly from the printed stacktrace now."))
+(make-obsolete 'cider-stacktrace-analyze-at-point nil "1.18")
+
+(defun cider-stacktrace-analyze-in-region (&rest _)
+ "Removed."
+ (interactive)
+ (message "This function has been removed.
+You can jump to functions and methods directly from the printed stacktrace now."))
+(make-obsolete 'cider-stacktrace-analyze-in-region nil "1.18")
+
+(provide 'cider-stacktrace)
+
+;;; cider-stacktrace.el ends here
--- /dev/null
+;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2025 Jeff Valk, Bozhidar Batsov and CIDER contributors
+
+;; Author: Jeff Valk <jvNOSPAMjeffvalk.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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 "<backtab>") #'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
+ `("op" "test-stacktrace"
+ "ns" ,ns
+ "var" ,var
+ "index" ,index
+ ,@(cider--nrepl-print-request-plist fill-column))
+ (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
--- /dev/null
+;;; cider-tracing.el --- Executing tracing functionality -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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
--- /dev/null
+;; cider-util.el --- Common utility functions that don't belong anywhere else -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2025 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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-clojure-ts-mode-p ()
+ "Return non-nil if current buffer is managed by a Clojure[TS] major mode."
+ (derived-mode-p 'clojure-ts-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))))
+
+(defun cider-keyword-at-point-p (&optional point)
+ "Return non-nil if POINT is in a Clojure keyword.
+
+Take into consideration current major mode."
+ (let ((pos (or point (point))))
+ (if (and (cider-clojure-ts-mode-p)
+ (fboundp 'clojure-ts--keyword-node-p)
+ (fboundp 'treesit-node-parent)
+ (fboundp 'treesit-node-at))
+ (clojure-ts--keyword-node-p (treesit-node-parent (treesit-node-at pos)))
+ (member 'clojure-keyword-face (text-properties-at pos)))))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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)))
+
+\f
+;;; Plists
+
+(defun cider-plist-get (plist prop)
+ "Extract PROP from PLIST using `equal'.
+
+An alternative `lax-plist-get' that got deprecated in Emacs 29."
+ (lax-plist-get plist prop))
+
+(defun cider-plist-put (plist prop val)
+ "Change value in PLIST of PROP to VAL, comparing with `equal'.
+
+An alternative to `lax-plist-put' that got deprecated in Emacs 29."
+ (lax-plist-put plist prop val))
+
+\f
+;;; 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")))
+
+\f
+;;; 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))
+
+\f
+;;; 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 "^\e\\[" 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)))))))
+
+\f
+;;; 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)))
+
+\f
+;;; 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))
+
+\f
+;;; 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 <C-u \\[cider-inspect]> to inspect the defun at point's result."
+ "Press <C-u C-u \\[cider-inspect]> 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 <M-x customize-group RET cider RET> to see every possible setting you can customize."
+ "Use <M-x customize-group RET cider-repl RET> 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
--- /dev/null
+;;; cider-xref-backend.el --- CIDER's backend for Emacs' xref functionality -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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
--- /dev/null
+;;; cider-xref.el --- Xref functionality for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2019-2025 Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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
--- /dev/null
+;;; cider.el --- Clojure Interactive Development Environment that Rocks -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2025 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+;; Maintainer: Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;;
+;; Homepage: https://www.github.com/clojure-emacs/cider
+;; Keywords: languages, clojure, cider
+;;
+;; Package-Version: 20250520.1110
+;; Package-Revision: f83d7684185b
+;; Package-Requires: (
+;; (emacs "27")
+;; (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"))
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; 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.19.0-snapshot"
+ "The current version of CIDER.")
+
+(defconst cider-codename "Athens"
+ "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-command nil "1.8.0")
+(make-obsolete-variable 'cider-boot-parameters nil "1.8.0")
+(make-obsolete-variable 'cider-boot-global-options nil "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")
+(make-obsolete-variable 'cider-enrich-classpath nil "1.19.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 deps.edn for clojure-cli, 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
+clojure-cli) 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)
+ ('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
+ "Removed."
+ :type 'boolean
+ :safe #'booleanp)
+
+(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))
+ ('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))
+ ('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)
+ ('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)
+ ('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))))
+
+\f
+;;; 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.1"
+ "The version of nREPL injected on jack-in.
+We inject the newest known version of nREPL just in case
+your version of 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.55.7"
+ "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 (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--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--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-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\"'"))))
+ " -- ")
+ " -- "
+ 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)
+ ;; 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 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))
+ ('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))))
+
+\f
+;;; 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-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 <build-id>.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 (<build-id>.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)
+ (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)))))))
+
+\f
+;;; 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-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-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)))
+
+\f
+;;; 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)
+
+\f
+;;; Aliases
+
+;;;###autoload
+(defalias 'cider-jack-in #'cider-jack-in-clj)
+;;;###autoload
+(defalias 'cider-connect #'cider-connect-clj)
+
+\f
+;;; 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 <path, port> 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:
+ ;; <username> 15411 0.0 0.0 37915744 16084 s000 S+ 3:02PM 0:00.02 bb --nrepl-server
+ ;; <username> 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 <descriptor>
+ ;; -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 <PID>.
+ (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 <PID>.
+ (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")
+ (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
--- /dev/null
+;;; nrepl-client.el --- Client for Clojure nREPL -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2025 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+;; Reid McKenzie <meNOSPAMarrdem.com>
+;;
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; This file is not part of GNU Emacs.
+;;
+;;; Commentary:
+;;
+;; 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-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-dict (dict)
+ "Encode DICT with bencode.
+According to the Bittorrent protocol specification[1], when bencoding
+dictionaries, keys must be strings and appear in sorted order (sorted as
+raw strings, not alphanumerics).
+
+[1] https://www.bittorrent.org/beps/bep_0003.html#bencoding"
+ (let* ((sorted-keys (sort (nrepl-dict-keys dict)
+ (lambda (a b)
+ (string< a b))))
+ (sorted-dict (nrepl-dict)))
+ (dolist (k sorted-keys sorted-dict)
+ (nrepl-dict-put sorted-dict
+ k
+ (nrepl-dict-get dict k)))
+ (mapconcat #'nrepl-bencode (cdr sorted-dict) "")))
+
+(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" (nrepl--bencode-dict 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) buffer))
+ (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 (cider-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 callback)
+ "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.
+
+If CALLBACK is non-nil, it will additionally be called on all received
+messages. This shouldn't be used this for any control logic — use the
+asynchronous `nrepl-send-request' directly for that. CALLBACK here should
+be used to react to some intermediate events in an otherwise synchronous
+command and e.g. notify the user about them."
+ (let* ((time0 (current-time))
+ (response (cons 'dict nil))
+ (nrepl-ongoing-sync-request t)
+ (cb (lambda (resp)
+ ;; If caller has provided `callback', call it on the response.
+ (when callback
+ (funcall callback resp))
+ (nrepl--merge response resp)))
+ status)
+ (nrepl-send-request request cb 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 user 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))
+
+(defvar cider-version)
+
+(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"
+ "client-name" "CIDER"
+ "client-version" ,cider-version)
+ 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 "<backtab>") #'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)
+ (cider-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 (cider-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)))
+
+(provide 'nrepl-client)
+
+;;; nrepl-client.el ends here
--- /dev/null
+;;; nrepl-dict.el --- Dictionary functions for Clojure nREPL -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2025 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2025 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.dev>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+;;
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; This file is not part of GNU Emacs.
+;;
+;;; Commentary:
+;;
+;; 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)
+(require 'cider-util)
+
+
+(defun nrepl-dict (&rest key-vals)
+ "Create nREPL dict from KEY-VALS."
+ (if (cl-evenp (length key-vals))
+ (cons 'dict key-vals)
+ (error "An even number of KEY-VALS is needed to build a dict object")))
+
+(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 (cider-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 (cider-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))
+
+\f
+;;; 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--alist-to-plist (maybe-alist)
+ "Transform MAYBE-ALIST into a plist if it is an alist.
+Compatibility function for functions that used to accepts nrepl request
+options as alists. A warning will be printed if alist is received."
+ (let ((first-arg (car-safe maybe-alist)))
+ (if (or (null first-arg) (not (listp first-arg)))
+ maybe-alist ;; It is a plist - don't have to convert
+ (warn "Received alist where it should have been plist: %s" maybe-alist)
+ (seq-mapcat #'identity maybe-alist))))
+
+(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)))))
+
+\f
+;;; 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
projects / emacsconfig.git / commitdiff