+++ /dev/null
-;;; cider-apropos.el --- Apropos functionality for Clojure -*- lexical-binding: t -*-
-
-;; Copyright © 2014-2017 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)
-(require 'cider-util)
-(require 'subr-x)
-(require 'cider-compat)
-
-(require 'cider-client)
-(require 'cider-popup)
-(require 'nrepl-dict)
-
-(require 'clojure-mode)
-(require 'apropos)
-(require 'button)
-
-(defconst cider-apropos-buffer "*cider-apropos*")
-
-(push cider-apropos-buffer cider-ancillary-buffers)
-
-(defcustom cider-apropos-actions '(("display-doc" . cider-doc-lookup)
- ("find-def" . cider--find-var)
- ("lookup-on-grimoire" . cider-grimoire-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"))
-
-(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)
-
-(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))))
- (cider-propertize-region (list 'apropos-symbol name
- 'action 'cider-apropos-doc
- 'help-echo help)
- (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")))))
-
-(declare-function cider-mode "cider-mode")
-
-(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 t)
- (let ((inhibit-read-only t))
- (apropos-mode)
- (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
-;;
-;;; Code:
-(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
-\f
-;;;### (autoloads nil "cider" "cider.el" (22692 30287 0 0))
-;;; Generated autoloads from cider.el
-
-(autoload 'cider-version "cider" "\
-Display CIDER's version.
-
-\(fn)" t nil)
-
-(autoload 'cider-jack-in "cider" "\
-Start an nREPL server for the current project and connect to it.
-If PROMPT-PROJECT is t, then prompt for the project for which to
-start the server.
-If CLJS-TOO is non-nil, also start a ClojureScript REPL session with its
-own buffer.
-
-\(fn &optional PROMPT-PROJECT CLJS-TOO)" t nil)
-
-(autoload 'cider-jack-in-clojurescript "cider" "\
-Start an nREPL server and connect to it both Clojure and ClojureScript REPLs.
-If PROMPT-PROJECT is t, then prompt for the project for which to
-start the server.
-
-\(fn &optional PROMPT-PROJECT)" t nil)
-
-(autoload 'cider-connect "cider" "\
-Connect to an nREPL server identified by HOST and PORT.
-Create REPL buffer and start an nREPL client connection.
-
-When the optional param PROJECT-DIR is present, the connection
-gets associated with it.
-
-\(fn HOST PORT &optional PROJECT-DIR)" t nil)
-
-(eval-after-load 'clojure-mode '(progn (define-key clojure-mode-map (kbd "C-c M-j") #'cider-jack-in) (define-key clojure-mode-map (kbd "C-c M-J") #'cider-jack-in-clojurescript) (define-key clojure-mode-map (kbd "C-c M-c") #'cider-connect)))
-
-;;;***
-\f
-;;;### (autoloads nil "cider-apropos" "cider-apropos.el" (22692 30287
-;;;;;; 0 0))
-;;; Generated autoloads from cider-apropos.el
-
-(autoload 'cider-apropos "cider-apropos" "\
-Show all symbols whose names match QUERY, a regular expression.
-QUERY can also be a list of space-separated words (e.g. take while) which
-will be converted to a regular expression (like take.+while) automatically
-behind the scenes. The search may be limited to the namespace NS, and may
-optionally search doc strings (based on DOCS-P), include private vars
-\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P).
-
-\(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t nil)
-
-(autoload 'cider-apropos-documentation "cider-apropos" "\
-Shortcut for (cider-apropos <query> nil t).
-
-\(fn)" t nil)
-
-(autoload 'cider-apropos-select "cider-apropos" "\
-Similar to `cider-apropos', but presents the results in a completing read.
-
-Show all symbols whose names match QUERY, a regular expression.
-QUERY can also be a list of space-separated words (e.g. take while) which
-will be converted to a regular expression (like take.+while) automatically
-behind the scenes. The search may be limited to the namespace NS, and may
-optionally search doc strings (based on DOCS-P), include private vars
-\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P).
-
-\(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t nil)
-
-(autoload 'cider-apropos-documentation-select "cider-apropos" "\
-Shortcut for (cider-apropos-select <query> nil t).
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "cider-browse-ns" "cider-browse-ns.el" (22692
-;;;;;; 30287 0 0))
-;;; Generated autoloads from cider-browse-ns.el
-
-(autoload 'cider-browse-ns "cider-browse-ns" "\
-List all NAMESPACE's vars in BUFFER.
-
-\(fn NAMESPACE)" t nil)
-
-(autoload 'cider-browse-ns-all "cider-browse-ns" "\
-List all loaded namespaces in BUFFER.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "cider-classpath" "cider-classpath.el" (22692
-;;;;;; 30287 0 0))
-;;; Generated autoloads from cider-classpath.el
-
-(autoload 'cider-classpath "cider-classpath" "\
-List all classpath entries.
-
-\(fn)" t nil)
-
-(autoload 'cider-open-classpath-entry "cider-classpath" "\
-Open a classpath entry.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "cider-debug" "cider-debug.el" (22692 30287
-;;;;;; 0 0))
-;;; Generated autoloads from cider-debug.el
-
-(autoload 'cider-debug-defun-at-point "cider-debug" "\
-Instrument the \"top-level\" expression at point.
-If it is a defn, dispatch the instrumented definition. Otherwise,
-immediately evaluate the instrumented expression.
-
-While debugged code is being evaluated, the user is taken through the
-source code and displayed the value of various expressions. At each step,
-a number of keys will be prompted to the user.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "cider-grimoire" "cider-grimoire.el" (22692
-;;;;;; 30287 0 0))
-;;; Generated autoloads from cider-grimoire.el
-
-(autoload 'cider-grimoire-web "cider-grimoire" "\
-Open grimoire documentation in the default web browser.
-
-Prompts for the symbol to use, or uses the symbol at point, depending on
-the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
-opposite of what that option dictates.
-
-\(fn &optional ARG)" t nil)
-
-(autoload 'cider-grimoire "cider-grimoire" "\
-Open grimoire documentation in a popup buffer.
-
-Prompts for the symbol to use, or uses the symbol at point, depending on
-the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
-opposite of what that option dictates.
-
-\(fn &optional ARG)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "cider-inspector" "cider-inspector.el" (22692
-;;;;;; 30287 0 0))
-;;; Generated autoloads from cider-inspector.el
-
-(autoload 'cider-inspect-last-sexp "cider-inspector" "\
-Inspect the result of the the expression preceding point.
-
-\(fn)" t nil)
-
-(autoload 'cider-inspect-defun-at-point "cider-inspector" "\
-Inspect the result of the \"top-level\" expression at point.
-
-\(fn)" t nil)
-
-(autoload 'cider-inspect-last-result "cider-inspector" "\
-Inspect the most recent eval result.
-
-\(fn)" t nil)
-
-(autoload 'cider-inspect "cider-inspector" "\
-Inspect the result of the preceding sexp.
-
-With a prefix argument ARG it inspects the result of the \"top-level\" form.
-With a second prefix argument it prompts for an expression to eval and inspect.
-
-\(fn &optional ARG)" t nil)
-
-(autoload 'cider-inspect-expr "cider-inspector" "\
-Evaluate EXPR in NS and inspect its value.
-Interactively, EXPR is read from the minibuffer, and NS the
-current buffer's namespace.
-
-\(fn EXPR NS)" t nil)
-
-(define-obsolete-function-alias 'cider-inspect-read-and-inspect 'cider-inspect-expr "0.13.0")
-
-;;;***
-\f
-;;;### (autoloads nil "cider-macroexpansion" "cider-macroexpansion.el"
-;;;;;; (22692 30287 0 0))
-;;; Generated autoloads from cider-macroexpansion.el
-
-(autoload 'cider-macroexpand-1 "cider-macroexpansion" "\
-Invoke \\=`macroexpand-1\\=` on the expression preceding point.
-If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of
-\\=`macroexpand-1\\=`.
-
-\(fn &optional PREFIX)" t nil)
-
-(autoload 'cider-macroexpand-all "cider-macroexpansion" "\
-Invoke \\=`clojure.walk/macroexpand-all\\=` on the expression preceding point.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "cider-mode" "cider-mode.el" (22692 30287 0
-;;;;;; 0))
-;;; Generated autoloads from cider-mode.el
-
-(defvar cider-mode-line '(:eval (format " cider[%s]" (cider--modeline-info))) "\
-Mode line lighter for `cider-mode'.
-
-The value of this variable is a mode line template as in
-`mode-line-format'. See Info Node `(elisp)Mode Line Format' for
-details about mode line templates.
-
-Customize this variable to change how `cider-mode' displays its
-status in the mode line. The default value displays the current connection.
-Set this variable to nil to disable the mode line
-entirely.")
-
-(custom-autoload 'cider-mode-line "cider-mode" t)
-
-(eval-after-load 'clojure-mode '(easy-menu-define cider-clojure-mode-menu-open clojure-mode-map "Menu for Clojure mode.\n This is displayed in `clojure-mode' buffers, if `cider-mode' is not active." `("CIDER" :visible (not cider-mode) ["Start a REPL" cider-jack-in :help "Starts an nREPL server (with lein, boot, or maven) and connects a REPL to it."] ["Connect to a REPL" cider-connect :help "Connects to a REPL that's already running."] ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clojurescript :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL.\n Configure `cider-cljs-lein-repl', `cider-cljs-boot-repl' and `cider-cljs-gradle-repl' to change the ClojureScript REPL to use."] "--" ["View manual online" cider-view-manual])))
-
-(autoload 'cider-mode "cider-mode" "\
-Minor mode for REPL interaction from a Clojure buffer.
-
-\\{cider-mode-map}
-
-\(fn &optional ARG)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "cider-repl-history" "cider-repl-history.el"
-;;;;;; (22692 30287 0 0))
-;;; Generated autoloads from cider-repl-history.el
-
-(autoload 'cider-repl-history "cider-repl-history" "\
-Display items in the CIDER command history in another buffer.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "cider-scratch" "cider-scratch.el" (22692 30287
-;;;;;; 0 0))
-;;; Generated autoloads from cider-scratch.el
-
-(autoload 'cider-scratch "cider-scratch" "\
-Go to the scratch buffer named `cider-scratch-buffer-name'.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "cider-selector" "cider-selector.el" (22692
-;;;;;; 30287 0 0))
-;;; Generated autoloads from cider-selector.el
-
-(autoload 'cider-selector "cider-selector" "\
-Select a new buffer by type, indicated by a single character.
-The user is prompted for a single character indicating the method by
-which to choose a new buffer. The `?' character describes then
-available methods. OTHER-WINDOW provides an optional target.
-
-See `def-cider-selector-method' for defining new methods.
-
-\(fn &optional OTHER-WINDOW)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "cider-test" "cider-test.el" (22692 30287 0
-;;;;;; 0))
-;;; Generated autoloads from cider-test.el
-
-(defvar cider-auto-test-mode nil "\
-Non-nil if Cider-Auto-Test mode is enabled.
-See the `cider-auto-test-mode' command
-for a description of this minor mode.
-Setting this variable directly does not take effect;
-either customize it (see the info node `Easy Customization')
-or call the function `cider-auto-test-mode'.")
-
-(custom-autoload 'cider-auto-test-mode "cider-test" nil)
-
-(autoload 'cider-auto-test-mode "cider-test" "\
-Toggle automatic testing of Clojure files.
-
-When enabled this reruns tests every time a Clojure file is loaded.
-Only runs tests corresponding to the loaded file's namespace and does
-nothing if no tests are defined or if the file failed to load.
-
-\(fn &optional ARG)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "cider-util" "cider-util.el" (22692 30287 0
-;;;;;; 0))
-;;; Generated autoloads from cider-util.el
-
-(autoload 'cider-view-manual "cider-util" "\
-View the manual in your default browser.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil nil ("cider-client.el" "cider-common.el" "cider-compat.el"
-;;;;;; "cider-doc.el" "cider-eldoc.el" "cider-interaction.el" "cider-overlays.el"
-;;;;;; "cider-pkg.el" "cider-popup.el" "cider-repl.el" "cider-resolve.el"
-;;;;;; "cider-stacktrace.el" "nrepl-client.el" "nrepl-dict.el")
-;;;;;; (22692 30287 0 0))
-
-;;;***
-\f
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; End:
-;;; cider-autoloads.el ends here
+++ /dev/null
-;;; cider-browse-ns.el --- CIDER namespace browser
-
-;; Copyright © 2014-2017 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-interaction)
-(require 'cider-client)
-(require 'subr-x)
-(require 'cider-compat)
-(require 'cider-util)
-(require 'nrepl-dict)
-
-(defconst cider-browse-ns-buffer "*cider-ns-browser*")
-
-(push cider-browse-ns-buffer cider-ancillary-buffers)
-
-(defvar-local cider-browse-ns-current-ns 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)
- 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 buffer-read-only t)
- (setq-local electric-indent-chars nil)
- (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-str\" and \"macro\" indicates a macro form.
-Only \"arglists-str\" 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--list (buffer title items &optional ns noerase)
- "Reset contents of BUFFER.
-Display TITLE at the top and ITEMS are indented underneath.
-If NS is non-nil, it is added to each item as the
-`cider-browse-ns-current-ns' text property. If NOERASE is non-nil, the
-contents of the buffer are not reset before inserting TITLE and ITEMS."
- (with-current-buffer buffer
- (cider-browse-ns-mode)
- (let ((inhibit-read-only t))
- (unless noerase (erase-buffer))
- (goto-char (point-max))
- (insert (cider-propertize title 'ns) "\n")
- (dolist (item items)
- (insert (propertize (concat " " item "\n")
- 'cider-browse-ns-current-ns ns)))
- (goto-char (point-min)))))
-
-(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--items (namespace)
- "Return the items to show in the namespace browser of the given NAMESPACE.
-Each item consists of a ns-var and the first line of its docstring."
- (let* ((ns-vars-with-meta (cider-sync-request:ns-vars-with-meta namespace))
- (propertized-ns-vars (nrepl-dict-map #'cider-browse-ns--properties ns-vars-with-meta)))
- (mapcar (lambda (ns-var)
- (let* ((doc (nrepl-dict-get-in ns-vars-with-meta (list ns-var "doc")))
- ;; to avoid (read nil)
- ;; it prompts the user for a Lisp expression
- (doc (when doc (read doc)))
- (first-doc-line (cider-browse-ns--first-doc-line doc)))
- (concat ns-var " " (propertize first-doc-line 'font-lock-face 'font-lock-doc-face))))
- propertized-ns-vars)))
-
-;; 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 t)
- (cider-browse-ns--list (current-buffer)
- namespace
- (cider-browse-ns--items namespace))
- (setq-local cider-browse-ns-current-ns namespace)))
-
-;;;###autoload
-(defun cider-browse-ns-all ()
- "List all loaded namespaces in BUFFER."
- (interactive)
- (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t)
- (let ((names (cider-sync-request:ns-list)))
- (cider-browse-ns--list (current-buffer)
- "All loaded namespaces"
- (mapcar (lambda (name)
- (cider-browse-ns--properties name nil))
- names))
- (setq-local cider-browse-ns-current-ns nil))))
-
-(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 ((line (car (split-string (string-trim (thing-at-point 'line)) " "))))
- (if (string-match "\\." line)
- (list 'ns line)
- (list 'var (format "%s/%s"
- (or (get-text-property (point) 'cider-browse-ns-current-ns)
- cider-browse-ns-current-ns)
- line)))))
-
-(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))))
-
-(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-classpath.el --- Basic Java classpath browser
-
-;; Copyright © 2014-2017 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)
-(require 'cider-compat)
-
-(defvar cider-classpath-buffer "*cider-classpath*")
-
-(push cider-classpath-buffer cider-ancillary-buffers)
-
-(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 buffer-read-only t)
- (setq-local electric-indent-chars nil)
- (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)
- (cider-ensure-op-supported "classpath")
- (with-current-buffer (cider-popup-buffer cider-classpath-buffer t)
- (cider-classpath-list (current-buffer)
- (mapcar (lambda (name)
- (cider-classpath-properties name))
- (cider-sync-request:classpath)))))
-
-;;;###autoload
-(defun cider-open-classpath-entry ()
- "Open a classpath entry."
- (interactive)
- (cider-ensure-connected)
- (cider-ensure-op-supported "classpath")
- (when-let ((entry (completing-read "Classpath entries: " (cider-sync-request:classpath))))
- (find-file-other-window entry)))
-
-(provide 'cider-classpath)
-
-;;; cider-classpath.el ends here
+++ /dev/null
-;;; cider-client.el --- A layer of abstraction above the actual client code. -*- lexical-binding: t -*-
-
-;; Copyright © 2013-2017 Bozhidar Batsov
-;;
-;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.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 layer of abstraction above the actual client code.
-
-;;; Code:
-
-(require 'spinner)
-(require 'ewoc)
-(require 'nrepl-client)
-(require 'cider-common)
-(require 'cider-util)
-(require 'clojure-mode)
-
-(require 'subr-x)
-(require 'cider-compat)
-(require 'seq)
-
-;;; Connection Buffer Management
-
-(defcustom cider-request-dispatch 'dynamic
- "Controls the request dispatch mechanism when several connections are present.
-Dynamic dispatch tries to infer the connection based on the current project
-& currently visited file, while static dispatch simply uses the default
-connection.
-
-Project metadata is attached to connections when they are created with commands
-like `cider-jack-in' and `cider-connect'."
- :type '(choice (const :tag "dynamic" dynamic)
- (const :tag "static" static))
- :group 'cider
- :package-version '(cider . "0.10.0"))
-
-(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"))
-
-(defvar cider-connections nil
- "A list of connections.")
-
-(defun cider-connected-p ()
- "Return t if CIDER is currently connected, nil otherwise."
- (not (null (cider-connections))))
-
-(defun cider-ensure-connected ()
- "Ensure there is a cider connection present.
-An error is signaled in the absence of a connection."
- (unless (cider-connected-p)
- (user-error "`%s' needs an active nREPL connection" this-command)))
-
-(defsubst cider--in-connection-buffer-p ()
- "Return non-nil if current buffer is connected to a server."
- (and (derived-mode-p 'cider-repl-mode)
- (process-live-p
- (get-buffer-process (current-buffer)))))
-
-(defun cider-default-connection (&optional no-error)
- "The default (fallback) connection to use for nREPL interaction.
-When NO-ERROR is non-nil, don't throw an error when no connection has been
-found."
- (or (car (cider-connections))
- (unless no-error
- (error "No nREPL connection buffer"))))
-
-(defun cider-connections ()
- "Return the list of connection buffers.
-If the list is empty and buffer-local, return the global value."
- (or (setq cider-connections
- (seq-filter #'buffer-live-p cider-connections))
- (when (local-variable-p 'cider-connect)
- (kill-local-variable 'cider-connections)
- (seq-filter #'buffer-live-p cider-connections))))
-
-(defun cider-repl-buffers ()
- "Return the list of REPL buffers."
- (seq-filter
- (lambda (buffer)
- (with-current-buffer buffer (derived-mode-p 'cider-repl-mode)))
- (buffer-list)))
-
-(defun cider-make-connection-default (connection-buffer)
- "Make the nREPL CONNECTION-BUFFER the default connection.
-Moves CONNECTION-BUFFER to the front of variable `cider-connections'."
- (interactive (list (if (cider--in-connection-buffer-p)
- (current-buffer)
- (user-error "Not in a REPL buffer"))))
- ;; maintain the connection list in most recently used order
- (let ((buf (get-buffer connection-buffer)))
- (setq cider-connections
- (cons buf (delq buf cider-connections))))
- (cider--connections-refresh))
-
-(declare-function cider--close-buffer "cider-interaction")
-(defun cider--close-connection-buffer (conn-buffer)
- "Close CONN-BUFFER, removing it from variable `cider-connections'.
-Also close associated REPL and server buffers."
- (let ((buffer (get-buffer conn-buffer))
- (nrepl-messages-buffer (and nrepl-log-messages
- (nrepl-messages-buffer conn-buffer))))
- (setq cider-connections
- (delq buffer cider-connections))
- (when (buffer-live-p buffer)
- (with-current-buffer buffer
- (when spinner-current (spinner-stop))
- (when nrepl-tunnel-buffer
- (cider--close-buffer nrepl-tunnel-buffer)))
- ;; If this is the only (or last) REPL connected to its server, the
- ;; kill-process hook will kill the server.
- (cider--close-buffer buffer)
- (when nrepl-messages-buffer
- (kill-buffer nrepl-messages-buffer)))))
-
-\f
-;;; Current connection logic
-(defvar-local cider-repl-type "clj"
- "The type of this REPL buffer, usually either \"clj\" or \"cljs\".")
-
-(defun cider-find-connection-buffer-for-project-directory (&optional project-directory all-connections)
- "Return the most appropriate connection-buffer for the current project.
-
-By order of preference, this is any connection whose directory matches
-`clojure-project-dir', followed by any connection whose directory is nil,
-followed by any connection at all.
-
-If PROJECT-DIRECTORY is provided act on that project instead.
-
-Only return nil if variable `cider-connections' is empty,
-i.e there are no connections.
-
-If more than one connection satisfy a given level of preference, return the
-connection buffer closer to the start of variable `cider-connections'. This is
-usally the connection that was more recently created, but the order can be
-changed. For instance, the function `cider-make-connection-default' can be
-used to move a connection to the head of the list, so that it will take
-precedence over other connections associated with the same project.
-
-If ALL-CONNECTIONS is non-nil, the return value is a list and all matching
-connections are returned, instead of just the most recent."
- (when-let ((project-directory (or project-directory
- (clojure-project-dir (cider-current-dir))))
- (fn (if all-connections #'seq-filter #'seq-find)))
- (or (funcall fn (lambda (conn)
- (when-let ((conn-proj-dir (with-current-buffer conn
- nrepl-project-dir)))
- (equal (file-truename project-directory)
- (file-truename conn-proj-dir))))
- cider-connections)
- (funcall fn (lambda (conn)
- (with-current-buffer conn
- (not nrepl-project-dir)))
- cider-connections)
- (if all-connections
- cider-connections
- (car cider-connections)))))
-
-(defun cider-read-connection (prompt)
- "Completing read for connections using PROMPT."
- (get-buffer (completing-read prompt (mapcar #'buffer-name (cider-connections)))))
-
-(defun cider-assoc-project-with-connection (&optional project connection)
- "Associate a Clojure PROJECT with an nREPL CONNECTION.
-
-Useful for connections created using `cider-connect', as for them
-such a link cannot be established automatically."
- (interactive)
- (cider-ensure-connected)
- (let ((conn-buf (or connection (cider-read-connection "Connection: ")))
- (project-dir (or project (read-directory-name "Project directory: " (clojure-project-dir)))))
- (when conn-buf
- (with-current-buffer conn-buf
- (setq nrepl-project-dir project-dir)))))
-
-(defun cider-assoc-buffer-with-connection ()
- "Associate the current buffer with a connection.
-
-Useful for connections created using `cider-connect', as for them
-such a link cannot be established automatically."
- (interactive)
- (cider-ensure-connected)
- (let ((conn (cider-read-connection "Connection: ")))
- (when conn
- (setq-local cider-connections (list conn)))))
-
-(defun cider-toggle-buffer-connection ()
- "Toggles the current buffer's connection between Clojure and ClojureScript."
- (interactive)
- (cider-ensure-connected)
- (let ((other-conn (cider-other-connection)))
- (if other-conn
- (setq-local cider-connections (list other-conn))
- (user-error "No other connection available"))))
-
-(defun cider-clear-buffer-local-connection ()
- "Remove association between the current buffer and a connection."
- (interactive)
- (cider-ensure-connected)
- (kill-local-variable 'cider-connections))
-
-(defun cider-connection-type-for-buffer ()
- "Return the matching connection type (clj or cljs) for the current buffer."
- (cond
- ((derived-mode-p 'clojurescript-mode) "cljs")
- ((derived-mode-p 'clojure-mode) "clj")
- (cider-repl-type)
- (t "clj")))
-
-(defun cider-toggle-request-dispatch ()
- "Toggles the value of `cider-request-dispatch' between static and dynamic.
-
-Handy when you're using dynamic dispatch, but you want to quickly force all
-evaluation commands to use a particular connection."
- (interactive)
- (let ((new-value (if (eq cider-request-dispatch 'static) 'dynamic 'static)))
- (setq cider-request-dispatch new-value)
- (message "Toggled CIDER request dispatch to %s." new-value)))
-
-(defun cider-current-connection (&optional type)
- "Return the REPL buffer relevant for the current Clojure source buffer.
-A REPL is relevant if its `nrepl-project-dir' is compatible with the
-current directory (see `cider-find-connection-buffer-for-project-directory').
-
-If TYPE is provided, it is either \"clj\" or \"cljs\", and only a
-connection of that type is returned. If no connections of that TYPE exist,
-return nil.
-
-If TYPE is nil, then connections whose type matches the current file
-extension are given preference, but if none exist, any connection is
-returned. In this case, only return nil if there are no active connections
-at all."
- ;; If TYPE was specified, we only return that type (or nil). OW, we prefer
- ;; that TYPE, but ultimately allow any type.
- (cl-labels ((right-type-p
- (c)
- (when (or (not type)
- (and (buffer-live-p c)
- (with-current-buffer c (equal cider-repl-type type))))
- c)))
- (let ((connections (cider-connections)))
- (cond
- ((not connections) nil)
- ;; if you're in a REPL buffer, it's the connection buffer
- ((and (derived-mode-p 'cider-repl-mode) (right-type-p (current-buffer))))
- ((eq cider-request-dispatch 'static) (car connections))
- ((= 1 (length connections)) (right-type-p (car connections)))
- (t (let ((project-connections (cider-find-connection-buffer-for-project-directory
- nil :all-connections))
- (guessed-type (or type (cider-connection-type-for-buffer))))
- ;; So we have multiple connections. Look for the connection type we
- ;; want, prioritizing the current project.
- (or (seq-find (lambda (conn)
- (equal (cider--connection-type conn) guessed-type))
- project-connections)
- (seq-find (lambda (conn)
- (equal (cider--connection-type conn) guessed-type))
- connections)
- (right-type-p (car project-connections))
- (right-type-p (car connections)))))))))
-
-(defun cider-other-connection (&optional connection)
- "Return the first connection of another type than CONNECTION.
-Only return connections in the same project or nil.
-CONNECTION defaults to `cider-current-connection'."
- (when-let ((connection (or connection (cider-current-connection)))
- (connection-type (cider--connection-type connection)))
- (cider-current-connection (pcase connection-type
- (`"clj" "cljs")
- (_ "clj")))))
-
-(defvar cider--has-warned-about-bad-repl-type nil)
-
-(defun cider--guess-cljs-connection ()
- "Hacky way to find a ClojureScript REPL.
-DO NOT USE THIS FUNCTION.
-It was written only to be used in `cider-map-connections', as a workaround
-to a still-undetermined bug in the state-stracker backend."
- (when-let ((project-connections (cider-find-connection-buffer-for-project-directory
- nil :all-connections))
- (cljs-conn
- ;; So we have multiple connections. Look for the connection type we
- ;; want, prioritizing the current project.
- (or (seq-find (lambda (c) (string-match "\\bCLJS\\b" (buffer-name c)))
- project-connections)
- (seq-find (lambda (c) (string-match "\\bCLJS\\b" (buffer-name c)))
- (cider-connections)))))
- (unless cider--has-warned-about-bad-repl-type
- (setq cider--has-warned-about-bad-repl-type t)
- (read-key
- (concat "The ClojureScript REPL seems to be is misbehaving."
- (substitute-command-keys
- "\nWe have applied a workaround, but please also file a bug report with `\\[cider-report-bug]'.")
- "\nPress any key to continue.")))
- cljs-conn))
-
-(defun cider-map-connections (function which &optional any-mode)
- "Call FUNCTION once for each appropriate connection.
-The function is called with one argument, the connection buffer.
-The appropriate connections are found by inspecting the current buffer. If
-the buffer is associated with a .cljc or .cljx file, BODY will be executed
-multiple times.
-
-WHICH is one of the following keywords identifying which connections to map
-over.
- :any - Act the connection whose type matches the current buffer.
- :clj - Like :any, but signal a `user-error' in `clojurescript-mode' or if
- there is no Clojure connection (use this for commands only
- supported in Clojure).
- :cljs - Like :clj, but demands a ClojureScript connection instead.
- :both - In `clojurec-mode' or `clojurex-mode' act on both connections,
- otherwise function like :any. Obviously, this option might run
- FUNCTION twice.
-
-If ANY-MODE is non-nil, :clj and :cljs don't signal errors due to being in
-the wrong major mode (they still signal if the desired connection type
-doesn't exist). Use this for commands that only apply to a specific
-connection but can be invoked from any buffer (like `cider-refresh')."
- (cl-labels ((err (msg) (user-error (concat "`%s' " msg) this-command)))
- ;; :both in a clj or cljs buffer just means :any.
- (let* ((which (if (and (eq which :both)
- (not (cider--cljc-or-cljx-buffer-p)))
- :any
- which))
- (curr
- (pcase which
- (`:any (let ((type (cider-connection-type-for-buffer)))
- (or (cider-current-connection type)
- (when (equal type "cljs")
- (cider--guess-cljs-connection))
- (err (substitute-command-keys
- (format "needs a Clojure%s REPL.\nIf you don't know what that means, you probably need to jack-in (%s)."
- (if (equal type "cljs") "Script" "")
- (if (equal type "cljs") "`\\[cider-jack-in-clojurescript]'" "`\\[cider-jack-in]'")))))))
- (`:both (or (cider-current-connection)
- (err "needs an active REPL connection")))
- (`:clj (cond ((and (not any-mode)
- (derived-mode-p 'clojurescript-mode))
- (err "doesn't support ClojureScript"))
- ((cider-current-connection "clj"))
- ((err "needs a Clojure REPL"))))
- (`:cljs (cond ((and (not any-mode)
- (eq major-mode 'clojure-mode))
- (err "doesn't support Clojure"))
- ((cider-current-connection "cljs"))
- ((err "needs a ClojureScript REPL")))))))
- (funcall function curr)
- (when (eq which :both)
- (when-let ((other-connection (cider-other-connection curr)))
- (funcall function other-connection))))))
-
-\f
-;;; Connection Browser
-(defvar cider-connections-buffer-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "d" #'cider-connections-make-default)
- (define-key map "g" #'cider-connection-browser)
- (define-key map "k" #'cider-connections-close-connection)
- (define-key map (kbd "RET") #'cider-connections-goto-connection)
- (define-key map "?" #'describe-mode)
- (define-key map "h" #'describe-mode)
- map))
-
-(declare-function cider-popup-buffer-mode "cider-popup")
-(define-derived-mode cider-connections-buffer-mode cider-popup-buffer-mode
- "CIDER Connections"
- "CIDER Connections Buffer Mode.
-\\{cider-connections-buffer-mode-map}
-\\{cider-popup-buffer-mode-map}"
- (when cider-special-mode-truncate-lines
- (setq-local truncate-lines t)))
-
-(defvar cider--connection-ewoc)
-(defconst cider--connection-browser-buffer-name "*cider-connections*")
-
-(defun cider-connection-browser ()
- "Open a browser buffer for nREPL connections."
- (interactive)
- (if-let ((buffer (get-buffer cider--connection-browser-buffer-name)))
- (progn
- (cider--connections-refresh-buffer buffer)
- (unless (get-buffer-window buffer)
- (select-window (display-buffer buffer))))
- (cider--setup-connection-browser)))
-
-(defun cider--connections-refresh ()
- "Refresh the connections buffer, if the buffer exists.
-The connections buffer is determined by
-`cider--connection-browser-buffer-name'"
- (when-let ((buffer (get-buffer cider--connection-browser-buffer-name)))
- (cider--connections-refresh-buffer buffer)))
-
-(add-hook 'nrepl-disconnected-hook #'cider--connections-refresh)
-
-(defun cider--connections-refresh-buffer (buffer)
- "Refresh the connections BUFFER."
- (cider--update-connections-display
- (buffer-local-value 'cider--connection-ewoc buffer)
- cider-connections))
-
-(defun cider--setup-connection-browser ()
- "Create a browser buffer for nREPL connections."
- (with-current-buffer (get-buffer-create cider--connection-browser-buffer-name)
- (let ((ewoc (ewoc-create
- 'cider--connection-pp
- " REPL Host Port Project Type\n")))
- (setq-local cider--connection-ewoc ewoc)
- (cider--update-connections-display ewoc cider-connections)
- (setq buffer-read-only t)
- (cider-connections-buffer-mode)
- (display-buffer (current-buffer)))))
-
-(defun cider-client-name-repl-type (type)
- "Return a human-readable name for a connection TYPE.
-TYPE can be any of the possible values of `cider-repl-type'."
- (pcase type
- ("clj" "Clojure")
- ("cljs" "ClojureScript")
- (_ "Unknown")))
-
-(defun cider-project-name (project-dir)
- "Extract the project name from PROJECT-DIR."
- (if (and project-dir (not (equal project-dir "")))
- (file-name-nondirectory (directory-file-name project-dir))
- "-"))
-
-(defun cider--connection-pp (connection)
- "Print an nREPL CONNECTION to the current buffer."
- (let* ((buffer-read-only nil)
- (buffer (get-buffer connection))
- (project-name (cider-project-name (buffer-local-value 'nrepl-project-dir buffer)))
- (repl-type (cider-client-name-repl-type (buffer-local-value 'cider-repl-type buffer)))
- (endpoint (buffer-local-value 'nrepl-endpoint buffer)))
- (insert
- (format "%s %-30s %-16s %5s %-16s %s"
- (if (equal connection (car cider-connections)) "*" " ")
- (buffer-name connection)
- (car endpoint)
- (prin1-to-string (cadr endpoint))
- project-name
- repl-type))))
-
-(defun cider--update-connections-display (ewoc connections)
- "Update the connections EWOC to show CONNECTIONS."
- (ewoc-filter ewoc (lambda (n) (member n connections)))
- (let ((existing))
- (ewoc-map (lambda (n) (setq existing (cons n existing))) ewoc)
- (let ((added (seq-difference connections existing)))
- (mapc (apply-partially 'ewoc-enter-last ewoc) added)
- (save-excursion (ewoc-refresh ewoc)))))
-
-(defun cider--ewoc-apply-at-point (f)
- "Apply function F to the ewoc node at point.
-F is a function of two arguments, the ewoc and the data at point."
- (let* ((ewoc cider--connection-ewoc)
- (node (and ewoc (ewoc-locate ewoc))))
- (when node
- (funcall f ewoc (ewoc-data node)))))
-
-(defun cider-connections-make-default ()
- "Make default the connection at point in the connection browser."
- (interactive)
- (save-excursion
- (cider--ewoc-apply-at-point #'cider--connections-make-default)))
-
-(defun cider--connections-make-default (ewoc data)
- "Make the connection in EWOC specified by DATA default.
-Refreshes EWOC."
- (interactive)
- (cider-make-connection-default data)
- (ewoc-refresh ewoc))
-
-(defun cider-connections-close-connection ()
- "Close connection at point in the connection browser."
- (interactive)
- (cider--ewoc-apply-at-point #'cider--connections-close-connection))
-
-(defun cider--connections-close-connection (ewoc data)
- "Close the connection in EWOC specified by DATA."
- (cider--close-connection-buffer (get-buffer data))
- (cider--update-connections-display ewoc cider-connections))
-
-(defun cider-connections-goto-connection ()
- "Goto connection at point in the connection browser."
- (interactive)
- (cider--ewoc-apply-at-point #'cider--connections-goto-connection))
-
-(defun cider--connections-goto-connection (_ewoc data)
- "Goto the REPL for the connection in _EWOC specified by DATA."
- (when (buffer-live-p data)
- (select-window (display-buffer data))))
-
-
-(defun cider-display-connected-message ()
- "Message displayed on successful connection."
- (message
- (concat "Connected."
- (if cider-connection-message-fn
- (format " %s" (funcall cider-connection-message-fn))
- ""))))
-
-;; TODO: Replace direct usage of such hooks with CIDER hooks,
-;; that are connection type independent
-(add-hook 'nrepl-connected-hook 'cider-display-connected-message)
-
-\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"))
-
-(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-handler (eval-buffer original-callback)
- "Return a response handler to stop the spinner and call ORIGINAL-CALLBACK.
-EVAL-BUFFER is the buffer where the spinner was started."
- (lambda (response)
- ;; 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))))
- (funcall original-callback response)))
-
-\f
-;;; Evaluation helpers
-(defun cider-ns-form-p (form)
- "Check if FORM is an ns form."
- (string-match-p "^[[:space:]]*\(ns\\([[:space:]]*$\\|[[:space:]]+\\)" form))
-
-(defvar-local cider-buffer-ns nil
- "Current Clojure namespace of some buffer.
-
-Useful for special buffers (e.g. REPL, doc buffers) that have to
-keep track of a namespace.
-
-This should never be set in Clojure buffers, as there the namespace
-should be extracted from the buffer's ns form.")
-
-(defun cider-current-ns (&optional no-default)
- "Return the current ns.
-The ns is extracted from the ns form for Clojure buffers and from
-`cider-buffer-ns' for all other buffers. If it's missing, use the current
-REPL's ns, otherwise fall back to \"user\".
-
-When NO-DEFAULT is non-nil, it will return nil instead of \"user\"."
- (or cider-buffer-ns
- (clojure-find-ns)
- (when-let ((repl-buf (cider-current-connection)))
- (buffer-local-value 'cider-buffer-ns repl-buf))
- (if no-default nil "user")))
-
-(defun cider-expected-ns (&optional path)
- "Return the namespace string matching PATH, or nil if not found.
-
-PATH is expected to be an absolute file path.
-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 (or path (file-truename (buffer-file-name))))
- (relpath (thread-last (cider-sync-request:classpath)
- (seq-map
- (lambda (cp)
- (when (string-prefix-p cp path)
- (substring path (length cp)))))
- (seq-filter #'identity)
- (seq-sort (lambda (a b)
- (< (length a) (length b))))
- (car))))
- (if relpath
- (thread-last (substring relpath 1) ; remove leading /
- (file-name-sans-extension)
- (replace-regexp-in-string "/" ".")
- (replace-regexp-in-string "_" "-"))
- (clojure-expected-ns path)))
- (clojure-expected-ns path)))
-
-(defun cider-nrepl-op-supported-p (op)
- "Check whether the current connection supports the nREPL middleware OP."
- (nrepl-op-supported-p op (cider-current-connection)))
-
-(defvar cider-version)
-(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\". Please, install (or update) cider-nrepl %s and restart CIDER" this-command op (upcase cider-version))))
-
-(defun cider-nrepl-send-request (request callback &optional connection)
- "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."
- (nrepl-send-request request callback (or connection (cider-current-connection))))
-
-(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-connection))
- abort-on-input))
-
-(defun cider-nrepl-send-unhandled-request (request)
- "Send REQUEST to the nREPL server and ignore any responses.
-Immediately mark the REQUEST as done.
-Return the id of the sent message."
- (let* ((conn (cider-current-connection))
- (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)
- "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."
- (let ((connection (cider-current-connection)))
- (nrepl-request:eval input
- (if cider-show-eval-spinner
- (cider-eval-spinner-handler connection callback)
- callback)
- connection
- ns line column additional-params)
- (cider-spinner-start connection)))
-
-(defun cider-nrepl-sync-request:eval (input &optional ns)
- "Send the INPUT to the nREPL server synchronously.
-If NS is non-nil, include it in the request."
- (nrepl-sync-request:eval
- input
- (cider-current-connection)
- ns))
-
-(defcustom cider-pprint-fn 'pprint
- "Sets the function to use when pretty-printing evaluation results.
-
-The value must be one of the following symbols:
-
- `pprint' - to use \\=`clojure.pprint/pprint\\=`
-
- `fipp' - to use the Fast Idiomatic Pretty Printer, approximately 5-10x
- faster than \\=`clojure.core/pprint\\=` (this is the default)
-
- `puget' - to use Puget, which provides canonical serialization of data on
- top of fipp, but at a slight performance cost
-
-Alternatively, can be the namespace-qualified name of a Clojure function of
-one argument. If the function cannot be resolved, an exception will be
-thrown.
-
-The function is assumed to respect the contract of \\=`clojure.pprint/pprint\\=`
-with respect to the bound values of \\=`*print-length*\\=`, \\=`*print-level*\\=`,
-\\=`*print-meta*\\=`, and \\=`clojure.pprint/*print-right-margin*\\=`."
- :type '(choice (const pprint)
- (const fipp)
- (const puget)
- string)
- :group 'cider
- :package-version '(cider . "0.11.0"))
-
-(defun cider--pprint-fn ()
- "Return the value to send in the pprint-fn slot of messages."
- (pcase cider-pprint-fn
- (`pprint "clojure.pprint/pprint")
- (`fipp "cider.nrepl.middleware.pprint/fipp-pprint")
- (`puget "cider.nrepl.middleware.pprint/puget-pprint")
- (_ cider-pprint-fn)))
-
-(defun cider--nrepl-pprint-request-plist (right-margin &optional pprint-fn)
- "Plist to be appended to an eval request to make it use pprint.
-PPRINT-FN is the name of the Clojure function to use.
-RIGHT-MARGIN specifies the maximum column-width of the pretty-printed
-result, and is included in the request if non-nil."
- (append (list "pprint" "true"
- "pprint-fn" (or pprint-fn (cider--pprint-fn)))
- (and right-margin (list "print-right-margin" right-margin))))
-
-(defun cider-tooling-eval (input callback &optional ns)
- "Send the request INPUT and register the CALLBACK as the response handler.
-NS specifies the namespace in which to evaluate the request."
- ;; namespace forms are always evaluated in the "user" namespace
- (nrepl-request:eval input
- callback
- (cider-current-connection)
- ns nil nil nil t ; tooling
- ))
-
-(defalias 'cider-current-repl-buffer #'cider-current-connection
- "The current REPL buffer.
-Return the REPL buffer given by `cider-current-connection'.")
-
-(declare-function cider-interrupt-handler "cider-interaction")
-(defun cider-interrupt ()
- "Interrupt any pending evaluations."
- (interactive)
- (with-current-buffer (cider-current-connection)
- (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-connection))))))
-
-(defun cider-current-session ()
- "Return the eval nREPL session id of the current connection."
- (cider-session-for-connection (cider-current-connection)))
-
-(defun cider-session-for-connection (connection)
- (with-current-buffer connection
- nrepl-session))
-
-(defun cider-current-messages-buffer ()
- "The nREPL messages buffer, matching the current connection."
- (nrepl-messages-buffer (cider-current-connection)))
-
-(defun cider-current-tooling-session ()
- "Return the tooling nREPL session id of the current connection."
- (with-current-buffer (cider-current-connection)
- nrepl-tooling-session))
-
-(defun cider--var-choice (var-info)
- "Prompt to choose from among multiple VAR-INFO candidates, if required.
-This is needed only when the symbol queried is an unqualified host platform
-method, and multiple classes have a so-named member. If VAR-INFO does not
-contain a `candidates' key, it is returned as is."
- (let ((candidates (nrepl-dict-get var-info "candidates")))
- (if candidates
- (let* ((classes (nrepl-dict-keys candidates))
- (choice (completing-read "Member in class: " classes nil t))
- (info (nrepl-dict-get candidates choice)))
- info)
- var-info)))
-
-(defun cider-var-info (var &optional all)
- "Return VAR's info as an alist with list cdrs.
-When multiple matching vars are returned you'll be prompted to select one,
-unless ALL is truthy."
- (when (and var (not (string= var "")))
- (let ((var-info (cider-sync-request:info var)))
- (if all var-info (cider--var-choice var-info)))))
-
-(defun cider-member-info (class member)
- "Return the CLASS MEMBER's info as an alist with list cdrs."
- (when (and class member)
- (cider-sync-request:info nil class member)))
-
-(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)))
-
-(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")
- (cider-ensure-op-supported "info")
- (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))))
-
-\f
-;;; Requests
-
-(declare-function cider-load-file-handler "cider-interaction")
-(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-connection'.
-If CALLBACK is nil, use `cider-load-file-handler'."
- (cider-nrepl-send-request (list "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" "^clojure.tools.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"))
- "filter-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 (list "op" "classpath")
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "classpath")))
-
-(defun cider-sync-request:complete (str context)
- "Return a list of completions for STR using nREPL's \"complete\" op.
-CONTEXT represents a completion context for compliment."
- (when-let ((dict (thread-first (list "op" "complete"
- "ns" (cider-current-ns)
- "symbol" str
- "context" context)
- (cider-nrepl-send-sync-request nil 'abort-on-input))))
- (nrepl-dict-get dict "completions")))
-
-(defun cider-sync-request:info (symbol &optional class member)
- "Send \"info\" op with parameters SYMBOL or CLASS and MEMBER."
- (let ((var-info (thread-first `("op" "info"
- "ns" ,(cider-current-ns)
- ,@(when symbol (list "symbol" symbol))
- ,@(when class (list "class" class))
- ,@(when member (list "member" member)))
- (cider-nrepl-send-sync-request))))
- (if (member "no-info" (nrepl-dict-get var-info "status"))
- nil
- var-info)))
-
-(defun cider-sync-request:eldoc (symbol &optional class member)
- "Send \"eldoc\" op with parameters SYMBOL or CLASS and MEMBER."
- (when-let ((eldoc (thread-first `("op" "eldoc"
- "ns" ,(cider-current-ns)
- ,@(when symbol (list "symbol" symbol))
- ,@(when class (list "class" class))
- ,@(when member (list "member" member)))
- (cider-nrepl-send-sync-request nil 'abort-on-input))))
- (if (member "no-eldoc" (nrepl-dict-get eldoc "status"))
- nil
- eldoc)))
-
-(defun cider-sync-request:ns-list ()
- "Get a list of the available namespaces."
- (thread-first (list "op" "ns-list"
- "filter-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 (list "op" "ns-vars"
- "ns" ns)
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "ns-vars")))
-
-(defun cider-sync-request:ns-vars-with-meta (ns)
- "Get a map of the vars in NS to its metadata information."
- (thread-first (list "op" "ns-vars-with-meta"
- "ns" ns)
- (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 (list "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 (list "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."
- (thread-first (list "op" "resources-list")
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "resources-list")))
-
-(defun cider-sync-request:format-code (code)
- "Perform nREPL \"format-code\" op with CODE."
- (thread-first (list "op" "format-code"
- "code" code)
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "formatted-code")))
-
-(defun cider-sync-request:format-edn (edn right-margin)
- "Perform \"format-edn\" op with EDN and RIGHT-MARGIN."
- (let* ((response (thread-first (list "op" "format-edn"
- "edn" edn)
- (append (cider--nrepl-pprint-request-plist right-margin))
- (cider-nrepl-send-sync-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")))
-
-\f
-;;; Connection info
-(defun cider--java-version ()
- "Retrieve the underlying connection's Java version."
- (with-current-buffer (cider-current-connection "clj")
- (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-connection "clj")
- (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-connection "clj")
- (when nrepl-versions
- (thread-first nrepl-versions
- (nrepl-dict-get "nrepl")
- (nrepl-dict-get "version-string")))))
-
-(defun cider--connection-info (connection-buffer)
- "Return info about CONNECTION-BUFFER.
-
-Info contains project name, current REPL namespace, host:port
-endpoint and Clojure version."
- (with-current-buffer connection-buffer
- (format "%s%s@%s:%s (Java %s, Clojure %s, nREPL %s)"
- (upcase (concat cider-repl-type " "))
- (or (cider--project-name nrepl-project-dir) "<no project>")
- (car nrepl-endpoint)
- (cadr nrepl-endpoint)
- (cider--java-version)
- (cider--clojure-version)
- (cider--nrepl-version))))
-
-(defun cider--connection-properties (conn-buffer)
- "Extract the essential properties of CONN-BUFFER."
- (with-current-buffer conn-buffer
- (list
- :type cider-repl-type
- :host (car nrepl-endpoint)
- :port (cadr nrepl-endpoint)
- :project-dir nrepl-project-dir)))
-
-(defun cider--connection-type (conn-buffer)
- "Get CONN-BUFFER's type.
-
-Return value matches `cider-repl-type'."
- (plist-get (cider--connection-properties conn-buffer) :type))
-
-(defun cider--connection-host (conn-buffer)
- "Get CONN-BUFFER's host."
- (plist-get (cider--connection-properties conn-buffer) :host))
-
-(defun cider--connection-port (conn-buffer)
- "Get CONN-BUFFER's port."
- (plist-get (cider--connection-properties conn-buffer) :port))
-
-(defun cider--connection-project-dir (conn-buffer)
- "Get CONN-BUFFER's project dir."
- (plist-get (cider--connection-properties conn-buffer) :project-dir))
-
-(defun cider-display-connection-info (&optional show-default)
- "Display information about the current connection.
-
-With a prefix argument SHOW-DEFAULT it will display info about the
-default connection."
- (interactive "P")
- (message "%s" (cider--connection-info (if show-default
- (cider-default-connection)
- (cider-current-connection)))))
-
-(defun cider-rotate-default-connection ()
- "Rotate and display the default nREPL connection."
- (interactive)
- (cider-ensure-connected)
- (setq cider-connections
- (append (cdr cider-connections)
- (list (car cider-connections))))
- (message "Default nREPL connection: %s"
- (cider--connection-info (car cider-connections))))
-
-(defun cider-replicate-connection (&optional conn)
- "Establish a new connection based on an existing connection.
-The new connection will use the same host and port.
-If CONN is not provided the user will be prompted to select a connection."
- (interactive)
- (let* ((conn (or conn (cider-read-connection "Select connection to replicate: ")))
- (host (cider--connection-host conn))
- (port (cider--connection-port conn))
- (project-dir (cider--connection-project-dir conn)))
- (cider-connect host port project-dir)))
-
-(defun cider-extract-designation-from-current-repl-buffer ()
- "Extract the designation from the cider repl buffer name."
- (let ((repl-buffer-name (buffer-name (cider-current-repl-buffer)))
- (template (split-string nrepl-repl-buffer-name-template "%s")))
- (string-match (format "^%s\\(.*\\)%s"
- (regexp-quote (concat (car template) nrepl-buffer-name-separator))
- (regexp-quote (cadr template)))
- repl-buffer-name)
- (or (match-string 1 repl-buffer-name) "<no designation>")))
-
-(defun cider-change-buffers-designation (designation)
- "Change the DESIGNATION in cider buffer names.
-Buffer names changed are cider-repl and nrepl-server."
- (interactive (list (read-string (format "Change CIDER buffer designation from '%s': "
- (cider-extract-designation-from-current-repl-buffer)))))
- (cider-ensure-connected)
- (let ((new-repl-buffer-name (nrepl-format-buffer-name-template
- nrepl-repl-buffer-name-template designation)))
- (with-current-buffer (cider-current-repl-buffer)
- (rename-buffer new-repl-buffer-name)
- (when nrepl-server-buffer
- (let ((new-server-buffer-name (nrepl-format-buffer-name-template
- nrepl-server-buffer-name-template designation)))
- (with-current-buffer nrepl-server-buffer
- (rename-buffer new-server-buffer-name)))))
- (message "CIDER buffer designation changed to: %s" designation)))
-
-(provide 'cider-client)
-
-;;; cider-client.el ends here
+++ /dev/null
-;;; cider-common.el --- Common use functions -*- lexical-binding: t; -*-
-
-;; Copyright © 2015-2017 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 'cider-compat)
-(require 'nrepl-dict)
-(require 'cider-util)
-(require 'tramp)
-
-(defcustom cider-prompt-for-symbol t
- "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 is used to invert 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)))
-
-(declare-function cider-read-from-minibuffer "cider-interaction")
-
-(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-jump-to "cider-interaction")
-
-(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-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)
- (let ((vec (tramp-dissect-file-name name)))
- (tramp-make-tramp-file-name (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-host vec)
- nil)))))
-
-(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 (concat (cider-tramp-prefix buffer) name)))
- (if (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))
-
-(defvar cider-from-nrepl-filename-function
- (with-no-warnings
- (if (eq system-type 'cygwin)
- #'cygwin-convert-file-name-from-windows
- #'identity))
- "Function to translate nREPL namestrings to Emacs filenames.")
-
-(defcustom cider-prefer-local-resources nil
- "Prefer local resources to remote (tramp) ones when both are available."
- :type 'boolean
- :group 'cider)
-
-(defun cider--file-path (path)
- "Return PATH's local or tramp path using `cider-prefer-local-resources'.
-If no local or remote file exists, return nil."
- (let* ((local-path (funcall cider-from-nrepl-filename-function path))
- (tramp-path (and local-path (cider--client-tramp-filename local-path))))
- (cond ((equal local-path "") "")
- ((and cider-prefer-local-resources (file-exists-p local-path))
- local-path)
- ((and tramp-path (file-exists-p tramp-path))
- tramp-path)
- ((and local-path (file-exists-p local-path))
- local-path))))
-
-(declare-function archive-extract "arc-mode")
-(declare-function archive-zip-extract "arc-mode")
-
-(defun cider-find-file (url)
- "Return a buffer visiting the file URL if it exists, or nil otherwise.
-If URL has a scheme prefix, it must represent a fully-qualified file path
-or an entry within a zip/jar archive. If 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)))
- (or (find-buffer-visiting name)
- (if (tramp-tramp-file-p path)
- (progn
- ;; Use emacs built in archiving
- (find-file path)
- (goto-char (point-min))
- ;; Make sure the file path is followed by a newline to
- ;; prevent eg. clj matching cljs.
- (search-forward (concat entry "\n"))
- ;; moves up to matching line
- (forward-line -1)
- (archive-extract)
- (current-buffer))
- ;; Use external zip program to just extract the single file
- (with-current-buffer (generate-new-buffer
- (file-name-nondirectory entry))
- (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-compat.el --- Functions from newer Emacs versions for compatibility -*- lexical-binding: t -*-
-
-;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
-;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba 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:
-
-;; Pretty much everything here's copied from subr-x for compatibility with
-;; Emacs 24.4.
-
-;;; Code:
-
-(eval-and-compile
-
- (unless (fboundp 'internal--thread-argument)
- (defmacro internal--thread-argument (first? &rest forms)
- "Internal implementation for `thread-first' and `thread-last'.
-When Argument FIRST? is non-nil argument is threaded first, else
-last. FORMS are the expressions to be threaded."
- (pcase forms
- (`(,x (,f . ,args) . ,rest)
- `(internal--thread-argument
- ,first? ,(if first? `(,f ,x ,@args) `(,f ,@args ,x)) ,@rest))
- (`(,x ,f . ,rest) `(internal--thread-argument ,first? (,f ,x) ,@rest))
- (_ (car forms)))))
-
- (unless (fboundp 'thread-first)
- (defmacro thread-first (&rest forms)
- "Thread FORMS elements as the first argument of their successor.
-Example:
- (thread-first
- 5
- (+ 20)
- (/ 25)
- -
- (+ 40))
-Is equivalent to:
- (+ (- (/ (+ 5 20) 25)) 40)
-Note how the single `-' got converted into a list before
-threading."
- (declare (indent 1)
- (debug (form &rest [&or symbolp (sexp &rest form)])))
- `(internal--thread-argument t ,@forms)))
-
- (unless (fboundp 'thread-last)
- (defmacro thread-last (&rest forms)
- "Thread FORMS elements as the last argument of their successor.
-Example:
- (thread-last
- 5
- (+ 20)
- (/ 25)
- -
- (+ 40))
-Is equivalent to:
- (+ 40 (- (/ 25 (+ 20 5))))
-Note how the single `-' got converted into a list before
-threading."
- (declare (indent 1) (debug thread-first))
- `(internal--thread-argument nil ,@forms))))
-
-
-(eval-and-compile
-
- (unless (fboundp 'internal--listify)
-
- (defsubst internal--listify (elt)
- "Wrap ELT in a list if it is not one."
- (if (not (listp elt))
- (list elt)
- elt)))
-
- (unless (fboundp 'internal--check-binding)
-
- (defsubst internal--check-binding (binding)
- "Check BINDING is properly formed."
- (when (> (length binding) 2)
- (signal
- 'error
- (cons "`let' bindings can have only one value-form" binding)))
- binding))
-
- (unless (fboundp 'internal--build-binding-value-form)
-
- (defsubst internal--build-binding-value-form (binding prev-var)
- "Build the conditional value form for BINDING using PREV-VAR."
- `(,(car binding) (and ,prev-var ,(cadr binding)))))
-
- (unless (fboundp 'internal--build-binding)
-
- (defun internal--build-binding (binding prev-var)
- "Check and build a single BINDING with PREV-VAR."
- (thread-first
- binding
- internal--listify
- internal--check-binding
- (internal--build-binding-value-form prev-var))))
-
- (unless (fboundp 'internal--build-bindings)
-
- (defun internal--build-bindings (bindings)
- "Check and build conditional value forms for BINDINGS."
- (let ((prev-var t))
- (mapcar (lambda (binding)
- (let ((binding (internal--build-binding binding prev-var)))
- (setq prev-var (car binding))
- binding))
- bindings)))))
-
-(eval-and-compile
-
- (unless (fboundp 'if-let)
- (defmacro if-let (bindings then &rest else)
- "Process BINDINGS and if all values are non-nil eval THEN, else ELSE.
-Argument BINDINGS is a list of tuples whose car is a symbol to be
-bound and (optionally) used in THEN, and its cadr is a sexp to be
-evalled to set symbol's value. In the special case you only want
-to bind a single value, BINDINGS can just be a plain tuple."
- (declare (indent 2)
- (debug ([&or (&rest (symbolp form)) (symbolp form)] form body)))
- (when (and (<= (length bindings) 2)
- (not (listp (car bindings))))
- ;; Adjust the single binding case
- (setq bindings (list bindings)))
- `(let* ,(internal--build-bindings bindings)
- (if ,(car (internal--listify (car (last bindings))))
- ,then
- ,@else))))
-
- (unless (fboundp 'when-let)
- (defmacro when-let (bindings &rest body)
- "Process BINDINGS and if all values are non-nil eval BODY.
-Argument BINDINGS is a list of tuples whose car is a symbol to be
-bound and (optionally) used in BODY, and its cadr is a sexp to be
-evalled to set symbol's value. In the special case you only want
-to bind a single value, BINDINGS can just be a plain tuple."
- (declare (indent 1) (debug if-let))
- (list 'if-let bindings (macroexp-progn body)))))
-
-(provide 'cider-compat)
-;;; cider-compat.el ends here
+++ /dev/null
-;;; cider-debug.el --- CIDER interaction with the cider.debug nREPL middleware -*- lexical-binding: t; -*-
-
-;; Copyright © 2015-2017 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 'nrepl-dict)
-(require 'nrepl-client) ; `nrepl--mark-id-completed'
-(require 'cider-interaction)
-(require 'cider-client)
-(require 'cider-util)
-(require 'cider-inspector)
-(require 'cider-browse-ns)
-(require 'cider-common)
-(require 'subr-x)
-(require 'cider-compat)
-(require 'seq)
-(require 'spinner)
-
-\f
-;;; Customization
-(defgroup cider-debug nil
- "Presentation and behaviour 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."
- :group 'cider-debug
- :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."
- :group 'cider-debug
- :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."
- :group 'cider-debug
- :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)."
- :group 'cider-debug
- :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))
- :group 'cider-debug
- :package-version '(cider . "0.10.0"))
-
-(defcustom cider-debug-use-overlays t
- "Whether to higlight 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))
- :group 'cider-debug
- :package-version '(cider . "0.9.1"))
-
-(defcustom cider-debug-print-level 10
- "The print-level for values displayed by the debugger.
-This variable must be set before starting the repl connection."
- :type '(choice (const :tag "No limit" nil)
- (integer :tag "Max depth" 10))
- :group 'cider-debug
- :package-version '(cider . "0.10.0"))
-
-(defcustom cider-debug-print-length 10
- "The print-length for values displayed by the debugger.
-This variable must be set before starting the repl connection."
- :type '(choice (const :tag "No limit" nil)
- (integer :tag "Max depth" 10))
- :group 'cider-debug
- :package-version '(cider . "0.10.0"))
-
-\f
-;;; Implementation
-(defun cider-browse-instrumented-defs ()
- "List all instrumented definitions."
- (interactive)
- (if-let ((all (thread-first (cider-nrepl-send-sync-request (list "op" "debug-instrumented-defs"))
- (nrepl-dict-get "list"))))
- (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (dolist (list all)
- (let* ((ns (car list))
- (ns-vars-with-meta (cider-sync-request:ns-vars-with-meta ns))
- ;; seq of metadata maps of the instrumented vars
- (instrumented-meta (mapcar (apply-partially #'nrepl-dict-get ns-vars-with-meta)
- (cdr list))))
- (cider-browse-ns--list (current-buffer) ns
- (seq-mapn #'cider-browse-ns--properties
- (cdr list)
- instrumented-meta)
-
- ns 'noerase)
- (goto-char (point-max))
- (insert "\n"))))
- (goto-char (point-min)))
- (message "No currently instrumented definitions")))
-
-(defun cider--debug-response-handler (response)
- "Handles RESPONSE from the cider.debug middleware."
- (nrepl-dbind-response response (status id causes)
- (when (member "enlighten" status)
- (cider--handle-enlighten response))
- (when (or (member "eval-error" status)
- (member "stack" status))
- ;; TODO: Make the error buffer a bit friendlier when we're just printing
- ;; the stack.
- (cider--render-stacktrace-causes causes))
- (when (member "need-debug-input" status)
- (cider--handle-debug response))
- (when (member "done" status)
- (nrepl--mark-id-completed id))))
-
-(defun cider--debug-init-connection ()
- "Initialize a connection with the cider.debug middleware."
- (cider-nrepl-send-request
- (append '("op" "init-debugger")
- (when cider-debug-print-level
- (list "print-level" cider-debug-print-level))
- (when cider-debug-print-length
- (list "print-length" cider-debug-print-length)))
- #'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)
- "Place an overlay at point displaying VALUE."
- (when cider-debug-use-overlays
- ;; This is cosmetic, let's ensure it doesn't break the session no matter what.
- (ignore-errors
- ;; Result
- (cider--make-result-overlay (cider-font-lock-as-clojure value)
- :where (point-marker)
- :type 'debug-result
- 'before-string cider--fringe-arrow-string)
- ;; Code
- (cider--make-overlay (save-excursion (clojure-backward-logical-sexp 1) (point))
- (point) 'debug-code
- 'face 'cider-debug-code-overlay-face
- ;; Higher priority than `show-paren'.
- 'priority 2000))))
-
-\f
-;;; Minor mode
-(defvar-local cider--debug-mode-commands-dict nil
- "An nrepl-dict from keys to debug commands.
-Autogenerated by `cider--turn-on-debug-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
- :group 'cider-debug
- :package-version '(cider . "0.10.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-prompt (command-dict)
- "Return prompt to display for COMMAND-DICT."
- ;; Force `default' face, otherwise the overlay "inherits" the face of the text
- ;; after it.
- (format (propertize "%s\n" 'face 'default)
- (string-join
- (nrepl-dict-map (lambda (char cmd)
- (when-let ((pos (cl-search char cmd)))
- (put-text-property pos (1+ pos) 'face 'cider-debug-prompt-face cmd))
- cmd)
- command-dict)
- " ")))
-
-(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)
- (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 non-stop")
- (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)
-
-(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'."
- nil " DEBUG" '()
- (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")))
- ;; Set the keymap.
- (nrepl-dict-map (lambda (char cmd)
- (unless (string= char "h") ; `here' needs a special command.
- (define-key cider--debug-mode-map char #'cider-debug-mode-send-reply))
- (when (string= char "o")
- (define-key cider--debug-mode-map (upcase char) #'cider-debug-mode-send-reply)))
- input-type)
- (setq cider--debug-mode-commands-dict input-type)
- ;; 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-commands-dict 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-connection)))))
- (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)))))
-
-;;; Bind the `:here` command to both h and H, because it behaves differently if
-;;; invoked with an uppercase letter.
-(define-key cider--debug-mode-map "h" #'cider-debug-move-here)
-(define-key cider--debug-mode-map "H" #'cider-debug-move-here)
-
-(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 non-stop" (cider-debug-mode-send-reply ":continue") :keys "c"]
- ["Move out of sexp" (cider-debug-mode-send-reply ":out") :keys "o"]
- ["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 value" (cider-debug-mode-send-reply ":inspect")]
- ["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 true 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 ":" (nrepl-dict-get cider--debug-mode-commands-dict
- (downcase (string last-command-event))))))
- 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
- (list "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))
- (cider--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-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))))
- ;; 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)))
- (move-to-column 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 tools.nrepl version is older than 0.2.11"))
- (save-excursion
- (cider--debug-move-point coor)
- (point-marker)))))))))
-
-(defun cider--handle-debug (response)
- "Handle debugging notification.
-RESPONSE is a message received from the nrepl describing the input
-needed. It is expected to contain at least \"key\", \"input-type\", and
-\"prompt\", and possibly other entries depending on the input-type."
- (nrepl-dbind-response response (debug-value key input-type prompt inspect)
- (condition-case-unless-debug e
- (progn
- (pcase input-type
- ("expression" (cider-debug-mode-send-reply
- (condition-case nil
- (cider-read-from-minibuffer
- (or prompt "Expression: "))
- (quit "nil"))
- key))
- ((pred sequencep)
- (let* ((marker (cider--debug-find-source-position response 'create-if-needed)))
- (pop-to-buffer (marker-buffer marker))
- (goto-char marker))
- ;; The overlay code relies on window boundaries, but point could have been
- ;; moved outside the window by some other code. Redisplay here to ensure the
- ;; visible window includes point.
- (redisplay)
- ;; Remove overlays AFTER redisplaying! Otherwise there's a visible
- ;; flicker even if we immediately recreate the overlays.
- (cider--debug-remove-overlays)
- (when cider-debug-use-overlays
- (cider--debug-display-result-overlay debug-value))
- (setq cider--debug-mode-response response)
- (cider--debug-mode 1)))
- (when inspect
- (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."
- (interactive (list (cider--uppercase-command-p)))
- (unless cider--debug-mode
- (user-error "`cider-debug-move-here' only makes sense during a debug session"))
- (let ((here (point)))
- (nrepl-dbind-response cider--debug-mode-response (line column)
- (if (and line column (buffer-file-name))
- (progn ;; Get to the proper line & column in the file
- (forward-line (1- (- line (line-number-at-pos))))
- (move-to-column column))
- (beginning-of-defun))
- ;; Is HERE inside the sexp being debugged?
- (when (or (< here (point))
- (save-excursion
- (forward-sexp 1)
- (> here (point))))
- (user-error "Point is outside the sexp being debugged"))
- ;; Move forward untill start of sexp.
- (comment-normalize-vars)
- (comment-forward (point-max))
- ;; Find the coordinate and send it.
- (cider-debug-mode-send-reply
- (format "{:response :here, :coord %s :force? %s}"
- (cider--debug-find-coordinates-for-point here)
- (if force "true" "false"))))))
-
-\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-2017 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 'subr-x)
-(require 'cider-compat)
-(require 'cider-util)
-(require 'cider-popup)
-(require 'cider-client)
-(require 'cider-grimoire)
-(require 'nrepl-dict)
-(require 'org-table)
-(require 'button)
-(require 'easymenu)
-
-\f
-;;; Variables
-
-(defgroup cider-doc nil
- "Documentation for CIDER."
- :prefix "cider-doc-"
- :group 'cider)
-
-
-(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 "r") #'cider-grimoire)
- (define-key cider-doc-map (kbd "C-r") #'cider-grimoire)
- (define-key cider-doc-map (kbd "w") #'cider-grimoire-web)
- (define-key cider-doc-map (kbd "C-w") #'cider-grimoire-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]
- ["Grimoire" cider-grimoire]
- ["Grimoire in browser" cider-grimoire-web]
- ["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.")
-
-(defadvice enable-theme (after cider-docview-adapt-to-theme activate)
- "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-grimoire)
- (define-key map "G" #'cider-docview-grimoire-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 Grimoire" cider-docview-grimoire]
- ["Look up in Grimoire (browser)" cider-docview-grimoire-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)
- (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))
-
-(declare-function cider-find-file "cider-common")
-(declare-function cider-jump-to "cider-interaction")
-
-(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-grimoire-lookup "cider-grimoire")
-
-(defun cider-docview-grimoire ()
- "Return the grimoire documentation for `cider-docview-symbol'."
- (interactive)
- (if cider-buffer-ns
- (cider-grimoire-lookup cider-docview-symbol)
- (error "%s cannot be looked up on Grimoire" cider-docview-symbol)))
-
-(declare-function cider-grimoire-web-lookup "cider-grimoire")
-
-(defun cider-docview-grimoire-web ()
- "Open the grimoire documentation for `cider-docview-symbol' in a web browser."
- (interactive)
- (if cider-buffer-ns
- (cider-grimoire-web-lookup cider-docview-symbol)
- (error "%s cannot be looked up on Grimoire" cider-docview-symbol)))
-
-(defconst cider-doc-buffer "*cider-doc*")
-(add-to-list 'cider-ancillary-buffers cider-doc-buffer)
-
-(defun cider-create-doc-buffer (symbol)
- "Populates *cider-doc* with the documentation for SYMBOL."
- (when-let ((info (cider-var-info symbol)))
- (cider-docview-render (cider-make-popup-buffer cider-doc-buffer) symbol info)))
-
-(defun cider-doc-lookup (symbol)
- "Look up documentation for SYMBOL."
- (if-let ((buffer (cider-create-doc-buffer symbol)))
- (cider-popup-buffer-display buffer t)
- (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."
- (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'."
- (if (string-match "\\`file:\\(.*\\)" file-with-protocol)
- (let ((file (match-string 1 file-with-protocol))
- (proj-dir (clojure-project-dir)))
- (if (and proj-dir
- (file-in-directory-p file proj-dir))
- (file-relative-name file proj-dir)
- file))
- file-with-protocol))
-
-(defun cider-docview-render-info (buffer info)
- "Emit into BUFFER formatted INFO for the Clojure or Java symbol."
- (let* ((ns (nrepl-dict-get info "ns"))
- (name (nrepl-dict-get info "name"))
- (added (nrepl-dict-get info "added"))
- (depr (nrepl-dict-get info "deprecated"))
- (macro (nrepl-dict-get info "macro"))
- (special (nrepl-dict-get info "special-form"))
- (forms (nrepl-dict-get info "forms-str"))
- (args (nrepl-dict-get info "arglists-str"))
- (doc (or (nrepl-dict-get info "doc")
- "Not documented."))
- (url (nrepl-dict-get info "url"))
- (class (nrepl-dict-get info "class"))
- (member (nrepl-dict-get info "member"))
- (javadoc (nrepl-dict-get info "javadoc"))
- (super (nrepl-dict-get info "super"))
- (ifaces (nrepl-dict-get info "interfaces"))
- (spec (nrepl-dict-get info "spec"))
- (clj-name (if ns (concat ns "/" name) name))
- (java-name (if member (concat class "/" member) class))
- (see-also (nrepl-dict-get info "see-also")))
- (cider--help-setup-xref (list #'cider-doc-lookup (format "%s/%s" ns name)) nil buffer)
- (with-current-buffer buffer
- (cl-flet ((emit (text &optional face)
- (insert (if face
- (propertize text 'font-lock-face face)
- text)
- "\n")))
- (emit (if class java-name clj-name) 'font-lock-function-name-face)
- (when super
- (emit (concat " Extends: " (cider-font-lock-as 'java-mode super))))
- (when ifaces
- (emit (concat "Implements: " (cider-font-lock-as 'java-mode (car ifaces))))
- (dolist (iface (cdr ifaces))
- (emit (concat " "(cider-font-lock-as 'java-mode iface)))))
- (when (or super ifaces)
- (insert "\n"))
- (when (or forms args)
- (insert " ")
- (save-excursion
- (emit (cider-font-lock-as-clojure
- ;; All `defn's use ([...] [...]), but some special forms use
- ;; (...). We only remove the parentheses on the former.
- (replace-regexp-in-string "\\`(\\(\\[.*\\]\\))\\'" "\\1"
- (or forms args)))))
- ;; It normally doesn't happen, but it's technically conceivable for
- ;; the args string to contain unbalanced sexps, so `ignore-errors'.
- (ignore-errors
- (forward-sexp 1)
- (while (not (looking-at "$"))
- (insert "\n")
- (forward-sexp 1)))
- (forward-line 1))
- (when (or special macro)
- (emit (if special "Special Form" "Macro") 'font-lock-variable-name-face))
- (when added
- (emit (concat "Added in " added) 'font-lock-comment-face))
- (when depr
- (emit (concat "Deprecated in " depr) 'font-lock-keyword-face))
- (if class
- (cider-docview-render-java-doc (current-buffer) doc)
- (emit (concat " " doc)))
- (when url
- (insert "\n Please see ")
- (insert-text-button url
- 'url url
- 'follow-link t
- 'action (lambda (x)
- (browse-url (button-get x 'url))))
- (insert "\n"))
- (when javadoc
- (insert "\n\nFor additional documentation, see the ")
- (insert-text-button "Javadoc"
- 'url javadoc
- 'follow-link t
- 'action (lambda (x)
- (browse-url (button-get x 'url))))
- (insert ".\n"))
- (insert "\n")
- (when spec
- (emit "Spec: " 'font-lock-function-name-face)
- (mapc (lambda (s) (insert s "\n")) spec)
- (insert "\n"))
- (if cider-docview-file
- (progn
- (insert (propertize (if class java-name clj-name)
- 'font-lock-face 'font-lock-function-name-face)
- " is defined in ")
- (insert-text-button (cider--abbreviate-file-protocol cider-docview-file)
- 'follow-link t
- 'action (lambda (_x)
- (cider-docview-source)))
- (insert "."))
- (insert "Definition location unavailable."))
- (when see-also
- (insert "\n\n Also see: ")
- (mapc (lambda (ns-sym)
- (let* ((ns-sym-split (split-string ns-sym "/"))
- (see-also-ns (car ns-sym-split))
- (see-also-sym (cadr ns-sym-split))
- ;; if the var belongs to the same namespace,
- ;; we omit the namespace to save some screen space
- (symbol (if (equal ns see-also-ns) see-also-sym ns-sym)))
- (insert-button symbol
- 'type 'help-xref
- 'help-function (apply-partially #'cider-doc-lookup symbol)))
- (insert " "))
- see-also))
- (cider--doc-make-xrefs)
- (let ((beg (point-min))
- (end (point-max)))
- (nrepl-dict-map (lambda (k v)
- (put-text-property beg end k v))
- info)))
- (current-buffer))))
-
-(declare-function cider-set-buffer-ns "cider-mode")
-(defun cider-docview-render (buffer symbol info)
- "Emit into BUFFER formatted documentation for SYMBOL's INFO."
- (with-current-buffer buffer
- (let ((javadoc (nrepl-dict-get info "javadoc"))
- (file (nrepl-dict-get info "file"))
- (line (nrepl-dict-get info "line"))
- (ns (nrepl-dict-get info "ns"))
- (inhibit-read-only t))
- (cider-docview-mode)
-
- (cider-set-buffer-ns ns)
- (setq-local cider-docview-symbol symbol)
- (setq-local cider-docview-javadoc-url javadoc)
- (setq-local cider-docview-file file)
- (setq-local cider-docview-line line)
-
- (remove-overlays)
- (cider-docview-render-info buffer info)
-
- (goto-char (point-min))
- (current-buffer))))
-
-
-(provide 'cider-doc)
-
-;;; cider-doc.el ends here
+++ /dev/null
-;;; cider-eldoc.el --- eldoc support for Clojure -*- lexical-binding: t -*-
-
-;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
-;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; 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 'subr-x)
-(require 'cider-compat)
-(require 'cider-util)
-(require 'nrepl-dict)
-
-(require 'seq)
-
-(require 'eldoc)
-
-(defvar cider-extra-eldoc-commands '("yas-expand")
- "Extra commands to be added to eldoc's safe commands list.")
-
-(defcustom cider-eldoc-max-num-sexps-to-skip 30
- "The maximum number of sexps to skip while searching the beginning of current sexp."
- :type 'integer
- :group 'cider
- :package-version '(cider . "0.10.1"))
-
-(defvar-local cider-eldoc-last-symbol nil
- "The eldoc information for the last symbol we checked.")
-
-(defcustom cider-eldoc-ns-function #'identity
- "A function that returns a ns string to be used by eldoc.
-Takes one argument, a namespace name.
-For convenience, some functions are already provided for this purpose:
-`cider-abbreviate-ns', and `cider-last-ns-segment'."
- :type '(choice (const :tag "Full namespace" identity)
- (const :tag "Abbreviated namespace" cider-abbreviate-ns)
- (const :tag "Last name in namespace" cider-last-ns-segment)
- (function :tag "Custom function"))
- :group 'cider
- :package-version '(cider . "0.13.0"))
-
-(defcustom cider-eldoc-max-class-names-to-display 3
- "The maximum number of classes to display in an eldoc string.
-An eldoc string for Java interop forms can have a number of classes prefixed to
-it, when the form belongs to more than 1 class. When, not nil we only display
-the names of first `cider-eldoc-max-class-names-to-display' classes and add
-a \"& x more\" suffix. Otherwise, all the classes are displayed."
- :type 'integer
- :safe #'integerp
- :group 'cider
- :package-version '(cider . "0.13.0"))
-
-(defcustom cider-eldoc-display-for-symbol-at-point t
- "When non-nil, display eldoc for symbol at point if available.
-So in (map inc ...) when the cursor is over inc its eldoc would be
-displayed. When nil, always display eldoc for first symbol of the sexp."
- :type 'boolean
- :safe 'booleanp
- :group 'cider
- :package-version '(cider . "0.13.0"))
-
-(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 and THING.
-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 pos eldoc-info)
- "Return the formatted eldoc string for a variable.
-THING is the variable name. POS will always be 0 here.
-ELDOC-INFO is a p-list containing the eldoc information."
- (let* ((ns (lax-plist-get eldoc-info "ns"))
- (symbol (lax-plist-get eldoc-info "symbol"))
- (docstring (lax-plist-get eldoc-info "docstring"))
- (formatted-var (cider-eldoc-format-thing ns symbol thing 'var)))
- (when docstring
- (cider-eldoc-format-sym-doc formatted-var ns docstring))))
-
-(defun cider-eldoc-format-function (thing pos eldoc-info)
- "Return the formatted eldoc string for a function.
-THING is the function name. POS is the argument-index of the functions
-arglists. ELDOC-INFO is a p-list containing the eldoc information."
- (let ((ns (lax-plist-get eldoc-info "ns"))
- (symbol (lax-plist-get eldoc-info "symbol"))
- (arglists (lax-plist-get eldoc-info "arglists")))
- (format "%s: %s"
- (cider-eldoc-format-thing ns symbol thing 'fn)
- (cider-eldoc-format-arglist arglists pos))))
-
-(defun cider-highlight-args (arglist pos)
- "Format the the function ARGLIST for eldoc.
-POS is the index of the currently highlighted argument."
- (let* ((rest-pos (cider--find-rest-args-position arglist))
- (i 0))
- (mapconcat
- (lambda (arg)
- (let ((argstr (format "%s" arg)))
- (if (string= arg "&")
- argstr
- (prog1
- (if (or (= (1+ i) pos)
- (and rest-pos
- (> (1+ i) rest-pos)
- (> pos rest-pos)))
- (propertize argstr 'face
- 'eldoc-highlight-function-argument)
- argstr)
- (setq i (1+ i)))))) arglist " ")))
-
-(defun cider--find-rest-args-position (arglist)
- "Find the position of & in the ARGLIST vector."
- (seq-position arglist "&"))
-
-(defun cider-highlight-arglist (arglist pos)
- "Format the ARGLIST for eldoc.
-POS is the index of the argument to highlight."
- (concat "[" (cider-highlight-args arglist pos) "]"))
-
-(defun cider-eldoc-format-arglist (arglist pos)
- "Format all the ARGLIST for eldoc.
-POS is the index of current argument."
- (concat "("
- (mapconcat (lambda (args) (cider-highlight-arglist args pos))
- arglist
- " ")
- ")"))
-
-(defun cider-eldoc-beginning-of-sexp ()
- "Move to the beginning of current sexp.
-
-Return the number of nested sexp the point was over or after. Return nil
-if the maximum number of sexps to skip is exceeded."
- (let ((parse-sexp-ignore-comments t)
- (num-skipped-sexps 0))
- (condition-case _
- (progn
- ;; First account for the case the point is directly over a
- ;; beginning of a nested sexp.
- (condition-case _
- (let ((p (point)))
- (forward-sexp -1)
- (forward-sexp 1)
- (when (< (point) p)
- (setq num-skipped-sexps 1)))
- (error))
- (while
- (let ((p (point)))
- (forward-sexp -1)
- (when (< (point) p)
- (setq num-skipped-sexps
- (unless (and cider-eldoc-max-num-sexps-to-skip
- (>= num-skipped-sexps
- cider-eldoc-max-num-sexps-to-skip))
- ;; Without the above guard,
- ;; `cider-eldoc-beginning-of-sexp' could traverse the
- ;; whole buffer when the point is not within a
- ;; list. This behavior is problematic especially with
- ;; a buffer containing a large number of
- ;; non-expressions like a REPL buffer.
- (1+ num-skipped-sexps)))))))
- (error))
- num-skipped-sexps))
-
-(defun cider-eldoc-thing-type (eldoc-info)
- "Return the type of the thing being displayed by eldoc.
-It can be a function or var now."
- (pcase (lax-plist-get eldoc-info "type")
- ("function" 'fn)
- ("variable" 'var)))
-
-(defun cider-eldoc-info-at-point ()
- "Return eldoc info at point.
-First go to the beginning of the sexp and check if the eldoc is to be
-considered (i.e sexp is a method call) and not a map or vector literal.
-Then go back to the point and return its eldoc."
- (save-excursion
- (unless (cider-in-comment-p)
- (let* ((current-point (point)))
- (cider-eldoc-beginning-of-sexp)
- (unless (member (or (char-before (point)) 0) '(?\" ?\{ ?\[))
- (goto-char current-point)
- (when-let (eldoc-info (cider-eldoc-info
- (cider--eldoc-remove-dot (cider-symbol-at-point))))
- (list "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))))
- (list "eldoc-info" eldoc-info
- "thing" (cider-symbol-at-point)
- "pos" argument-index))))))
-
-(defun cider-eldoc-info-in-current-sexp ()
- "Return eldoc information from the sexp.
-If `cider-eldoc-display-for-symbol-at-poin' is non-nil and
-the symbol at point has a valid eldoc available, return that.
-Otherwise return the eldoc of the first symbol of the sexp."
- (or (when cider-eldoc-display-for-symbol-at-point
- (cider-eldoc-info-at-point))
- (cider-eldoc-info-at-sexp-beginning)))
-
-(defun cider-eldoc--convert-ns-keywords (thing)
- "Convert THING values that match ns macro keywords to function names."
- (pcase thing
- (":import" "clojure.core/import")
- (":refer-clojure" "clojure.core/refer-clojure")
- (":use" "clojure.core/use")
- (":refer" "clojure.core/refer")
- (_ thing)))
-
-(defun cider-eldoc-info (thing)
- "Return the info for THING.
-This includes the arglist and ns and symbol name (if available)."
- (let ((thing (cider-eldoc--convert-ns-keywords thing)))
- (when (and (cider-nrepl-op-supported-p "eldoc")
- thing
- ;; ignore empty strings
- (not (string= thing ""))
- ;; ignore strings
- (not (string-prefix-p "\"" thing))
- ;; ignore regular expressions
- (not (string-prefix-p "#" thing))
- ;; ignore chars
- (not (string-prefix-p "\\" thing))
- ;; ignore numbers
- (not (string-match-p "^[0-9]" thing)))
- ;; check if we can used the cached eldoc info
- (cond
- ;; handle keywords for map access
- ((string-prefix-p ":" thing) (list "symbol" thing
- "type" "function"
- "arglists" '(("map") ("map" "not-found"))))
- ;; handle Classname. by displaying the eldoc for new
- ((string-match-p "^[A-Z].+\\.$" thing) (list "symbol" thing
- "type" "function"
- "arglists" '(("args*"))))
- ;; generic case
- (t (if (equal thing (car cider-eldoc-last-symbol))
- (cadr cider-eldoc-last-symbol)
- (when-let ((eldoc-info (cider-sync-request:eldoc thing)))
- (let* ((arglists (nrepl-dict-get eldoc-info "eldoc"))
- (docstring (nrepl-dict-get eldoc-info "docstring"))
- (type (nrepl-dict-get eldoc-info "type"))
- (ns (nrepl-dict-get eldoc-info "ns"))
- (class (nrepl-dict-get eldoc-info "class"))
- (name (nrepl-dict-get eldoc-info "name"))
- (member (nrepl-dict-get eldoc-info "member"))
- (ns-or-class (if (and ns (not (string= ns "")))
- ns
- class))
- (name-or-member (if (and name (not (string= name "")))
- name
- (format ".%s" member)))
- (eldoc-plist (list "ns" ns-or-class
- "symbol" name-or-member
- "arglists" arglists
- "docstring" docstring
- "type" type)))
- ;; 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 ()
- "Backend function for eldoc to show argument list in the echo area."
- (when (and (cider-connected-p)
- ;; don't clobber an error message in the minibuffer
- (not (member last-command '(next-error previous-error)))
- ;; don't try to provide eldoc in EDN buffers
- (not (cider--eldoc-edn-file-p buffer-file-name)))
- (let* ((sexp-eldoc-info (cider-eldoc-info-in-current-sexp))
- (eldoc-info (lax-plist-get sexp-eldoc-info "eldoc-info"))
- (pos (lax-plist-get sexp-eldoc-info "pos"))
- (thing (lax-plist-get sexp-eldoc-info "thing")))
- (when eldoc-info
- (if (equal (cider-eldoc-thing-type eldoc-info) 'fn)
- (cider-eldoc-format-function thing pos eldoc-info)
- (cider-eldoc-format-variable 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."
- (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-grimoire.el --- Grimoire integration -*- lexical-binding: t -*-
-
-;; Copyright © 2014-2017 Bozhidar Batsov and CIDER contributors
-;;
-;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.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 few commands for Grimoire documentation lookup.
-
-;;; Code:
-
-(require 'cider-client)
-(require 'cider-common)
-(require 'subr-x)
-(require 'cider-compat)
-(require 'cider-popup)
-
-(require 'nrepl-dict)
-
-(require 'url-vars)
-
-(defconst cider-grimoire-url "http://conj.io/")
-
-(defconst cider-grimoire-buffer "*cider-grimoire*")
-
-(defun cider-grimoire-replace-special (name)
- "Convert the dashes in NAME to a grimoire friendly format."
- (thread-last name
- (replace-regexp-in-string "\\?" "_QMARK_")
- (replace-regexp-in-string "\\." "_DOT_")
- (replace-regexp-in-string "\\/" "_SLASH_")
- (replace-regexp-in-string "\\(\\`_\\)\\|\\(_\\'\\)" "")))
-
-(defun cider-grimoire-url (name ns)
- "Generate a grimoire search v0 url from NAME, NS."
- (let ((base-url cider-grimoire-url))
- (when (and name ns)
- (concat base-url "search/v0/" ns "/" (cider-grimoire-replace-special name) "/"))))
-
-(defun cider-grimoire-web-lookup (symbol)
- "Open the grimoire documentation for SYMBOL in a web browser."
- (if-let ((var-info (cider-var-info symbol)))
- (let ((name (nrepl-dict-get var-info "name"))
- (ns (nrepl-dict-get var-info "ns")))
- (browse-url (cider-grimoire-url name ns)))
- (error "Symbol %s not resolved" symbol)))
-
-;;;###autoload
-(defun cider-grimoire-web (&optional arg)
- "Open grimoire 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)
- "Grimoire doc for"
- #'cider-grimoire-web-lookup))
-
-(defun cider-create-grimoire-buffer (content)
- "Create a new grimoire buffer with CONTENT."
- (with-current-buffer (cider-popup-buffer cider-grimoire-buffer t)
- (read-only-mode -1)
- (insert content)
- (read-only-mode +1)
- (goto-char (point-min))
- (current-buffer)))
-
-(defun cider-grimoire-lookup (symbol)
- "Look up the grimoire documentation for SYMBOL."
- (if-let ((var-info (cider-var-info symbol)))
- (let ((name (nrepl-dict-get var-info "name"))
- (ns (nrepl-dict-get var-info "ns"))
- (url-request-method "GET")
- (url-request-extra-headers `(("Content-Type" . "text/plain"))))
- (url-retrieve (cider-grimoire-url name ns)
- (lambda (_status)
- ;; we need to strip the http header
- (goto-char (point-min))
- (re-search-forward "^$")
- (delete-region (point-min) (point))
- (delete-blank-lines)
- ;; and create a new buffer with whatever is left
- (pop-to-buffer (cider-create-grimoire-buffer (buffer-string))))))
- (error "Symbol %s not resolved" symbol)))
-
-;;;###autoload
-(defun cider-grimoire (&optional arg)
- "Open grimoire documentation in a popup buffer.
-
-Prompts for the symbol to use, or uses the symbol at point, depending on
-the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
-opposite of what that option dictates."
- (interactive "P")
- (when (derived-mode-p 'clojurescript-mode)
- (user-error "`cider-grimoire' doesn't support ClojureScript"))
- (funcall (cider-prompt-for-symbol-function arg)
- "Grimoire doc for"
- #'cider-grimoire-lookup))
-
-(provide 'cider-grimoire)
-
-;;; cider-grimoire.el ends here
+++ /dev/null
-;;; cider-inspector.el --- Object inspector -*- lexical-binding: t -*-
-
-;; Copyright © 2013-2017 Vital Reactor, LLC
-;; Copyright © 2014-2017 Bozhidar Batsov and CIDER contributors
-
-;; Author: Ian Eslick <ianNOSPAMvitalreactor.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.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:
-
-;; Clojure object inspector inspired by SLIME.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'seq)
-(require 'cider-interaction)
-
-;; ===================================
-;; Inspector Key Map and Derived Mode
-;; ===================================
-
-(defconst cider-inspector-buffer "*cider-inspect*")
-
-(push cider-inspector-buffer cider-ancillary-buffers)
-
-;;; Customization
-(defgroup cider-inspector nil
- "Presentation and behaviour 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)
- :group 'cider-inspector
- :package-version '(cider . "0.10.0"))
-
-(defcustom cider-inspector-fill-frame nil
- "Controls whether the cider inspector window fills its frame."
- :type 'boolean
- :group 'cider-inspector
- :package-version '(cider . "0.15.0"))
-
-(defvar cider-inspector-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map cider-popup-buffer-mode-map)
- (define-key map (kbd "RET") #'cider-inspector-operate-on-point)
- (define-key map [mouse-1] #'cider-inspector-operate-on-click)
- (define-key map "l" #'cider-inspector-pop)
- (define-key map "g" #'cider-inspector-refresh)
- ;; Page-up/down
- (define-key map [next] #'cider-inspector-next-page)
- (define-key map [prior] #'cider-inspector-prev-page)
- (define-key map " " #'cider-inspector-next-page)
- (define-key map (kbd "M-SPC") #'cider-inspector-prev-page)
- (define-key map (kbd "S-SPC") #'cider-inspector-prev-page)
- (define-key map "s" #'cider-inspector-set-page-size)
- (define-key map [tab] #'cider-inspector-next-inspectable-object)
- (define-key map "\C-i" #'cider-inspector-next-inspectable-object)
- (define-key map [(shift tab)] #'cider-inspector-previous-inspectable-object)
- ;; Emacs translates S-TAB to BACKTAB on X.
- (define-key map [backtab] #'cider-inspector-previous-inspectable-object)
- 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 buffer-read-only t)
- (setq-local electric-indent-chars nil)
- (when cider-special-mode-truncate-lines
- (setq-local truncate-lines t)))
-
-;;;###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 M-x and its variants, the value of `last-command'
-is not set to the command it invokes.")
-
-;; 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)))
- (when-let (value (cider-sync-request:inspect-expr expr ns (or cider-inspector-page-size 32)))
- (cider-inspector--render-value value)))
-
-(defun cider-inspector-pop ()
- (interactive)
- (setq cider-inspector-last-command 'cider-inspector-pop)
- (when-let (value (cider-sync-request:inspect-pop))
- (cider-inspector--render-value value)))
-
-(defun cider-inspector-push (idx)
- (push (point) cider-inspector-location-stack)
- (when-let (value (cider-sync-request:inspect-push idx))
- (cider-inspector--render-value value)))
-
-(defun cider-inspector-refresh ()
- (interactive)
- (when-let (value (cider-sync-request:inspect-refresh))
- (cider-inspector--render-value value)))
-
-(defun cider-inspector-next-page ()
- "Jump to the next page when inspecting a paginated sequence/map.
-
-Does nothing if already on the last page."
- (interactive)
- (push (point) cider-inspector-page-location-stack)
- (when-let (value (cider-sync-request:inspect-next-page))
- (cider-inspector--render-value value)))
-
-(defun cider-inspector-prev-page ()
- "Jump to the previous page when expecting a paginated sequence/map.
-
-Does nothing if already on the first page."
- (interactive)
- (setq cider-inspector-last-command 'cider-inspector-prev-page)
- (when-let (value (cider-sync-request:inspect-prev-page))
- (cider-inspector--render-value value)))
-
-(defun cider-inspector-set-page-size (page-size)
- "Set the page size in pagination mode to the specified PAGE-SIZE.
-
-Current page will be reset to zero."
- (interactive "nPage size: ")
- (when-let (value (cider-sync-request:inspect-set-page-size page-size))
- (cider-inspector--render-value value)))
-
-;; nREPL interactions
-(defun cider-sync-request:inspect-pop ()
- "Move one level up in the inspector stack."
- (thread-first (list "op" "inspect-pop")
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "value")))
-
-(defun cider-sync-request:inspect-push (idx)
- "Inspect the inside value specified by IDX."
- (thread-first (list "op" "inspect-push"
- "idx" idx)
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "value")))
-
-(defun cider-sync-request:inspect-refresh ()
- "Re-render the currently inspected value."
- (thread-first (list "op" "inspect-refresh")
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "value")))
-
-(defun cider-sync-request:inspect-next-page ()
- "Jump to the next page in paginated collection view."
- (thread-first (list "op" "inspect-next-page")
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "value")))
-
-(defun cider-sync-request:inspect-prev-page ()
- "Jump to the previous page in paginated collection view."
- (thread-first (list "op" "inspect-prev-page")
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "value")))
-
-(defun cider-sync-request:inspect-set-page-size (page-size)
- "Set the page size in paginated view to PAGE-SIZE."
- (thread-first (list "op" "inspect-set-page-size"
- "page-size" page-size)
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "value")))
-
-(defun cider-sync-request:inspect-expr (expr ns page-size)
- "Evaluate EXPR in context of NS and inspect its result.
-Set the page size in paginated view to PAGE-SIZE."
- (thread-first (append (nrepl--eval-request expr ns)
- (list "inspect" "true"
- "page-size" page-size))
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "value")))
-
-;; Render Inspector from Structured Values
-(defun cider-inspector--render-value (value)
- (cider-make-popup-buffer cider-inspector-buffer 'cider-inspector-mode)
- (cider-inspector-render cider-inspector-buffer value)
- (cider-popup-buffer-display cider-inspector-buffer t)
- (when cider-inspector-fill-frame (delete-other-windows))
- (with-current-buffer cider-inspector-buffer
- (when (eq cider-inspector-last-command 'cider-inspector-pop)
- (setq cider-inspector-last-command nil)
- ;; Prevents error message being displayed when we try to pop
- ;; from the top-level of a data struture
- (when cider-inspector-location-stack
- (goto-char (pop cider-inspector-location-stack))))
-
- (when (eq cider-inspector-last-command 'cider-inspector-prev-page)
- (setq cider-inspector-last-command nil)
- ;; Prevents error message being displayed when we try to
- ;; go to a prev-page from the first page
- (when cider-inspector-page-location-stack
- (goto-char (pop cider-inspector-page-location-stack))))))
-
-(defun cider-inspector-render (buffer str)
- (with-current-buffer buffer
- (cider-inspector-mode)
- (let ((inhibit-read-only t))
- (condition-case nil
- (cider-inspector-render* (car (read-from-string str)))
- (error (insert "\nInspector error for: " str))))
- (goto-char (point-min))))
-
-(defun cider-inspector-render* (elements)
- (dolist (el elements)
- (cider-inspector-render-el* el)))
-
-(defun cider-inspector-render-el* (el)
- (cond ((symbolp el) (insert (symbol-name el)))
- ((stringp el) (insert (propertize el 'font-lock-face 'font-lock-keyword-face)))
- ((and (consp el) (eq (car el) :newline))
- (insert "\n"))
- ((and (consp el) (eq (car el) :value))
- (cider-inspector-render-value (cadr el) (cl-caddr el)))
- (t (message "Unrecognized inspector object: %s" el))))
-
-(defun cider-inspector-render-value (value idx)
- (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) (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) (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 ()
- (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 (1- (point))))))
-
-(defun cider-inspector-operate-on-point ()
- "Invoke the command for the text at point.
-1. If point is on a value then recursively call the inspector on
-that value.
-2. If point is on an action then call that action.
-3. If point is on a range-button fetch and insert the range."
- (interactive)
- (seq-let (property value) (cider-inspector-property-at-point)
- (cl-case property
- (cider-value-idx
- (cider-inspector-push value))
- ;; TODO: range and action handlers
- (t (error "No object at point")))))
-
-(defun cider-inspector-operate-on-click (event)
- "Move to EVENT's position and operate the part."
- (interactive "@e")
- (let ((point (posn-point (event-end event))))
- (cond ((and point
- (or (get-text-property point 'cider-value-idx)))
- (goto-char point)
- (cider-inspector-operate-on-point))
- (t
- (error "No clickable part here")))))
-
-;;;###autoload
-(define-obsolete-function-alias 'cider-inspect-read-and-inspect
- 'cider-inspect-expr "0.13.0")
-
-(provide 'cider-inspector)
-
-;;; cider-inspector.el ends here
+++ /dev/null
-;;; cider-interaction.el --- IDE for Clojure -*- lexical-binding: t -*-
-
-;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
-;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; 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 an Emacs Lisp client to connect to Clojure nREPL servers.
-
-;;; Code:
-
-(require 'cider-client)
-(require 'cider-repl)
-(require 'cider-popup)
-(require 'cider-common)
-(require 'cider-util)
-(require 'cider-stacktrace)
-(require 'cider-test)
-(require 'cider-doc)
-(require 'cider-eldoc)
-(require 'cider-overlays)
-(require 'subr-x)
-(require 'cider-compat)
-
-(require 'clojure-mode)
-(require 'thingatpt)
-(require 'arc-mode)
-(require 'ansi-color)
-(require 'cl-lib)
-(require 'compile)
-(require 'etags) ; for find-tags-marker-ring
-(require 'tramp)
-
-(defconst cider-read-eval-buffer "*cider-read-eval*")
-(defconst cider-result-buffer "*cider-result*")
-(defconst cider-nrepl-session-buffer "*cider-nrepl-session*")
-(add-to-list 'cider-ancillary-buffers cider-nrepl-session-buffer)
-
-(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.
-
-Irespective of the value of this variable, the `cider-error-buffer' is
-always generated in the background. Use `cider-visit-error-buffer' to
-navigate to this buffer."
- :type '(choice (const :tag "always" t)
- (const except-in-repl)
- (const only-in-repl)
- (const :tag "never" nil))
- :group 'cider)
-
-(defcustom cider-auto-jump-to-error t
- "Control the cursor jump behaviour 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-prompt-save-file-on-load t
- "Controls whether to prompt to save the file when loading a buffer.
-If nil, files are not saved.
-If t, the user is prompted to save the file if it's been modified.
-If the symbol `always-save', save the file without confirmation."
- :type '(choice (const t :tag "Prompt to save the file if it's been modified")
- (const nil :tag "Don't save the file")
- (const always-save :tag "Save the file without confirmation"))
- :group 'cider
- :package-version '(cider . "0.6.0"))
-
-(defcustom cider-completion-use-context t
- "When true, uses context at point to improve completion suggestions."
- :type 'boolean
- :group 'cider
- :package-version '(cider . "0.7.0"))
-
-(defcustom cider-annotate-completion-candidates t
- "When true, annotate completion candidates with some extra information."
- :type 'boolean
- :group 'cider
- :package-version '(cider . "0.8.0"))
-
-(defcustom cider-annotate-completion-function
- #'cider-default-annotate-completion-function
- "Controls how the annotations for completion candidates are formatted.
-
-Must be a function that takes two arguments: the abbreviation of the
-candidate type according to `cider-completion-annotations-alist' and the
-candidate's namespace."
- :type 'function
- :group 'cider
- :package-version '(cider . "0.9.0"))
-
-(defcustom cider-completion-annotations-alist
- '(("class" "c")
- ("field" "fi")
- ("function" "f")
- ("import" "i")
- ("keyword" "k")
- ("local" "l")
- ("macro" "m")
- ("method" "me")
- ("namespace" "n")
- ("protocol" "p")
- ("protocol-function" "pf")
- ("record" "r")
- ("special-form" "s")
- ("static-field" "sf")
- ("static-method" "sm")
- ("type" "t")
- ("var" "v"))
- "Controls the abbreviations used when annotating completion candidates.
-
-Must be a list of elements with the form (TYPE . ABBREVIATION), where TYPE
-is a possible value of the candidate's type returned from the completion
-backend, and ABBREVIATION is a short form of that type."
- :type '(alist :key-type string :value-type string)
- :group 'cider
- :package-version '(cider . "0.9.0"))
-
-(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"))
-
-(defconst cider-refresh-log-buffer "*cider-refresh-log*")
-
-(defcustom cider-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-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-refresh-before-fn nil
- "Clojure function for `cider-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-refresh-after-fn nil
- "Clojure function for `cider-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"))
-
-(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)
-
-(defconst cider-clojure-artifact-id "org.clojure/clojure"
- "Artifact identifier for Clojure.")
-
-(defconst cider-minimum-clojure-version "1.7.0"
- "Minimum supported version of Clojure.")
-
-(defconst cider-latest-clojure-version "1.8.0"
- "Latest supported version of Clojure.")
-
-(defconst cider-required-nrepl-version "0.2.12"
- "The minimum nREPL version that's known to work properly with CIDER.")
-
-;;; 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.")
-
-(defvar-local cider-connection-created-with 'jack-in
- "Save how the connection was created.
-Its value can be either 'jack-in or 'connect.")
-
-(defun cider-read-from-minibuffer (prompt &optional value)
- "Read a string from the minibuffer, prompting with PROMPT.
-If VALUE is non-nil, it is inserted into the minibuffer as initial-input.
-
-PROMPT need not end with \": \". If it doesn't, VALUE is displayed on the
-prompt as a default value (used if the user doesn't type anything) and is
-not used as initial input (input is left empty)."
- (minibuffer-with-setup-hook
- (lambda ()
- (set-syntax-table clojure-mode-syntax-table)
- (add-hook 'completion-at-point-functions
- #'cider-complete-at-point nil t)
- (setq-local eldoc-documentation-function #'cider-eldoc)
- (run-hooks 'eval-expression-minibuffer-setup-hook))
- (let* ((has-colon (string-match ": \\'" prompt))
- (input (read-from-minibuffer (cond
- (has-colon prompt)
- (value (format "%s (default %s): " prompt value))
- (t (format "%s: " prompt)))
- (when has-colon value) ; initial-input
- cider-minibuffer-map nil
- 'cider-minibuffer-history
- (unless has-colon value)))) ; default-value
- (if (and (equal input "") value (not has-colon))
- value
- input))))
-
-\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)))
- (quit-window nil error-win)))
-
-;;;
-(declare-function cider-mode "cider-mode")
-
-(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
- (ring-insert find-tag-marker-ring (point-marker)))
- (if other-window
- (pop-to-buffer buffer)
- ;; like switch-to-buffer, but reuse existing window if BUFFER is visible
- (pop-to-buffer buffer '((display-buffer-reuse-window display-buffer-same-window))))
- (with-current-buffer buffer
- (widen)
- (goto-char (point-min))
- (cider-mode +1)
- (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))))
- (t nil))))
-
-(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))
-
-(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)))
-
-(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-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-sync-request:ns-path (ns)
- "Get the path to the file containing NS."
- (thread-first (list "op" "ns-path"
- "ns" ns)
- cider-nrepl-send-sync-request
- (nrepl-dict-get "path")))
-
-(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 %s" ns)))
-
-(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)))))
-
-(defvar cider-completion-last-context nil)
-
-(defun cider-completion-symbol-start-pos ()
- "Find the starting position of the symbol at point, unless inside a string."
- (let ((sap (symbol-at-point)))
- (when (and sap (not (nth 3 (syntax-ppss))))
- (car (bounds-of-thing-at-point 'symbol)))))
-
-(defun cider-completion-get-context-at-point ()
- "Extract the context at point.
-If point is not inside the list, returns nil; otherwise return \"top-level\"
-form, with symbol at point replaced by __prefix__."
- (when (save-excursion
- (condition-case _
- (progn
- (up-list)
- (check-parens)
- t)
- (scan-error nil)
- (user-error nil)))
- (save-excursion
- (let* ((pref-end (point))
- (pref-start (cider-completion-symbol-start-pos))
- (context (cider-defun-at-point))
- (_ (beginning-of-defun))
- (expr-start (point)))
- (concat (when pref-start (substring context 0 (- pref-start expr-start)))
- "__prefix__"
- (substring context (- pref-end expr-start)))))))
-
-(defun cider-completion-get-context ()
- "Extract context depending on `cider-completion-use-context' and major mode."
- (let ((context (if (and cider-completion-use-context
- ;; Important because `beginning-of-defun' and
- ;; `ending-of-defun' work incorrectly in the REPL
- ;; buffer, so context extraction fails there.
- (derived-mode-p 'clojure-mode))
- (or (cider-completion-get-context-at-point)
- "nil")
- "nil")))
- (if (string= cider-completion-last-context context)
- ":same"
- (setq cider-completion-last-context context)
- context)))
-
-(defun cider-completion--parse-candidate-map (candidate-map)
- (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 (str)
- "Complete STR with context at point."
- (let* ((context (cider-completion-get-context))
- (candidates (cider-sync-request:complete str context)))
- (mapcar #'cider-completion--parse-candidate-map candidates)))
-
-(defun cider-completion--get-candidate-type (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)
- (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)
- (concat (when ns (format " (%s)" ns))
- (when type (format " <%s>" type))))
-
-(defun cider-annotate-symbol (symbol)
- "Return a string suitable for annotating SYMBOL.
-
-If SYMBOL has a text property `type` whose value is recognised, its
-abbreviation according to `cider-completion-annotations-alist' will be
-used. If `type` is present but not recognised, its value will be used
-unaltered.
-
-If SYMBOL has a text property `ns`, then its value will be used according
-to `cider-completion-annotations-include-ns'.
-
-The formatting is performed by `cider-annotate-completion-function'."
- (when cider-annotate-completion-candidates
- (let* ((type (cider-completion--get-candidate-type symbol))
- (ns (cider-completion--get-candidate-ns symbol)))
- (funcall cider-annotate-completion-function type ns))))
-
-(defun cider-complete-at-point ()
- "Complete the symbol at point."
- (when-let ((bounds (bounds-of-thing-at-point 'symbol)))
- (when (and (cider-connected-p)
- (not (or (cider-in-string-p) (cider-in-comment-p))))
- (list (car bounds) (cdr bounds)
- (completion-table-dynamic #'cider-complete)
- :annotation-function #'cider-annotate-symbol
- :company-doc-buffer #'cider-create-doc-buffer
- :company-location #'cider-company-location
- :company-docsig #'cider-company-docsig))))
-
-(defun cider-company-location (var)
- "Open VAR's definition in a buffer.
-
-Returns the cons of the buffer itself and the location of VAR's definition
-in the buffer."
- (when-let ((info (cider-var-info var))
- (file (nrepl-dict-get info "file"))
- (line (nrepl-dict-get info "line"))
- (buffer (cider-find-file file)))
- (with-current-buffer buffer
- (save-excursion
- (goto-char (point-min))
- (forward-line (1- line))
- (cons buffer (point))))))
-
-(defun cider-company-docsig (thing)
- "Return signature for THING."
- (let* ((eldoc-info (cider-eldoc-info thing))
- (ns (lax-plist-get eldoc-info "ns"))
- (symbol (lax-plist-get eldoc-info "symbol"))
- (arglists (lax-plist-get eldoc-info "arglists")))
- (when eldoc-info
- (format "%s: %s"
- (cider-eldoc-format-thing ns symbol thing
- (cider-eldoc-thing-type eldoc-info))
- (cider-eldoc-format-arglist arglists 0)))))
-
-;; Fuzzy completion for company-mode
-
-(defun cider-company-unfiltered-candidates (string table predicate point)
- "Return CIDER completion candidates as is, without filtering them by prefix."
- (cider-complete string))
-
-(add-to-list 'completion-styles-alist
- '(cider
- cider-company-unfiltered-candidates
- cider-company-unfiltered-candidates
- "CIDER backend-driven completion style."))
-
-(defun cider-company-enable-fuzzy-completion ()
- "Enable backend-driven fuzzy completion in the current buffer."
- (setq-local completion-styles '(cider)))
-
-(defun cider-stdin-handler (&optional buffer)
- "Make a stdin response handler for BUFFER."
- (nrepl-make-response-handler (or buffer (current-buffer))
- (lambda (buffer value)
- (cider-repl-emit-result buffer value t))
- (lambda (buffer out)
- (cider-repl-emit-stdout buffer out))
- (lambda (buffer err)
- (cider-repl-emit-stderr buffer err))
- nil))
-
-(defun cider-insert-eval-handler (&optional buffer)
- "Make an nREPL evaluation handler for the BUFFER.
-The handler simply inserts the result value in BUFFER."
- (let ((eval-buffer (current-buffer)))
- (nrepl-make-response-handler (or buffer eval-buffer)
- (lambda (_buffer value)
- (with-current-buffer buffer
- (insert value)))
- (lambda (_buffer out)
- (cider-repl-emit-interactive-stdout out))
- (lambda (_buffer err)
- (cider-handle-compilation-errors err eval-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)
- (condition-case nil
- (while (progn (clojure-forward-logical-sexp)
- (and (<= (point) end)
- (not (eobp))))
- (cider--make-fringe-overlay (point)))
- (scan-error nil)))))
-
-(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."
- (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))))
- (nrepl-make-response-handler (or buffer eval-buffer)
- (lambda (_buffer value)
- (if beg
- (cider--make-fringe-overlays-for-region beg end)
- (cider--make-fringe-overlay end))
- (cider--display-interactive-eval-result value end))
- (lambda (_buffer out)
- (cider-emit-interactive-eval-output out))
- (lambda (_buffer err)
- (cider-emit-interactive-eval-err-output err)
- (cider-handle-compilation-errors err eval-buffer))
- '())))
-
-(defun cider-load-file-handler (&optional buffer)
- "Make a load file handler for BUFFER."
- (let ((eval-buffer (current-buffer)))
- (nrepl-make-response-handler (or buffer eval-buffer)
- (lambda (buffer value)
- (cider--display-interactive-eval-result value)
- (when (buffer-live-p buffer)
- (with-current-buffer buffer
- (cider--make-fringe-overlays-for-region (point-min) (point-max))
- (run-hooks 'cider-file-loaded-hook))))
- (lambda (_buffer value)
- (cider-emit-interactive-eval-output value))
- (lambda (_buffer err)
- (cider-emit-interactive-eval-err-output err)
- (cider-handle-compilation-errors err eval-buffer))
- '()
- (lambda ()
- (funcall nrepl-err-handler)))))
-
-(defun cider-eval-print-handler (&optional buffer)
- "Make a handler for evaluating and printing result in BUFFER."
- (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 at which to insert.
-COMMENT-PREFIX is the comment prefix to use."
- (nrepl-make-response-handler buffer
- (lambda (buffer value)
- (with-current-buffer buffer
- (save-excursion
- (goto-char location)
- (insert (concat comment-prefix
- value "\n")))))
- (lambda (_buffer out)
- (cider-emit-interactive-eval-output out))
- (lambda (_buffer err)
- (cider-emit-interactive-eval-err-output err))
- '()))
-
-(defun cider-popup-eval-out-handler (&optional buffer)
- "Make a handler for evaluating and printing stdout/stderr in popup BUFFER.
-
-This is used by pretty-printing commands and intentionally discards their results."
- (nrepl-make-response-handler (or buffer (current-buffer))
- '()
- ;; stdout handler
- (lambda (buffer str)
- (cider-emit-into-popup-buffer buffer (ansi-color-apply str)))
- ;; stderr handler
- (lambda (buffer str)
- (cider-emit-into-popup-buffer buffer (ansi-color-apply str)))
- '()))
-
-(defun cider-visit-error-buffer ()
- "Visit the `cider-error-buffer' (usually *cider-error*) if it exists."
- (interactive)
- (if-let ((buffer (get-buffer cider-error-buffer)))
- (cider-popup-buffer-display buffer cider-auto-select-error-buffer)
- (user-error "No %s buffer" cider-error-buffer)))
-
-(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)
- (cider-make-popup-buffer cider-error-buffer mode)))
-
-(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--render-stacktrace-causes (causes &optional error-types)
- "If CAUSES is non-nil, render its contents into a new error buffer.
-Optional argument ERROR-TYPES contains a list which should determine the
-op/situation that originated this error."
- (when causes
- (let ((error-buffer (cider-new-error-buffer #'cider-stacktrace-mode error-types)))
- (cider-stacktrace-render error-buffer (reverse causes) error-types))))
-
-(defun cider--handle-stacktrace-response (response causes)
- "Handle stacktrace op RESPONSE, aggregating the result into CAUSES.
-
-If RESPONSE contains a cause, cons it onto CAUSES and return that. If
-RESPONSE is the final message (i.e. it contains a status), render CAUSES
-into a new error buffer."
- (nrepl-dbind-response response (class status)
- (cond (class (cons response causes))
- (status (cider--render-stacktrace-causes causes)))))
-
-(defun cider-default-err-op-handler ()
- "Display the last exception, with middleware support."
- ;; Causes are returned as a series of messages, which we aggregate in `causes'
- (let (causes)
- (cider-nrepl-send-request
- (append
- (list "op" "stacktrace")
- (when (cider--pprint-fn)
- (list "pprint-fn" (cider--pprint-fn)))
- (when cider-stacktrace-print-length
- (list "print-length" cider-stacktrace-print-length))
- (when cider-stacktrace-print-level
- (list "print-level" cider-stacktrace-print-level)))
- (lambda (response)
- ;; While the return value of `cider--handle-stacktrace-response' is not
- ;; meaningful for the last message, we do not need the value of `causes'
- ;; after it has been handled, so it's fine to set it unconditionally here
- (setq causes (cider--handle-stacktrace-response response causes))))))
-
-(defun cider-default-err-handler ()
- "This function determines how the error buffer is shown.
-It delegates the actual error content to the eval or op handler."
- (if (cider-nrepl-op-supported-p "stacktrace")
- (cider-default-err-op-handler)
- (cider-default-err-eval-handler)))
-
-(defvar cider-compilation-regexp
- '("\\(?:.*\\(warning, \\)\\|.*?\\(, compiling\\):(\\)\\(.*?\\):\\([[:digit:]]+\\)\\(?::\\([[:digit:]]+\\)\\)?\\(\\(?: - \\(.*\\)\\)\\|)\\)" 3 4 5 (1))
- "Specifications for matching errors and warnings in Clojure stacktraces.
-See `compilation-error-regexp-alist' for help on their format.")
-
-(add-to-list 'compilation-error-regexp-alist-alist
- (cons 'cider cider-compilation-regexp))
-(add-to-list 'compilation-error-regexp-alist 'cider)
-
-(defun cider-extract-error-info (regexp message)
- "Extract error information with REGEXP against MESSAGE."
- (let ((file (nth 1 regexp))
- (line (nth 2 regexp))
- (col (nth 3 regexp))
- (type (nth 4 regexp))
- (pat (car regexp)))
- (when (string-match pat message)
- ;; special processing for type (1.2) style
- (setq type (if (consp type)
- (or (and (car type) (match-end (car type)) 1)
- (and (cdr type) (match-end (cdr type)) 0)
- 2)))
- (list
- (when file
- (let ((val (match-string-no-properties file message)))
- (unless (string= val "NO_SOURCE_PATH") val)))
- (when line (string-to-number (match-string-no-properties line message)))
- (when col
- (let ((val (match-string-no-properties col message)))
- (when val (string-to-number val))))
- (aref [cider-warning-highlight-face
- cider-warning-highlight-face
- cider-error-highlight-face]
- (or type 2))
- message))))
-
-(defun cider--goto-expression-start ()
- "Go to the beginning a list, vector, map or set outside of a string.
-
-We do so by starting and the current position and proceeding backwards
-until we find a delimiters that's not inside a string."
- (if (and (looking-back "[])}]" (line-beginning-position))
- (null (nth 3 (syntax-ppss))))
- (backward-sexp)
- (while (or (not (looking-at-p "[({[]"))
- (nth 3 (syntax-ppss)))
- (backward-char))))
-
-(defun cider--find-last-error-location (message)
- "Return the location (begin end buffer) from the Clojure error MESSAGE.
-If location could not be found, return nil."
- (save-excursion
- (let ((info (cider-extract-error-info cider-compilation-regexp message)))
- (when info
- (let ((file (nth 0 info))
- (line (nth 1 info))
- (col (nth 2 info)))
- (unless (or (not (stringp file))
- (cider--tooling-file-p file))
- (when-let ((buffer (cider-find-file file)))
- (with-current-buffer buffer
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (forward-line (1- line))
- (move-to-column (or col 0))
- (let ((begin (progn (if col (cider--goto-expression-start) (back-to-indentation))
- (point)))
- (end (progn (if col (forward-list) (move-end-of-line nil))
- (point))))
- (list begin end buffer))))))))))))
-
-(defun cider-handle-compilation-errors (message eval-buffer)
- "Highlight and jump to compilation error extracted from MESSAGE.
-EVAL-BUFFER is the buffer that was current during user's interactive
-evaluation command. Honor `cider-auto-jump-to-error'."
- (when-let ((loc (cider--find-last-error-location message))
- (overlay (make-overlay (nth 0 loc) (nth 1 loc) (nth 2 loc)))
- (info (cider-extract-error-info cider-compilation-regexp message)))
- (let* ((face (nth 3 info))
- (note (nth 4 info))
- (auto-jump (if (eq cider-auto-jump-to-error 'errors-only)
- (not (eq face 'cider-warning-highlight-face))
- 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)))))))))
-
-(defun cider-need-input (buffer)
- "Handle an need-input request from BUFFER."
- (with-current-buffer buffer
- (nrepl-request:stdin (concat (read-from-minibuffer "Stdin: ") "\n")
- (cider-stdin-handler buffer)
- (cider-current-connection))))
-
-(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))))
-
-\f
-;;; Evaluation
-
-(defvar cider-to-nrepl-filename-function
- (with-no-warnings
- (if (eq system-type 'cygwin)
- #'cygwin-convert-file-name-to-windows
- #'identity))
- "Function to translate Emacs filenames to nREPL namestrings.")
-
-(defvar-local cider--ns-form-cache (make-hash-table :test 'equal)
- "ns form cache for the current buffer.
-
-The cache is a hash where the keys are connection names and the values
-are ns forms. This allows every connection to keep track of the ns
-form independently.")
-
-(defun cider--cache-ns-form ()
- "Cache the form in the current buffer for the current connection."
- (puthash (cider-current-connection)
- (cider-ns-form)
- cider--ns-form-cache))
-
-(defun cider--cached-ns-form ()
- "Retrieve the cached ns form for the current buffer & connection."
- (gethash (cider-current-connection) cider--ns-form-cache))
-
-(defun cider--prep-interactive-eval (form)
- "Prepare the environment for an interactive eval of FORM.
-
-If FORM is an ns-form, ensure that it is evaluated in the `user`
-namespace. Otherwise, ensure the current ns declaration has been
-evaluated (so that the ns containing FORM exists).
-
-Clears any compilation highlights and kills the error window."
- (cider--clear-compilation-highlights)
- (cider--quit-error-window)
- (let ((cur-ns-form (cider-ns-form)))
- (when (and cur-ns-form
- (not (string= cur-ns-form (cider--cached-ns-form)))
- (not (cider-ns-form-p form)))
- ;; TODO: check for evaluation errors
- (cider-eval-ns-form 'sync)
- (cider--cache-ns-form))))
-
-(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 appended to 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 bounds)))
- (start (car-safe bounds))
- (end (car-safe (cdr-safe bounds))))
- (when (and start end)
- (remove-overlays start end 'cider-temporary t))
- (unless (and cider-interactive-eval-override
- (functionp cider-interactive-eval-override)
- (funcall cider-interactive-eval-override form callback bounds))
- (cider-map-connections #'ignore :any)
- (cider--prep-interactive-eval form)
- (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))))
-
-(defun cider-eval-region (start end)
- "Evaluate the region between START and END."
- (interactive "r")
- (cider-interactive-eval nil nil (list start end)))
-
-(defun cider-eval-last-sexp (&optional prefix)
- "Evaluate the expression preceding point.
-If invoked with a PREFIX argument, print the result in the current buffer."
- (interactive "P")
- (cider-interactive-eval nil
- (when prefix (cider-eval-print-handler))
- (cider-last-sexp 'bounds)))
-
-(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
- (backward-kill-sexp)
- (cider-interactive-eval last-sexp (cider-eval-print-handler))))
-
-(defun cider-eval-sexp-at-point (&optional prefix)
- "Evaluate the expression around point.
-If invoked with a PREFIX argument, print the result in the current buffer."
- (interactive "P")
- (save-excursion
- (goto-char (cadr (cider-sexp-at-point 'bounds)))
- (cider-eval-last-sexp prefix)))
-
-(defun cider-eval-defun-to-comment (loc)
- "Evaluate the \"top-level\" form and insert result as comment at LOC.
-
-With a prefix arg, LOC, insert before the form, otherwise afterwards."
- (interactive "P")
- (let* ((bounds (cider-defun-at-point 'bounds))
- (insertion-point (nth (if loc 0 1) bounds)))
- (cider-interactive-eval nil
- (cider-eval-print-with-comment-handler
- (current-buffer) insertion-point ";; => ")
- bounds)))
-
-(declare-function cider-switch-to-repl-buffer "cider-mode")
-
-(defun cider-eval-last-sexp-to-repl (&optional prefix)
- "Evaluate the expression preceding point and insert its result in the REPL.
-If invoked with a PREFIX argument, switch to the REPL buffer."
- (interactive "P")
- (cider-interactive-eval nil
- (cider-insert-eval-handler (cider-current-connection))
- (cider-last-sexp 'bounds))
- (when prefix
- (cider-switch-to-repl-buffer)))
-
-(defun cider-pprint-eval-last-sexp-to-repl (&optional prefix)
- "Evaluate the expression preceding point and insert its pretty-printed result in the REPL.
-If invoked with a PREFIX argument, switch to the REPL buffer."
- (interactive "P")
- (let* ((conn-buffer (cider-current-connection)))
- (cider-interactive-eval nil
- (cider-insert-eval-handler conn-buffer)
- (cider-last-sexp 'bounds)
- (cider--nrepl-pprint-request-plist (cider--pretty-print-width))))
- (when prefix
- (cider-switch-to-repl-buffer)))
-
-(defun cider-eval-print-last-sexp ()
- "Evaluate the expression preceding point.
-Print its value into the current buffer."
- (interactive)
- (cider-interactive-eval nil
- (cider-eval-print-handler)
- (cider-last-sexp 'bounds)))
-
-(defun cider--pprint-eval-form (form)
- "Pretty print FORM in popup buffer."
- (let* ((result-buffer (cider-popup-buffer cider-result-buffer nil 'clojure-mode))
- (handler (cider-popup-eval-out-handler result-buffer)))
- (cider-interactive-eval (when (stringp form) form)
- handler
- (when (consp form) form)
- (cider--nrepl-pprint-request-plist (cider--pretty-print-width)))))
-
-(defun cider-pprint-eval-last-sexp ()
- "Evaluate the sexp preceding point and pprint its value in a popup buffer."
- (interactive)
- (cider--pprint-eval-form (cider-last-sexp 'bounds)))
-
-(defun cider--prompt-and-insert-inline-dbg ()
- "Insert a #dbg button at the current sexp."
- (save-excursion
- (let ((beg))
- (skip-chars-forward "\r\n[:blank:]")
- (unless (looking-at-p "(")
- (ignore-errors (backward-up-list)))
- (setq beg (point))
- (let* ((cond (cider-read-from-minibuffer "Condition for debugging (leave empty for \"always\"): "))
- (button (propertize (concat "#dbg"
- (unless (equal cond "")
- (format " ^{:break/when %s}" cond)))
- 'font-lock-face 'cider-fragile-button-face)))
- (when (> (current-column) 30)
- (insert "\n")
- (indent-according-to-mode))
- (insert button)
- (when (> (current-column) 40)
- (insert "\n")
- (indent-according-to-mode)))
- (make-button beg (point)
- 'help-echo "Breakpoint. Reevaluate this form to remove it."
- :type 'cider-fragile))))
-
-(defun cider-eval-defun-at-point (&optional debug-it)
- "Evaluate the current toplevel form, and print result in the minibuffer.
-With DEBUG-IT prefix argument, also debug the entire form as with the
-command `cider-debug-defun-at-point'."
- (interactive "P")
- (let ((inline-debug (eq 16 (car-safe debug-it))))
- (when debug-it
- (when (derived-mode-p 'clojurescript-mode)
- (when (y-or-n-p (concat "The debugger doesn't support ClojureScript yet, and we need help with that."
- " \nWould you like to read the Feature Request?"))
- (browse-url "https://github.com/clojure-emacs/cider/issues/1416"))
- (user-error "The debugger does not support ClojureScript"))
- (when inline-debug
- (cider--prompt-and-insert-inline-dbg)))
- (cider-interactive-eval (when (and debug-it (not inline-debug))
- (concat "#dbg\n" (cider-defun-at-point)))
- nil (cider-defun-at-point 'bounds))))
-
-(defun cider-pprint-eval-defun-at-point ()
- "Evaluate the \"top-level\" form at point and pprint its value in a popup buffer."
- (interactive)
- (cider--pprint-eval-form (cider-defun-at-point 'bounds)))
-
-(defun cider-eval-ns-form (&optional sync)
- "Evaluate the current buffer's namespace form.
-
-When SYNC is true the form is evaluated synchronously,
-otherwise it's evaluated interactively."
- (interactive)
- (when (clojure-find-ns)
- (save-excursion
- (goto-char (match-beginning 0))
- (if sync
- ;; 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))
- (cider-nrepl-sync-request:eval (cider-defun-at-point)))
- (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)))))
-
-(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 (concat "(" fn-name ")")))
- (cider-read-and-eval (cons form (length form)))))
-
-;; Eval keymap
-
-(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 "v") #'cider-eval-sexp-at-point)
- (define-key map (kbd ".") #'cider-read-and-eval-defun-at-point)
- ;; 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-v") #'cider-eval-sexp-at-point)
- (define-key map (kbd "C-.") #'cider-read-and-eval-defun-at-point)))
-
-\f
-;; Connection and REPL
-
-(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."
- (while (string-match "\\`[ \t\n\r]+\\|[ \t\n\r]+\\'" form)
- (setq form (replace-match "" t t form)))
- (with-current-buffer (cider-current-connection)
- (goto-char (point-max))
- (let ((beg (point)))
- (insert form)
- (indent-region beg (point)))
- (when eval
- (cider-repl-return)))
- (cider-switch-to-repl-buffer))
-
-(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 curent 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))
-
-(defun cider-ping ()
- "Check that communication with the nREPL server works."
- (interactive)
- (thread-first (cider-nrepl-sync-request:eval "\"PONG\"")
- (nrepl-dict-get "value")
- (read)
- (message)))
-
-(defun cider-enable-on-existing-clojure-buffers ()
- "Enable CIDER's minor mode on existing Clojure buffers.
-See `cider-mode'."
- (interactive)
- (add-hook 'clojure-mode-hook #'cider-mode)
- (dolist (buffer (cider-util--clojure-buffers))
- (with-current-buffer buffer
- (cider-mode +1))))
-
-(defun cider-disable-on-existing-clojure-buffers ()
- "Disable `cider-mode' on existing Clojure buffers.
-See `cider-mode'."
- (interactive)
- (dolist (buffer (cider-util--clojure-buffers))
- (with-current-buffer buffer
- (cider-mode -1))))
-
-(defun cider-possibly-disable-on-existing-clojure-buffers ()
- "If not connected, disable `cider-mode' on existing Clojure buffers."
- (unless (cider-connected-p)
- (cider-disable-on-existing-clojure-buffers)))
-
-\f
-;;; Completion
-
-(defun cider-sync-request:toggle-trace-var (symbol)
- "Toggle var tracing for SYMBOL."
- (thread-first (list "op" "toggle-trace-var"
- "ns" (cider-current-ns)
- "sym" symbol)
- (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)))))
-
-(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 (list "op" "toggle-trace-ns"
- "ns" ns)
- (cider-nrepl-send-sync-request)))
-
-(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-connections
- (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)))))))
- :clj))
-
-(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
- (list "op" "undef"
- "ns" (cider-current-ns)
- "symbol" sym)
- (cider-interactive-eval-handler (current-buffer))))))
-
-(defun cider-refresh--handle-response (response log-buffer)
- (nrepl-dbind-response response (out err reloading status error error-ns after before)
- (cl-flet* ((log (message &optional face)
- (cider-emit-into-popup-buffer log-buffer message face))
-
- (log-echo (message &optional face)
- (log message face)
- (unless cider-refresh-show-log-buffer
- (let ((message-truncate-lines t))
- (message "cider-refresh: %s" message)))))
- (cond
- (out
- (log out))
-
- (err
- (log err 'font-lock-warning-face))
-
- ((member "invoking-before" status)
- (log-echo (format "Calling %s\n" before) 'font-lock-string-face))
-
- ((member "invoked-before" status)
- (log-echo (format "Successfully called %s\n" before) 'font-lock-string-face))
-
- ((member "invoked-not-resolved" status)
- (log-echo "Could not resolve refresh function\n" 'font-lock-string-face))
-
- (reloading
- (log-echo (format "Reloading %s\n" reloading) 'font-lock-string-face))
-
- ((member "reloading" (nrepl-dict-keys response))
- (log-echo "Nothing to reload\n" 'font-lock-string-face))
-
- ((member "ok" status)
- (log-echo "Reloading successful\n" 'font-lock-string-face))
-
- (error-ns
- (log-echo (format "Error reloading %s\n" error-ns) 'font-lock-warning-face))
-
- ((member "invoking-after" status)
- (log-echo (format "Calling %s\n" after) 'font-lock-string-face))
-
- ((member "invoked-after" status)
- (log-echo (format "Successfully called %s\n" after) 'font-lock-string-face))))
-
- (with-selected-window (or (get-buffer-window cider-refresh-log-buffer)
- (selected-window))
- (with-current-buffer cider-refresh-log-buffer
- (goto-char (point-max))))
-
- (when (member "error" status)
- (cider--render-stacktrace-causes error))))
-
-(defun cider-refresh (&optional mode)
- "Reload modified and unloaded namespaces on the classpath.
-
-With a single prefix argument, or if MODE is `refresh-all', reload all
-namespaces on the classpath unconditionally.
-
-With a double prefix argument, or if MODE is `clear', clear the state of
-the namespace tracker before reloading. This is useful for recovering from
-some classes of error (for example, those caused by circular dependencies)
-that a normal reload would not otherwise recover from. The trade-off of
-clearing is that stale code from any deleted files may not be completely
-unloaded.
-
-With a negative prefix argument, or if MODE is `inhibit-fns', prevent any
-refresh functions (defined in `cider-refresh-before-fn' and
-`cider-refresh-after-fn') from being invoked."
- (interactive "p")
- (cider-ensure-connected)
- (cider-ensure-op-supported "refresh")
- (let ((clear? (member mode '(clear 16)))
- (refresh-all? (member mode '(refresh-all 4)))
- (inhibit-refresh-fns (member mode '(inhibit-fns -1))))
- (cider-map-connections
- (lambda (conn)
- ;; Inside the lambda, so the buffer is not created if we error out.
- (let ((log-buffer (or (get-buffer cider-refresh-log-buffer)
- (cider-make-popup-buffer cider-refresh-log-buffer))))
- (when cider-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"))
- (when clear?
- (cider-nrepl-send-sync-request (list "op" "refresh-clear") conn))
- (cider-nrepl-send-request
- (append (list "op" (if refresh-all? "refresh-all" "refresh")
- "print-length" cider-stacktrace-print-length
- "print-level" cider-stacktrace-print-level)
- (when (cider--pprint-fn) (list "pprint-fn" (cider--pprint-fn)))
- (when (and (not inhibit-refresh-fns) cider-refresh-before-fn)
- (list "before" cider-refresh-before-fn))
- (when (and (not inhibit-refresh-fns) cider-refresh-after-fn)
- (list "after" cider-refresh-after-fn)))
- (lambda (response)
- (cider-refresh--handle-response response log-buffer))
- conn)))
- :clj 'any-mode)))
-
-(defun cider-file-string (file)
- "Read the contents of a FILE and return as a string."
- (with-current-buffer (find-file-noselect file)
- (substring-no-properties (buffer-string))))
-
-(defun cider-load-buffer (&optional buffer)
- "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 or cljx file, and both a Clojure and
-ClojureScript REPL exists for the project, it is evaluated in both REPLs."
- (interactive)
- (check-parens)
- (cider-ensure-connected)
- (setq buffer (or buffer (current-buffer)))
- (with-current-buffer buffer
- (unless buffer-file-name
- (user-error "Buffer `%s' is not associated with a file" (current-buffer)))
- (when (and cider-prompt-save-file-on-load
- (buffer-modified-p)
- (or (eq cider-prompt-save-file-on-load 'always-save)
- (y-or-n-p (format "Save file %s? " buffer-file-name))))
- (save-buffer))
- (remove-overlays nil nil 'cider-temporary t)
- (cider--clear-compilation-highlights)
- (cider--quit-error-window)
- (cider--cache-ns-form)
- (let ((filename (buffer-file-name)))
- (cider-map-connections
- (lambda (connection)
- (cider-request:load-file (cider-file-string filename)
- (funcall cider-to-nrepl-filename-function
- (cider--server-filename filename))
- (file-name-nondirectory filename)
- connection))
- :both)
- (message "Loading %s..." filename))))
-
-(defun cider-load-file (filename)
- "Load (eval) the Clojure file FILENAME in nREPL.
-
-If the file is a cljc or cljx 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'."
- (interactive (list
- (read-file-name "Load file: " nil nil nil
- (when (buffer-file-name)
- (file-name-nondirectory
- (buffer-file-name))))))
- (if-let ((buffer (find-buffer-visiting filename)))
- (cider-load-buffer buffer)
- (find-file filename)
- (cider-load-buffer (current-buffer))))
-
-(defalias 'cider-eval-file 'cider-load-file
- "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--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."
- (let* ((original (substring-no-properties (buffer-string)))
- (formatted (funcall formatter original)))
- (unless (equal original formatted)
- (erase-buffer)
- (insert formatted))))
-
-(defun cider-format-buffer ()
- "Format the Clojure code in the current buffer."
- (interactive)
- (cider-ensure-connected)
- (cider--format-buffer #'cider-sync-request:format-code))
-
-(defun cider-format-edn-buffer ()
- "Format the EDN data in the current buffer."
- (interactive)
- (cider-ensure-connected)
- (cider--format-buffer (lambda (edn)
- (cider-sync-request:format-edn edn (cider--pretty-print-width)))))
-
-(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)))
-
-(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."
- (let* ((original (buffer-substring-no-properties start end))
- (formatted (funcall formatter original))
- (indented (cider--format-reindent formatted start)))
- (unless (equal original indented)
- (delete-region start end)
- (insert indented))))
-
-(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 #'cider-sync-request:format-code))
-
-(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 (- (cider--pretty-print-width) start-column)))
- (cider--format-region start end
- (lambda (edn)
- (cider-sync-request:format-edn edn right-margin)))))
-
-(defun cider-format-defun ()
- "Format the code in the current defun."
- (interactive)
- (cider-ensure-connected)
- (save-excursion
- (mark-defun)
- (cider-format-region (region-beginning) (region-end))))
-
-;;; 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-describe-nrepl-session ()
- "Describe an nREPL session."
- (interactive)
- (cider-ensure-connected)
- (let ((selected-session (completing-read "Describe nREPL session: " (nrepl-sessions (cider-current-connection)))))
- (when (and selected-session (not (equal selected-session "")))
- (let* ((session-info (nrepl-sync-request:describe (cider-current-connection)))
- (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-current-session)) "Active eval")
- ((equal session-id (cider-current-tooling-session)) "Active tooling")
- (t "Unknown"))))
- (with-current-buffer (cider-popup-buffer cider-nrepl-session-buffer)
- (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-close-nrepl-session ()
- "Close an nREPL session for the current connection."
- (interactive)
- (cider-ensure-connected)
- (nrepl-sync-request:close (cider-current-connection))
- (message "Closed nREPL session"))
-
-;;; quiting
-(defun cider--close-buffer (buffer)
- "Close the BUFFER and kill its associated process (if any)."
- (when (buffer-live-p buffer)
- (with-current-buffer buffer
- (when-let ((proc (get-buffer-process buffer)))
- (when (process-live-p proc)
- (when (or (not nrepl-server-buffer)
- ;; Sync request will hang if the server is dead.
- (process-live-p (get-buffer-process nrepl-server-buffer)))
- (when (or nrepl-session nrepl-tooling-session)
- (nrepl-sync-request:close buffer)))
- (when proc (delete-process proc)))))
- (kill-buffer buffer)))
-
-(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--quit-connection (conn)
- "Quit the connection CONN."
- (when conn
- (cider--close-connection-buffer conn)
- ;; clean the cached ns forms for this connection in all Clojure buffers
- (dolist (clojure-buffer (cider-util--clojure-buffers))
- (with-current-buffer clojure-buffer
- (remhash conn cider--ns-form-cache)))))
-
-(defun cider-quit (&optional quit-all)
- "Quit the currently active CIDER connection.
-
-With a prefix argument QUIT-ALL the command will kill all connections
-and all ancillary CIDER buffers."
- (interactive "P")
- (cider-ensure-connected)
- (if (and quit-all (y-or-n-p "Are you sure you want to quit all CIDER connections? "))
- (progn
- (dolist (connection cider-connections)
- (cider--quit-connection connection))
- (message "All active nREPL connections were closed"))
- (let ((connection (cider-current-connection)))
- (when (y-or-n-p (format "Are you sure you want to quit the current CIDER connection %s? "
- (cider-propertize (buffer-name connection) 'bold)))
- (cider--quit-connection connection))))
- ;; if there are no more connections we can kill all ancillary buffers
- (unless (cider-connected-p)
- (cider-close-ancillary-buffers)))
-
-(defun cider--restart-connection (conn)
- "Restart the connection CONN."
- (let ((project-dir (with-current-buffer conn nrepl-project-dir))
- (buf-name (buffer-name conn))
- ;; save these variables before we kill the connection
- (conn-creation-method (with-current-buffer conn cider-connection-created-with))
- (conn-endpoint (with-current-buffer conn nrepl-endpoint)))
- (cider--quit-connection conn)
- ;; Workaround for a nasty race condition https://github.com/clojure-emacs/cider/issues/439
- ;; TODO: Find a better way to ensure `cider-quit' has finished
- (message "Waiting for CIDER connection %s to quit..."
- (cider-propertize buf-name 'bold))
- (sleep-for 2)
- (pcase conn-creation-method
- (`connect (apply #'cider-connect conn-endpoint))
- (`jack-in (if project-dir
- (let ((default-directory project-dir))
- (cider-jack-in))
- (error "Can't restart CIDER connection for unknown project")))
- (_ (error "Unexpected value %S for `cider-connection-created-with'"
- conn-creation-method)))))
-
-(defun cider-restart (&optional restart-all)
- "Restart the currently active CIDER connection.
-If RESTART-ALL is t, then restarts all connections."
- (interactive "P")
- (cider-ensure-connected)
- (if restart-all
- (dolist (conn cider-connections)
- (cider--restart-connection conn))
- (cider--restart-connection (cider-current-connection))))
-
-(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-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))))
-
-(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
- (list "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))))))
-
-(provide 'cider-interaction)
-
-;;; cider-interaction.el ends here
+++ /dev/null
-;;; cider-macroexpansion.el --- Macro expansion support -*- lexical-binding: t -*-
-
-;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
-;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; 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)
-(require 'cider-compat)
-
-(defconst cider-macroexpansion-buffer "*cider-macroexpansion*")
-
-(push cider-macroexpansion-buffer cider-ancillary-buffers)
-
-(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-refered vars from other
- namespaces are refered using the alias for that namespace (if
- defined), other vars are displayed fully qualified."
- :type '(choice (const :tag "Suppress namespaces" none)
- (const :tag "Show fully-qualified namespaces" qualified)
- (const :tag "Show namespace aliases" tidy))
- :group 'cider
- :package-version '(cider . "0.7.0"))
-
-(defcustom cider-macroexpansion-print-metadata nil
- "Determines if metadata is included in macroexpansion results."
- :type 'boolean
- :group 'cider
- :package-version '(cider . "0.9.0"))
-
-(defun cider-sync-request:macroexpand (expander expr &optional display-namespaces)
- "Macroexpand, using EXPANDER, the given EXPR.
-The default for DISPLAY-NAMESPACES is taken from
-`cider-macroexpansion-display-namespaces'."
- (cider-ensure-op-supported "macroexpand")
- (thread-first (list "op" "macroexpand"
- "expander" expander
- "code" expr
- "ns" (cider-current-ns)
- "display-namespaces"
- (or display-namespaces
- (symbol-name cider-macroexpansion-display-namespaces)))
- (append (when cider-macroexpansion-print-metadata
- (list "print-meta" "true")))
- (cider-nrepl-send-sync-request)
- (nrepl-dict-get "expansion")))
-
-(defun cider-macroexpand-undo (&optional arg)
- "Undo the last macroexpansion, using `undo-only'.
-ARG is passed along to `undo-only'."
- (interactive)
- (let ((inhibit-read-only t))
- (undo-only arg)))
-
-(defvar cider-last-macroexpand-expression nil
- "Specify the last macroexpansion preformed.
-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 \\=`clojure.walk/macroexpand-all\\=` on the expression preceding point."
- (interactive)
- (cider-macroexpand-expr "macroexpand-all" (cider-last-sexp)))
-
-(defun cider-macroexpand-all-inplace ()
- "Perform inplace \\=`clojure.walk/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))
- (cider--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 t)
- (clojure-mode)
- (cider-mode -1)
- (cider-macroexpansion-mode 1)
- (current-buffer)))
-
-(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.
-
-\\{cider-macroexpansion-mode-map}"
- nil
- " Macroexpand"
- cider-macroexpansion-mode-map)
-
-(provide 'cider-macroexpansion)
-
-;;; cider-macroexpansion.el ends here
+++ /dev/null
-;;; cider-mode.el --- Minor mode for REPL interactions -*- lexical-binding: t -*-
-
-;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
-;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; 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-interaction)
-(require 'cider-test)
-(require 'cider-eldoc)
-(require 'cider-resolve)
-(require 'cider-doc)
-(require 'subr-x)
-(require 'cider-compat)
-
-(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 project name and host:port endpoint."
- (if-let ((current-connection (ignore-errors (cider-current-connection))))
- (with-current-buffer current-connection
- (concat
- cider-repl-type
- (when cider-mode-line-show-connection
- (format ":%s@%s:%s"
- (or (cider--project-name nrepl-project-dir) "<no project>")
- (pcase (car nrepl-endpoint)
- ("localhost" "")
- (x x))
- (cadr nrepl-endpoint)))))
- "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
-(defvar-local cider-last-clojure-buffer nil
- "A buffer-local variable holding the last Clojure source buffer.
-`cider-switch-to-last-clojure-buffer' uses this variable to jump
-back to last Clojure source buffer.")
-
-(defun cider-remember-clojure-buffer (buffer)
- "Try to remember the BUFFER from which the user jumps.
-The BUFFER needs to be a Clojure buffer and current major mode needs
-to be `cider-repl-mode'. The user can use `cider-switch-to-last-clojure-buffer'
-to jump back to the last Clojure source buffer."
- (when (and buffer
- (with-current-buffer buffer
- (derived-mode-p 'clojure-mode))
- (derived-mode-p 'cider-repl-mode))
- (setq cider-last-clojure-buffer buffer)))
-
-(defun cider--switch-to-repl-buffer (repl-buffer &optional set-namespace)
- "Select the REPL-BUFFER, when possible in an existing window.
-
-Hint: You can use `display-buffer-reuse-frames' and
-`special-display-buffer-names' to customize the frame in which
-the buffer should appear.
-
-When SET-NAMESPACE is t, sets the namespace in the REPL buffer to
-that of the namespace in the Clojure source buffer."
- (cider-ensure-connected)
- (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))))
- (cider-remember-clojure-buffer buffer)
- (goto-char (point-max))))
-
-(defun cider-switch-to-repl-buffer (&optional set-namespace)
- "Select the REPL buffer, when possible in an existing window.
-The buffer chosen is based on the file open in the current buffer.
-
-If the REPL buffer cannot be unambiguously determined, the REPL
-buffer is chosen based on the current connection buffer and a
-message raised informing the user.
-
-Hint: You can use `display-buffer-reuse-frames' and
-`special-display-buffer-names' to customize the frame in which
-the buffer should appear.
-
-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-buffer) set-namespace))
-
-(declare-function cider-load-buffer "cider-interaction")
-
-(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 `cider-switch-to-repl-buffer',
-so that it is very convenient to jump between a
-Clojure buffer and the REPL buffer."
- (interactive)
- (if (and (derived-mode-p 'cider-repl-mode)
- (buffer-live-p cider-last-clojure-buffer))
- (if cider-repl-display-in-current-window
- (pop-to-buffer-same-window cider-last-clojure-buffer)
- (pop-to-buffer cider-last-clojure-buffer))
- (message "Don't know the original Clojure 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."
- (interactive "P")
- (let ((origin-buffer (current-buffer)))
- (switch-to-buffer (cider-current-repl-buffer))
- (if clear-repl
- (cider-repl-clear-buffer)
- (cider-repl-clear-output))
- (switch-to-buffer origin-buffer)))
-
-\f
-;;; The menu-bar
-(defconst cider-mode-menu
- `("CIDER"
- ["Start a REPL" cider-jack-in
- :help "Starts an nREPL server (with lein, boot, or maven) and connects a REPL to it."]
- ["Connect to a REPL" cider-connect
- :help "Connects to a REPL that's already running."]
- ["Quit" cider-quit :active cider-connections]
- ["Restart" cider-restart :active cider-connections]
- ("Clojurescript"
- ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clojurescript
- :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL.
-Configure `cider-cljs-*-repl' to change the ClojureScript REPL to use for your build tool."]
- ["Create a ClojureScript REPL from a Clojure REPL" cider-create-sibling-cljs-repl]
- ["Form for launching a ClojureScript REPL via Leiningen" (customize-variable 'cider-cljs-lein-repl)]
- ["Form for launching a ClojureScript REPL via Boot" (customize-variable 'cider-cljs-boot-repl)]
- ["Form for launching a ClojureScript REPL via Gradle" (customize-variable 'cider-cljs-gradle-repl)])
- "--"
- ["Connection info" cider-display-connection-info
- :active cider-connections]
- ["Rotate default connection" cider-rotate-default-connection
- :active (cdr cider-connections)]
- ["Select any CIDER buffer" cider-selector]
- "--"
- ["Configure CIDER" (customize-group 'cider)]
- "--"
- ["A sip of CIDER" cider-drink-a-sip]
- ["View manual online" cider-view-manual]
- ["View refcard online" 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-connections
- ["Describe session" cider-describe-nrepl-session]
- ["Close session" cider-close-nrepl-session]
- ["Toggle message logging" nrepl-toggle-message-logging]))
- "Menu for CIDER mode")
-
-(defconst cider-mode-eval-menu
- '("CIDER Eval" :visible cider-connections
- ["Eval top-level sexp" cider-eval-defun-at-point]
- ["Eval current sexp" cider-eval-sexp-at-point]
- ["Eval last sexp" cider-eval-last-sexp]
- ["Eval selected region" cider-eval-region]
- ["Eval ns form" cider-eval-ns-form]
- "--"
- ["Interrupt evaluation" cider-interrupt]
- "--"
- ["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]
- ["Insert last sexp in REPL" cider-insert-last-sexp-in-repl]
- ["Eval top-level sexp to comment" cider-eval-defun-to-comment]
- "--"
- ["Load this buffer" cider-load-buffer]
- ["Load another file" cider-load-file]
- ["Load all project files" cider-load-all-project-ns]
- ["Refresh loaded code" cider-refresh]
- ["Run project (-main function)" cider-run])
- "Menu for CIDER mode eval commands.")
-
-(defconst cider-mode-interactions-menu
- `("CIDER Interactions" :visible cider-connections
- ["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 resource" cider-find-resource]
- ["Go back" cider-pop-back])
- ("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)])
- ("Browse"
- ["Browse namespace" cider-browse-ns]
- ["Browse all namespaces" cider-browse-ns-all]
- ["Browse REPL input history" cider-repl-history]
- ["Browse classpath" cider-classpath]
- ["Browse classpath entry" cider-open-classpath-entry]))
- "Menu for CIDER interactions.")
-
-(defconst cider-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "C-c C-d") 'cider-doc-map)
- (define-key map (kbd "M-.") #'cider-find-var)
- (define-key map (kbd "C-c C-.") #'cider-find-ns)
- (define-key map (kbd "M-,") #'cider-pop-back)
- (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-v") 'cider-eval-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 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 M-:") #'cider-read-and-eval)
- (define-key map (kbd "C-c C-u") #'cider-undef)
- (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-repl-set-ns)
- (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-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-r") #'cider-rotate-default-connection)
- (define-key map (kbd "C-c M-d") #'cider-display-connection-info)
- (define-key map (kbd "C-c C-x") #'cider-refresh)
- (define-key map (kbd "C-c C-q") #'cider-quit)
- (dolist (variable '(cider-mode-interactions-menu
- cider-mode-eval-menu
- cider-mode-menu))
- (easy-menu-do-define (intern (format "%s-open" variable))
- map
- (get variable 'variable-documentation)
- (cider--menu-add-help-strings (symbol-value variable))))
- map))
-
-;; This menu works as an easy entry-point into CIDER. Even if cider.el isn't
-;; loaded yet, this will be shown in Clojure buffers next to the "Clojure"
-;; menu.
-;;;###autoload
-(eval-after-load 'clojure-mode
- '(easy-menu-define cider-clojure-mode-menu-open clojure-mode-map
- "Menu for Clojure mode.
- This is displayed in `clojure-mode' buffers, if `cider-mode' is not active."
- `("CIDER" :visible (not cider-mode)
- ["Start a REPL" cider-jack-in
- :help "Starts an nREPL server (with lein, boot, or maven) and connects a REPL to it."]
- ["Connect to a REPL" cider-connect
- :help "Connects to a REPL that's already running."]
- ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clojurescript
- :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL.
- Configure `cider-cljs-lein-repl', `cider-cljs-boot-repl' and `cider-cljs-gradle-repl' to change the ClojureScript REPL to use."]
- "--"
- ["View manual online" cider-view-manual])))
-
-;;; Dynamic indentation
-(defcustom cider-dynamic-indentation t
- "Whether CIDER should aid Clojure(Script) indentation.
-If non-nil, CIDER uses runtime information (such as the \":style/indent\"
-metadata) to improve standard `clojure-mode' indentation.
-If nil, CIDER won't interfere with `clojure-mode's indentation.
-
-Toggling this variable only takes effect after a file is closed and
-re-visited."
- :type 'boolean
- :package-version '(cider . "0.11.0")
- :group 'cider)
-
-(defun cider--get-symbol-indent (symbol-name)
- "Return the indent metadata for SYMBOL-NAME in the current namespace."
- (let* ((ns (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-builtin-face'.
- `function': Any defined function gets the `font-lock-function-face'.
- `var': Any non-local var gets the `font-lock-variable-face'.
- `deprecated' (default): Any deprecated var gets the `cider-deprecated-face'
- face.
- `core' (default): Any symbol from clojure.core (face depends on type).
-
-The value can also be t, which means to font-lock as much as possible."
- :type '(choice (set :tag "Fine-tune font-locking"
- (const :tag "Any defined macro" macro)
- (const :tag "Any defined function" function)
- (const :tag "Any defined var" var)
- (const :tag "Any defined deprecated" deprecated)
- (const :tag "Any symbol from clojure.core" core))
- (const :tag "Font-lock as much as possible" t))
- :group 'cider
- :package-version '(cider . "0.10.0"))
-
-(defcustom cider-font-lock-reader-conditionals t
- "Apply font-locking to unused reader conditional expressions depending 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 (limit)
- "Helper function for `cider--anchored-search-suppressed-forms`.
-
-LIMIT is the same as the LIMIT in `cider--anchored-search-suppressed-forms`"
- (let ((expr (read (current-buffer)))
- (start (save-excursion (backward-sexp) (point))))
- (when (<= (point) limit)
- (forward-sexp)
- (if (not (string-equal (symbol-name expr) (concat ":" (cider-connection-type-for-buffer))))
- (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 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 ((result 'retry))
- (while (and (eq result 'retry) (<= (point) limit))
- (condition-case condition
- (setq result (cider--anchored-search-suppressed-forms-internal 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)
- (display-warning
- '(cider warning)
- (format
- (concat "Caught error during fontification while searching for forms\n"
- "that are suppressed by reader-conditionals. The error was: %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 the symbols in SYMBOLS-PLIST and CORE-PLIST."
- (let ((cider-font-lock-dynamically (if (eq cider-font-lock-dynamically t)
- '(function var macro core deprecated)
- cider-font-lock-dynamically))
- deprecated enlightened
- macros functions vars instrumented traced)
- (cl-labels ((handle-plist
- (plist)
- (let ((do-function (memq 'function cider-font-lock-dynamically))
- (do-var (memq 'var cider-font-lock-dynamically))
- (do-macro (memq 'macro cider-font-lock-dynamically))
- (do-deprecated (memq 'deprecated cider-font-lock-dynamically)))
- (while plist
- (let ((sym (pop plist))
- (meta (pop plist)))
- (pcase (nrepl-dict-get meta "cider.nrepl.middleware.util.instrument/breakfunction")
- (`nil nil)
- (`"#'cider.nrepl.middleware.debug/breakpoint-if-interesting"
- (push sym instrumented))
- (`"#'cider.nrepl.middleware.enlighten/light-form"
- (push sym enlightened)))
- ;; The ::traced keywords can be inlined by MrAnderson, so
- ;; we catch that case too.
- ;; FIXME: This matches values too, not just keys.
- (when (seq-find (lambda (k) (and (stringp k)
- (string-match (rx "clojure.tools.trace/traced" eos) k)))
- meta)
- (push sym traced))
- (when (and do-deprecated (nrepl-dict-get meta "deprecated"))
- (push sym deprecated))
- (cond ((and do-macro (nrepl-dict-get meta "macro"))
- (push sym macros))
- ((and do-function (nrepl-dict-get meta "arglists"))
- (push sym functions))
- (do-var (push sym vars))))))))
- (when (memq 'core cider-font-lock-dynamically)
- (let ((cider-font-lock-dynamically '(function var macro core deprecated)))
- (handle-plist core-plist)))
- (handle-plist symbols-plist))
- `(
- ,@(when macros
- `((,(concat (rx (or "(" "#'")) ; Can't take the value of macros.
- "\\(" (regexp-opt macros 'symbols) "\\)")
- 1 (cider--unless-local-match font-lock-keyword-face))))
- ,@(when functions
- `((,(regexp-opt functions 'symbols) 0
- (cider--unless-local-match font-lock-function-name-face))))
- ,@(when vars
- `((,(regexp-opt vars 'symbols) 0
- (cider--unless-local-match font-lock-variable-name-face))))
- ,@(when deprecated
- `((,(regexp-opt deprecated 'symbols) 0
- (cider--unless-local-match 'cider-deprecated-face) append)))
- ,@(when enlightened
- `((,(regexp-opt enlightened 'symbols) 0
- (cider--unless-local-match 'cider-enlightened-face) append)))
- ,@(when instrumented
- `((,(regexp-opt instrumented 'symbols) 0
- (cider--unless-local-match 'cider-instrumented-face) append)))
- ,@(when traced
- `((,(regexp-opt traced 'symbols) 0
- (cider--unless-local-match 'cider-traced-face) append))))))
-
-(defconst cider--static-font-lock-keywords
- (eval-when-compile
- `((,(regexp-opt '("#break" "#dbg" "#light") 'symbols) 0 font-lock-warning-face)))
- "Default expressions to highlight in CIDER mode.")
-
-(defvar-local cider--dynamic-font-lock-keywords nil)
-
-(defun cider-refresh-dynamic-font-lock (&optional ns)
- "Ensure that the current buffer has up-to-date font-lock rules.
-NS defaults to `cider-current-ns', and it can also be a dict describing the
-namespace itself."
- (interactive)
- (when (and cider-font-lock-dynamically
- font-lock-mode)
- (font-lock-remove-keywords nil cider--dynamic-font-lock-keywords)
- (when-let ((ns (or ns (cider-current-ns)))
- (symbols (cider-resolve-ns-symbols ns)))
- (setq-local cider--dynamic-font-lock-keywords
- (cider--compile-font-lock-keywords
- symbols (cider-resolve-ns-symbols (cider-resolve-core-ns))))
- (font-lock-add-keywords nil cider--dynamic-font-lock-keywords 'end))
- (cider--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)))
- (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'."
- (with-temp-buffer
- (cider-docview-render (current-buffer) sym info)
- (goto-char (point-max))
- (forward-line -1)
- (replace-regexp-in-string
- "[`']" "\\\\=\\&"
- (buffer-substring-no-properties (point-min) (1- (point))))))
-
-(defcustom cider-use-tooltips t
- "If non-nil, CIDER displays mouse-over tooltips."
- :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 help-at-pt-display-when-idle))
- (with-current-buffer obj
- (ignore-errors
- (save-excursion
- (goto-char pos)
- (when-let ((sym (cider-symbol-at-point)))
- (if (member sym (get-text-property (point) 'cider-locals))
- (concat (format "`%s' is a local" sym)
- (when cider--debug-mode
- (let* ((locals (nrepl-dict-get cider--debug-mode-response "locals"))
- (local-val (cadr (assoc sym locals))))
- (format " with value:\n%s" local-val))))
- (let* ((info (cider-sync-request:info sym))
- (candidates (nrepl-dict-get info "candidates")))
- (if candidates
- (concat "There were ambiguities resolving this symbol:\n\n"
- (mapconcat (lambda (x) (cider--docview-as-string sym x))
- candidates
- (concat "\n\n" (make-string 60 ?-) "\n\n")))
- (cider--docview-as-string sym info)))))))))))
-
-(defun cider--wrap-fontify-locals (func)
- "Return a function that will call FUNC after parsing local variables.
-The local variables are stored in a list under the `cider-locals' text
-property."
- (lambda (beg end &rest rest)
- (with-silent-modifications
- (remove-text-properties beg end '(cider-locals nil cider-block-dynamic-font-lock nil))
- (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
-(defvar x-gtk-use-system-tooltips)
-
-;;;###autoload
-(define-minor-mode cider-mode
- "Minor mode for REPL interaction from a Clojure buffer.
-
-\\{cider-mode-map}"
- nil
- cider-mode-line
- cider-mode-map
- (if cider-mode
- (progn
- (cider-eldoc-setup)
- (make-local-variable 'completion-at-point-functions)
- (add-to-list 'completion-at-point-functions
- #'cider-complete-at-point)
- (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)
- (setq next-error-function #'cider-jump-to-compilation-error))
- (mapc #'kill-local-variable '(completion-at-point-functions
- next-error-function
- x-gtk-use-system-tooltips
- font-lock-fontify-region-function
- clojure-get-indent-function))
- (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)
- (cider--font-lock-flush)))
-
-(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-overlays.el --- Managing CIDER overlays -*- lexical-binding: t; -*-
-
-;; Copyright © 2015-2017 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 'cider-compat)
-(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"))
-
-(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. 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 "End of line" t)
- (const :tag "Bottom of screen" nil)
- (const :tag "Both" both))
- :group 'cider
- :package-version '(cider . "0.10.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.
-Also see `cider-use-overlays'."
- :type '(choice (integer :tag "Duration in seconds")
- (const :tag "Until next command" command)
- (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 ()
- "Remove result overlay from current buffer.
-This function also removes itself from `post-command-hook'."
- (remove-hook 'post-command-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)
-
-(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 end of line.
-VALUE is used as the overlay's after-string property, meaning it is
-displayed at the end of the overlay. The overlay itself is placed from
-beginning to end of current line.
-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 over
- the entire line at that place (defaulting to `point'). 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)
- (line-end-position)))
- (display-string (format format value))
- (o nil))
- (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
- ;; 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))))
- (when-let ((win (get-buffer-window buffer)))
- ;; Left edge is visible.
- (when (and (<= (window-start win) (point))
- ;; In 24.3 `<=' is still a binary perdicate.
- (<= (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 &optional point)
- "Display the result VALUE of an interactive eval operation.
-VALUE is syntax-highlighted and displayed in the echo area.
-If POINT and `cider-use-overlays' are non-nil, it is also displayed in an
-overlay at the end of the line containing POINT.
-Note that, while POINT can be a number, it's preferable to be a marker, as
-that will better handle some corner cases where the original buffer is not
-focused."
- (let* ((font-value (if cider-result-use-clojure-font-lock
- (cider-font-lock-as-clojure value)
- value))
- (used-overlay (when (and point cider-use-overlays)
- (cider--make-result-overlay font-value
- :where point
- :duration cider-eval-result-duration))))
- (message
- "%s"
- (propertize (format "%s%s" cider-eval-result-prefix font-value)
- ;; The following hides the message from the echo-area, but
- ;; displays it in the Messages buffer. We only hide the message
- ;; if the user wants to AND if the overlay succeeded.
- 'invisible (and used-overlay
- (not (eq cider-use-overlays 'both)))))))
-
-\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
-(define-package "cider" "20170129.1941" "Clojure Interactive Development Environment that Rocks"
- '((emacs "24.4")
- (clojure-mode "5.6.0")
- (pkg-info "0.4")
- (queue "0.1.1")
- (spinner "1.7")
- (seq "2.16"))
- :url "http://www.github.com/clojure-emacs/cider" :keywords
- '("languages" "clojure" "cider"))
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
+++ /dev/null
-;;; cider-popup.el --- Creating and quitting popup buffers -*- lexical-binding: t; -*-
-
-;; Copyright © 2015-2017 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)
-(require 'cider-compat)
-
-(define-minor-mode cider-popup-buffer-mode
- "Mode for CIDER popup buffers"
- nil
- (" cider-tmp")
- '(("q" . cider-popup-buffer-quit-function)))
-
-(defvar-local cider-popup-buffer-quit-function #'cider-popup-buffer-quit
- "The function that is used to quit a temporary popup buffer.")
-
-(defun cider-popup-buffer-quit-function (&optional kill-buffer-p)
- "Wrapper to invoke the function `cider-popup-buffer-quit-function'.
-KILL-BUFFER-P is passed along."
- (interactive)
- (funcall cider-popup-buffer-quit-function kill-buffer-p))
-
-(defun cider-popup-buffer (name &optional select mode ancillary)
- "Create new popup buffer called NAME.
-If SELECT is non-nil, select the newly created window.
-If major MODE is non-nil, enable it for the popup buffer.
-If ANCILLARY is non-nil, the buffer is added to `cider-ancillary-buffers'
-and automatically removed when killed."
- (thread-first (cider-make-popup-buffer name mode ancillary)
- (cider-popup-buffer-display select)))
-
-(defun cider-popup-buffer-display (buffer &optional select)
- "Display BUFFER.
-If SELECT is non-nil, select the BUFFER."
- (let ((window (get-buffer-window buffer 'visible)))
- (when window
- (with-current-buffer buffer
- (set-window-point window (point))))
- ;; If the buffer we are popping up is already displayed in the selected
- ;; window, the below `inhibit-same-window' logic will cause it to be
- ;; displayed twice - so we early out in this case. Note that we must check
- ;; `selected-window', as async request handlers are executed in the context
- ;; of the current connection buffer (i.e. `current-buffer' is dynamically
- ;; bound to that).
- (unless (eq window (selected-window))
- ;; Non nil `inhibit-same-window' ensures that current window is not covered
- ;; Non nil `inhibit-switch-frame' ensures that the other frame is not selected
- ;; if that's where the buffer is being shown.
- (funcall (if select #'pop-to-buffer #'display-buffer)
- buffer `(nil . ((inhibit-same-window . ,pop-up-windows)
- (reusable-frames . visible))))))
- buffer)
-
-(defun cider-popup-buffer-quit (&optional kill)
- "Quit the current (temp) window.
-Bury its buffer using `quit-restore-window'.
-If prefix argument KILL is non-nil, kill the buffer instead of burying it."
- (interactive)
- (quit-restore-window (selected-window) (if kill 'kill 'append)))
-
-(defvar-local cider-popup-output-marker nil)
-
-(defvar cider-ancillary-buffers nil)
-
-(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)
- "Emit into BUFFER the provided VALUE optionally using FACE."
- ;; 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
- (if (fboundp 'add-face-text-property)
- (add-face-text-property 0 (length value-str) face nil value-str)
- (add-text-properties 0 (length value-str) (list 'face face) value-str)))
- (insert value-str))
- (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-repl-history.el --- REPL input history browser
-
-;; Copyright (c) 2017 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-compat)
-(require 'cider-popup)
-(require 'clojure-mode)
-(require 'derived)
-(require 'pulse)
-
-(defconst cider-repl-history-buffer "*cider-repl-history*")
-(add-to-list 'cider-ancillary-buffers cider-repl-history-buffer)
-
-(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))
- :group 'cider-repl-history
- :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)
- :group 'cider-repl-history
- :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")))
- :group 'cider-repl-history
- :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
- :group 'cider-repl-history
- :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
- :group 'cider-repl-history
- :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
- :group 'cider-repl-history
- :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))
- :group 'cider-repl-history
- :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
- :group 'cider-repl-history
- :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
- :group 'cider-repl-history
- :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
- :group 'cider-repl-history
- :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)
- :group 'cider-repl-history
- :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
- :group 'cider-repl-history
- :package-version '(cider . "0.15.0"))
-
-(defcustom cider-repl-history-display-duplicate-highest t
- "When `cider-repl-history-display-duplicates' is nil, then display highest (most recent) duplicate items in the command history."
- :type 'boolean
- :group 'cider-repl-history
- :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
- :group 'cider-repl-history
- :package-version '(cider . "0.15.0"))
-
-(defcustom cider-repl-history-hook nil
- "A list of functions to call after `cider-repl-history'."
- :type 'hook
- :group 'cider-repl-history
- :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
- :group 'cider-repl-history
- :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
- "The 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 ()
- "If variable `cider-repl-history-resize-window' is non-nil, resize the *cider-repl-history* 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, prompting with MSG; previous entry is default if USE-DEFAULT-P."
- (let* ((default (car regexp-history))
- (input
- (read-from-minibuffer
- (if (and default use-default-p)
- (format "%s for regexp (default `%s'): "
- msg
- default)
- (format "%s (regexp): " msg))
- 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 retun 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 and kill *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 the *cider-repl-history* buffer.
-
-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 the *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-highlighed-entry ()
- "Clear the highlighted entry, when one exists."
- (when cider-repl-history-previous-overlay
- (cl-assert (overlayp cider-repl-history-previous-overlay)
- t "not an overlay")
- (overlay-put cider-repl-history-previous-overlay 'face nil)))
-
-(defun cider-repl-history-update-highlighed-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-highlighed-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-highlighed-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)
- "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 udpated 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)))
- (when (not 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-highlighed-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))
-
-(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.
-
-\\{cider-repl-history-mode-map}"
- (define-key cider-repl-history-mode-map (kbd "n") 'cider-repl-history-forward)
- (define-key cider-repl-history-mode-map (kbd "p") 'cider-repl-history-previous)
- (define-key cider-repl-history-mode-map (kbd "SPC") 'cider-repl-history-insert-and-quit)
- (define-key cider-repl-history-mode-map (kbd "RET") 'cider-repl-history-insert-and-quit)
- (define-key cider-repl-history-mode-map [(mouse-2)] 'cider-repl-history-mouse-insert)
- (define-key cider-repl-history-mode-map (kbd "l") 'cider-repl-history-occur)
- (define-key cider-repl-history-mode-map (kbd "s") 'cider-repl-history-search-forward)
- (define-key cider-repl-history-mode-map (kbd "r") 'cider-repl-history-search-backward)
- (define-key cider-repl-history-mode-map (kbd "g") 'cider-repl-history-update)
- (define-key cider-repl-history-mode-map (kbd "q") 'cider-repl-history-quit)
- (define-key cider-repl-history-mode-map (kbd "U") 'cider-repl-history-undo-other-window)
- (define-key cider-repl-history-mode-map (kbd "?") 'describe-mode)
- (define-key cider-repl-history-mode-map (kbd "h") 'describe-mode))
-
-;;;###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 --- REPL interactions -*- lexical-binding: t -*-
-
-;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
-;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; 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:
-
-;; REPL interactions.
-
-;;; Code:
-
-(require 'cider-client)
-(require 'cider-doc)
-(require 'cider-test)
-(require 'cider-eldoc) ; for cider-eldoc-setup
-(require 'cider-common)
-(require 'subr-x)
-(require 'cider-compat)
-(require 'cider-util)
-(require 'cider-resolve)
-
-(require 'clojure-mode)
-(require 'easymenu)
-(require 'cl-lib)
-
-(eval-when-compile
- (defvar paredit-version)
- (defvar paredit-space-for-delimiter-predicates))
-
-\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."
- :group 'cider-repl)
-
-(defface cider-repl-stdout-face
- '((t (:inherit font-lock-string-face)))
- "Face for STDOUT output in the REPL buffer."
- :group 'cider-repl)
-
-(defface cider-repl-stderr-face
- '((t (:inherit font-lock-warning-face)))
- "Face for STDERR output in the REPL buffer."
- :group 'cider-repl
- :package-version '(cider . "0.6.0"))
-
-(defface cider-repl-input-face
- '((t (:bold t)))
- "Face for previous input in the REPL buffer."
- :group 'cider-repl)
-
-(defface cider-repl-result-face
- '((t ()))
- "Face for the result of an evaluation in the REPL buffer."
- :group 'cider-repl)
-
-(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))
- :group 'cider-repl)
-
-(defcustom cider-repl-display-in-current-window nil
- "Controls whether the REPL buffer is displayed in the current window."
- :type 'boolean
- :group 'cider-repl)
-
-(defcustom cider-repl-scroll-on-output t
- "Controls whether the REPL buffer auto-scrolls on new output.
-
-When set to t (the default), if the REPL buffer contains more lines than the
-size of the window, the buffer is automatically re-centered upon completion
-of evaluating an expression, so that the bottom line of output is on the
-bottom line of the window.
-
-If this is set to nil, no re-centering takes place."
- :type 'boolean
- :group 'cider-repl
- :package-version '(cider . "0.11.0"))
-
-(defcustom cider-repl-use-pretty-printing nil
- "Control whether the results in REPL are pretty-printed or not.
-The `cider-toggle-pretty-printing' command can be used to interactively
-change the setting's value."
- :type 'boolean
- :group 'cider-repl)
-
-(defcustom cider-repl-pretty-print-width nil
- "Control the width of pretty printing on the REPL.
-This sets the wrap point for pretty printing on the repl. If nil, it
-defaults to the variable `fill-column'."
- :type '(restricted-sexp :match-alternatives
- (integerp 'nil))
- :group 'cider-repl
- :package-version '(cider . "0.15.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
- :group 'cider-repl
- :package-version '(cider . "0.10.0"))
-
-(defcustom cider-repl-result-prefix ""
- "The prefix displayed in the REPL before a result value."
- :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
- :group 'cider-repl)
-
-(defcustom cider-repl-display-help-banner t
- "When non-nil a bit of help text will be displayed on REPL start."
- :type 'boolean
- :group 'cider-repl
- :package-version '(cider . "0.11.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. Other buffer's access it
-via `cider-current-connection'.")
-
-(defvar cider-mode)
-(declare-function cider-refresh-dynamic-font-lock "cider-mode")
-
-(defun cider-repl--state-handler (response)
- "Handle the server state contained in RESPONSE.
-Currently, this is only used to keep `cider-repl-type' updated."
- (with-demoted-errors "Error in `cider-repl--state-handler': %s"
- (when (member "state" (nrepl-dict-get response "status"))
- (nrepl-dbind-response response (repl-type changed-namespaces)
- (when repl-type
- (setq cider-repl-type repl-type))
- (unless (nrepl-dict-empty-p changed-namespaces)
- (setq cider-repl-ns-cache (nrepl-dict-merge cider-repl-ns-cache changed-namespaces))
- (dolist (b (buffer-list))
- (with-current-buffer b
- ;; Metadata changed, so signatures may have changed too.
- (setq cider-eldoc-last-symbol nil)
- (when (or cider-mode (derived-mode-p 'cider-repl-mode))
- (when-let ((ns-dict (or (nrepl-dict-get changed-namespaces (cider-current-ns))
- (let ((ns-dict (cider-resolve--get-in (cider-current-ns))))
- (when (seq-find (lambda (ns) (nrepl-dict-get changed-namespaces ns))
- (nrepl-dict-get ns-dict "aliases"))
- ns-dict)))))
- (cider-refresh-dynamic-font-lock ns-dict))))))))))
-
-(declare-function cider-default-err-handler "cider-interaction")
-
-(defun cider-repl-create (endpoint)
- "Create a REPL buffer and install `cider-repl-mode'.
-ENDPOINT is a plist as returned by `nrepl-connect'."
- ;; Connection might not have been set as yet. Please don't send requests here.
- (let* ((reuse-buff (not (eq 'new nrepl-use-this-as-repl-buffer)))
- (buff-name (nrepl-make-buffer-name nrepl-repl-buffer-name-template nil
- (plist-get endpoint :host)
- (plist-get endpoint :port)
- reuse-buff)))
- ;; when reusing, rename the buffer accordingly
- (when (and reuse-buff
- (not (equal buff-name nrepl-use-this-as-repl-buffer)))
- ;; uniquify as it might be Nth connection to the same endpoint
- (setq buff-name (generate-new-buffer-name buff-name))
- (with-current-buffer nrepl-use-this-as-repl-buffer
- (rename-buffer buff-name)))
- (with-current-buffer (get-buffer-create buff-name)
- (unless (derived-mode-p 'cider-repl-mode)
- (cider-repl-mode))
- (setq nrepl-err-handler #'cider-default-err-handler)
- (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))))
-
-(defun cider-repl-require-repl-utils ()
- "Require standard REPL util functions into the current REPL."
- (interactive)
- (cider-nrepl-request:eval
- "(when (clojure.core/resolve 'clojure.main/repl-requires)
- (clojure.core/map clojure.core/require clojure.main/repl-requires))"
- (lambda (_response) nil)))
-
-(declare-function cider-set-buffer-ns "cider-mode")
-(defun cider-repl-set-initial-ns (buffer)
- "Set the REPL BUFFER's initial namespace (by altering `cider-buffer-ns').
-This is \"user\" by default but can be overridden in apps like lein (:init-ns)."
- ;; we don't want to get a timeout during init
- (let ((nrepl-sync-request-timeout nil))
- (with-current-buffer buffer
- (let ((initial-ns (or (read
- (nrepl-dict-get
- (cider-nrepl-sync-request:eval "(str *ns*)")
- "value"))
- "user")))
- (cider-set-buffer-ns initial-ns)))))
-
-(defvar cider-current-clojure-buffer nil
- "This variable holds current buffer temporarily when connecting to a REPL.
-It is set to current buffer when `cider' or `cider-jack-in' is called.
-After the REPL buffer is created, the value of this variable is used
-to call `cider-remember-clojure-buffer'.")
-
-(declare-function cider-remember-clojure-buffer "cider-mode")
-
-(defun cider-repl-init (buffer &optional no-banner)
- "Initialize the REPL in BUFFER.
-BUFFER must be a REPL buffer with `cider-repl-mode' and a running
-client process connection. Unless NO-BANNER is non-nil, insert a banner."
- (cider-repl-set-initial-ns buffer)
- (cider-repl-require-repl-utils)
- (unless no-banner
- (cider-repl--insert-banner-and-prompt buffer))
- (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 (display-buffer buffer))
- ((pred identity) (pop-to-buffer buffer)))
- (cider-remember-clojure-buffer cider-current-clojure-buffer)
- buffer)
-
-(defun cider-repl--banner ()
- "Generate the welcome REPL buffer banner."
- (let ((host (cider--connection-host (current-buffer)))
- (port (cider--connection-port (current-buffer))))
- (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;"
- host
- port
- (cider--version)
- (cider--nrepl-version)
- (cider--clojure-version)
- (cider--java-version))))
-
-(defun cider-repl--help-banner ()
- "Generate the help banner."
- (substitute-command-keys
- "\n;; ======================================================================
-;; If you're new to CIDER it is highly recommended to go through its
-;; 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 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)
-;; * Enable `eldoc-mode' to display function & method signatures in the minibuffer.
-;; * 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 `cider-repl-clear-help-banner' command.
-;; You can disable it from appearing on start by setting
-;; `cider-repl-display-help-banner' to nil.
-;; ======================================================================
-"))
-
-(defun cider-repl--insert-banner-and-prompt (buffer)
- "Insert REPL banner and REPL prompt in BUFFER."
- (with-current-buffer buffer
- (when (zerop (buffer-size))
- (insert (propertize (cider-repl--banner) 'font-lock-face 'font-lock-comment-face))
- (when cider-repl-display-help-banner
- (insert (propertize (cider-repl--help-banner) 'font-lock-face 'font-lock-comment-face))))
- (goto-char (point-max))
- (cider-repl--mark-output-start)
- (cider-repl--mark-input-start)
- (cider-repl--insert-prompt cider-buffer-ns)))
-
-\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)))
-
-(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))
-
-(defun cider-repl--show-maximum-output ()
- "Put the end of the buffer at the bottom of the window."
- (when (and cider-repl-scroll-on-output (eobp))
- (let ((win (get-buffer-window (current-buffer) t)))
- (when win
- (with-selected-window win
- (set-window-point win (point-max))
- (recenter -1))))))
-
-(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"))
- :group 'cider-repl
- :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--flush-ansi-color-context ()
- "Flush ansi color context after printing.
-When there is a possible unfinished ansi control sequence,
- `ansi-color-context` maintains this list."
- (when (and ansi-color-context (stringp (cadr ansi-color-context)))
- (insert-before-markers (cadr ansi-color-context))
- (setq ansi-color-context nil)))
-
-(defun cider-repl--emit-output-at-pos (buffer string output-face position &optional bol)
- "Using BUFFER, insert STRING (applying to it OUTPUT-FACE) at POSITION.
-If BOL is non-nil insert at the beginning of line."
- (with-current-buffer buffer
- (save-excursion
- (cider-save-marker cider-repl-output-start
- (cider-save-marker cider-repl-output-end
- (goto-char position)
- ;; TODO: Review the need for bol
- (when (and bol (not (bolp))) (insert-before-markers "\n"))
- (insert-before-markers
- (ansi-color-apply (propertize string
- 'font-lock-face output-face
- 'rear-nonsticky '(font-lock-face))))
- (cider-repl--flush-ansi-color-context)
- (when (and (= (point) cider-repl-prompt-start-mark)
- (not (bolp)))
- (insert-before-markers "\n")
- (set-marker cider-repl-output-end (1- (point)))))))
- (cider-repl--show-maximum-output)))
-
-(defun cider-repl--emit-interactive-output (string face)
- "Emit STRING as interactive output using FACE."
- (with-current-buffer (cider-current-repl-buffer)
- (let ((pos (cider-repl--end-of-line-before-input-start))
- (string (replace-regexp-in-string "\n\\'" "" string)))
- (cider-repl--emit-output-at-pos (current-buffer) string face pos t))))
-
-(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-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 "\n "
- (cider--manual-button "More information" section-id)
- "."))))
-
-(defun cider-repl--emit-output (buffer string face &optional bol)
- "Using BUFFER, emit STRING font-locked with FACE.
-If BOL is non-nil, emit at the beginning of the line."
- (with-current-buffer buffer
- (cider-repl--emit-output-at-pos buffer string face cider-repl-input-start-mark bol)))
-
-(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-save-marker cider-repl-output-start
- (cider-save-marker cider-repl-output-end
- (cider-repl--insert-prompt cider-buffer-ns))))
- (cider-repl--show-maximum-output)))
-
-(defun cider-repl-emit-result (buffer string &optional bol)
- "Emit into BUFFER the result STRING and mark it as an evaluation result.
-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
- (cider-save-marker cider-repl-output-end
- (goto-char cider-repl-input-start-mark)
- (when (and bol (not (bolp)))
- (insert-before-markers "\n"))
- (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))))))
- (cider-repl--show-maximum-output)))
-
-(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-handler (buffer)
- "Make an nREPL evaluation handler for the REPL BUFFER."
- (nrepl-make-response-handler buffer
- (lambda (buffer value)
- (cider-repl-emit-result buffer value t))
- (lambda (buffer out)
- (cider-repl-emit-stdout buffer out))
- (lambda (buffer err)
- (cider-repl-emit-stderr buffer err))
- (lambda (buffer)
- (cider-repl-emit-prompt buffer))
- nrepl-err-handler
- (lambda (buffer pprint-out)
- (cider-repl-emit-result buffer pprint-out nil))))
-
-(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"))
- (goto-char (point-max))
- (let ((end (point))) ; end of input, without the newline
- (cider-repl--add-to-input-history (buffer-substring cider-repl-input-start-mark end))
- (when newline
- (insert "\n")
- (cider-repl--show-maximum-output))
- (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 (cider-repl--current-input))
- (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)
- (unless (or (not cider-repl-use-pretty-printing)
- (string-match-p "\\`[ \t\r\n]*\\'" input))
- (cider--nrepl-pprint-request-plist (cider--pretty-print-width))))))
-
-(defun cider-repl-return (&optional end-of-input)
- "Evaluate the current input string, or insert a newline.
-Send the current input ony 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--recenter-if-needed))
- ((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--recenter-if-needed ()
- "Make sure that the point is visible."
- (unless (pos-visible-in-window-p (point-max))
- (save-excursion
- (goto-char (point-max))
- (recenter -1))))
-
-(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 all open parenthesized 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--pretty-print-width ()
- "Returns the width to use for pretty-printing."
- (or cider-repl-pretty-print-width
- fill-column
- 80))
-
-(defun cider-repl-switch-to-other ()
- "Switch between the Clojure and ClojureScript REPLs for the current project."
- (interactive)
- (if-let (other-connection (cider-other-connection))
- (switch-to-buffer other-connection)
- (message "There's no other REPL for the current project")))
-
-(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 ()
- "Delete the output generated by the Clojure process."
- (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--end-of-line-before-input-start ()
- "Return the position of the end of the line preceding the beginning of input."
- (1- (previous-single-property-change cider-repl-input-start-mark 'field nil
- (1+ (point-min)))))
-
-(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 ((start (save-excursion
- (cider-repl-previous-prompt)
- (ignore-errors (forward-sexp))
- (forward-line)
- (point)))
- (end (cider-repl--end-of-line-before-input-start)))
- (when (< start end)
- (let ((inhibit-read-only t))
- (cider-repl--clear-region start end)
- (save-excursion
- (goto-char start)
- (insert
- (propertize ";; output cleared" '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 implemetation 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 or cljx 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-connections
- (lambda (connection)
- (cider-nrepl-request:eval (format "(in-ns '%s)" ns)
- (cider-repl-switch-ns-handler connection)))
- :both))
-
-\f
-;;;;; History
-
-(defcustom cider-repl-wrap-history nil
- "T to wrap history around when the end is reached."
- :type 'boolean
- :group 'cider-repl)
-
-;; 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
- :group 'cider-repl)
-
-(defcustom cider-repl-history-file nil
- "File to save the persistent REPL history to."
- :type 'string
- :safe 'stringp
- :group 'cider-repl)
-
-(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)
- :group 'cider-repl)
-
-(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-restart "cider-interaction")
-(declare-function cider-quit "cider-interaction")
-(declare-function cider-toggle-trace-ns "cider-interaction")
-(declare-function cider-undef "cider-interaction")
-(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-interaction")
-(declare-function cider-refresh "cider-interaction")
-(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 "ns" #'cider-repl-set-ns)
-(cider-repl-add-shortcut "toggle-pretty" #'cider-repl-toggle-pretty-printing)
-(cider-repl-add-shortcut "browse-ns" (lambda () (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-refresh)
-(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-report" #'cider-test-show-report)
-(cider-repl-add-shortcut "run" #'cider-run)
-(cider-repl-add-shortcut "conn-info" #'cider-display-connection-info)
-(cider-repl-add-shortcut "conn-rotate" #'cider-rotate-default-connection)
-(cider-repl-add-shortcut "hasta la vista" #'cider-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)
-(cider-repl-add-shortcut "version" #'cider-version)
-
-(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 (gethash command cider-repl-shortcuts))
- (error "Unknown command %S. Available commands: %s"
- command-func
- (mapconcat 'identity (cider-repl--available-shortcuts) ", "))))
- (error "No command selected")))))
-
-\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-region "cider-interaction")
-(declare-function cider-eval-last-sexp "cider-interaction")
-(declare-function cider-refresh "cider-interaction")
-(declare-function cider-toggle-trace-ns "cider-interaction")
-(declare-function cider-toggle-trace-var "cider-interaction")
-(declare-function cider-find-resource "cider-interaction")
-(declare-function cider-restart "cider-interaction")
-(declare-function cider-find-ns "cider-interaction")
-(declare-function cider-switch-to-last-clojure-buffer "cider-mode")
-
-(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 "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-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-display-connection-info)
- (define-key map (kbd "C-c C-q") #'cider-quit)
- (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-refresh)
- (define-key map (kbd "C-x C-e") #'cider-eval-last-sexp)
- (define-key map (kbd "C-c C-r") #'cider-eval-region)
- (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 resource" cider-find-resource]
- ["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-refresh]
- "--"
- ["Set REPL ns" cider-repl-set-ns]
- ["Toggle pretty printing" cider-repl-toggle-pretty-printing]
- "--"
- ["Browse classpath" cider-classpath]
- ["Browse classpath entry" cider-open-classpath-entry]
- ["Browse namespace" cider-browse-ns]
- ["Browse all namespaces" cider-browse-ns-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]
- ["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-display-connection-info]
- "--"
- ["Close ancillary buffers" cider-close-ancillary-buffers]
- ["Quit" cider-quit]
- ["Restart" cider-restart]
- "--"
- ["A sip of CIDER" cider-drink-a-sip]
- ["View manual online" cider-view-manual]
- ["View refcard online" cider-view-refcard]
- ["Report a bug" cider-report-bug]
- ["Version info" cider-version]))
- 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-interaction")
-(defvar cider--static-font-lock-keywords)
-
-(define-derived-mode cider-repl-mode fundamental-mode "REPL"
- "Major mode for Clojure REPL interactions.
-
-\\{cider-repl-mode-map}"
- (clojure-mode-variables)
- (setq-local lisp-indent-function #'clojure-indent-function)
- (setq-local indent-line-function #'lisp-indent-line)
- (clojure-font-lock-setup)
- (font-lock-add-keywords nil cider--static-font-lock-keywords)
- (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))
- (make-local-variable 'completion-at-point-functions)
- (add-to-list 'completion-at-point-functions
- #'cider-complete-at-point)
- (set-syntax-table cider-repl-mode-syntax-table)
- (cider-eldoc-setup)
- ;; At the REPL, we define beginning-of-defun and end-of-defun to be
- ;; the start of the previous prompt or next prompt respectively.
- ;; Notice the interplay with `cider-repl-beginning-of-defun'.
- (setq-local beginning-of-defun-function #'cider-repl-mode-beginning-of-defun)
- (setq-local end-of-defun-function #'cider-repl-mode-end-of-defun)
- (setq-local prettify-symbols-alist clojure--prettify-symbols-alist)
- ;; apply dir-local variables to REPL buffers
- (hack-dir-local-variables-non-file-buffer)
- (when cider-repl-history-file
- (cider-repl-history-load cider-repl-history-file)
- (add-hook 'kill-buffer-hook #'cider-repl-history-just-save t t)
- (add-hook 'kill-emacs-hook #'cider-repl-history-just-save))
- (add-hook 'paredit-mode-hook (lambda () (clojure-paredit-setup cider-repl-mode-map))))
-
-(provide 'cider-repl)
-
-;;; cider-repl.el ends here
+++ /dev/null
-;;; cider-resolve.el --- Resolve clojure symbols according to current nREPL connection
-
-;; Copyright © 2015-2017 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!" "#'clojure.tools.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 cider-connections
- (with-current-buffer (cider-current-connection)
- (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 ((referal (cider-resolve--get-in ns "refers" name)))
- (cider-resolve-var ns referal)
- ;; 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 `cider-repl-type'."
- (when (cider-connected-p)
- (with-current-buffer (cider-current-connection)
- (cider-resolve--get-in (if (equal 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-2017 Bozhidar Batsov and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; 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-interaction)
-(require 'clojure-mode)
-(require 'easymenu)
-
-(defvar cider-clojure-interaction-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map clojure-mode-map)
- (define-key map (kbd "C-j") #'cider-eval-print-last-sexp)
- (define-key map [remap paredit-newline] #'cider-eval-print-last-sexp)
- (easy-menu-define cider-clojure-interaction-mode-menu map
- "Menu for Clojure Interaction mode"
- '("Clojure Interaction"
- (["Eval and print last sexp" #'cider-eval-print-last-sexp]
- "--"
- ["Reset" #'cider-scratch-reset]
- "--"
- ["Set buffer connection" #'cider-assoc-buffer-with-connection]
- ["Toggle buffer connection" #'cider-toggle-buffer-connection]
- ["Reset buffer connection" #'cider-clear-buffer-local-connection])))
- map))
-
-(defconst cider-scratch-buffer-name "*cider-scratch*")
-
-(push cider-scratch-buffer-name cider-ancillary-buffers)
-
-;;;###autoload
-(defun cider-scratch ()
- "Go to the scratch buffer named `cider-scratch-buffer-name'."
- (interactive)
- (pop-to-buffer (cider-find-or-create-scratch-buffer)))
-
-(defun cider-find-or-create-scratch-buffer ()
- "Find or create the scratch buffer."
- (or (get-buffer cider-scratch-buffer-name)
- (cider-create-scratch-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}")
-
-(defun cider--scratch-insert-welcome-message ()
- "Insert the welcome message for the scratch buffer."
- (insert ";; This buffer is for Clojure experiments and evaluation.\n"
- ";; Press C-j to evaluate the last expression.\n\n"))
-
-(defun cider-create-scratch-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-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
-;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; 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-interaction)
-(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'.")
-
-(defun cider--recently-visited-buffer (mode)
- "Return the most recently visited buffer, deriving its `major-mode' from MODE.
-Only considers buffers that are not already visible."
- (cl-loop for buffer in (buffer-list)
- when (and (with-current-buffer buffer
- (derived-mode-p mode))
- ;; names starting with space are considered hidden by Emacs
- (not (string-match-p "^ " (buffer-name buffer)))
- (null (get-buffer-window buffer 'visible)))
- return buffer
- finally (error "Can't find unshown buffer in %S" mode)))
-
-;;;###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 then
-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 (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--recently-visited-buffer 'clojure-mode))
-
-(def-cider-selector-method ?e
- "Most recently visited emacs-lisp-mode buffer."
- (cider--recently-visited-buffer 'emacs-lisp-mode))
-
-(def-cider-selector-method ?q "Abort."
- (top-level))
-
-(def-cider-selector-method ?r
- "Current REPL buffer."
- (cider-current-repl-buffer))
-
-(def-cider-selector-method ?n
- "Connections browser buffer."
- (cider-connection-browser)
- cider--connection-browser-buffer-name)
-
-(def-cider-selector-method ?m
- "Current connection's *nrepl-messages* buffer."
- (cider-current-messages-buffer))
-
-(def-cider-selector-method ?x
- "*cider-error* buffer."
- cider-error-buffer)
-
-(def-cider-selector-method ?d
- "*cider-doc* buffer."
- cider-doc-buffer)
-
-(declare-function cider-find-or-create-scratch-buffer "cider-scratch")
-(def-cider-selector-method ?s
- "*cider-scratch* buffer."
- (cider-find-or-create-scratch-buffer))
-
-(provide 'cider-selector)
-
-;;; cider-selector.el ends here
+++ /dev/null
-;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*-
-
-;; Copyright © 2014-2017 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 'cl-lib)
-(require 'cider-popup)
-(require 'button)
-(require 'easymenu)
-(require 'cider-common)
-(require 'subr-x)
-(require 'cider-compat)
-(require 'cider-client)
-(require 'cider-util)
-
-(require 'seq)
-
-;; 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
- :group 'cider-stacktrace
- :package-version '(cider . "0.7.0"))
-
-(defcustom cider-stacktrace-default-filters '(tooling dup)
- "Frame types to omit from initial stacktrace display."
- :type 'list
- :group 'cider-stacktrace
- :package-version '(cider . "0.6.0"))
-
-(defcustom cider-stacktrace-print-length 50
- "Set the maximum length of sequences in displayed cause data.
-
-This sets the value of Clojure's `*print-length*` when pretty printing the
-`ex-data` map for exception causes in the stacktrace that are instances of
-`IExceptionInfo`.
-
-Be advised that setting this to `nil` will cause the attempted printing of
-infinite data structures."
- :type '(choice integer (const nil))
- :group 'cider-stacktrace
- :package-version '(cider . "0.9.0"))
-
-(defcustom cider-stacktrace-print-level 50
- "Set the maximum level of nesting in displayed cause data.
-
-This sets the value of Clojure's `*print-level*` when pretty printing the
-`ex-data` map for exception causes in the stacktrace that are instances of
-`IExceptionInfo`.
-
-Be advised that setting this to `nil` will cause the attempted printing of
-cyclical data structures."
- :type '(choice integer (const nil))
- :group 'cider-stacktrace
- :package-version '(cider . "0.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-prior-filters nil)
-(defvar-local cider-stacktrace-cause-visibility nil)
-
-(defconst cider-error-buffer "*cider-error*")
-(add-to-list 'cider-ancillary-buffers cider-error-buffer)
-
-(defcustom cider-stacktrace-suppressed-errors '()
- "A set of errors that won't make the stacktrace buffer 'pop-over' your active window.
-The error types are represented as strings."
- :type 'list
- :group 'cider-stacktrace
- :package-version '(cider . "0.12.0"))
-
-;; Faces
-
-(defface cider-stacktrace-error-class-face
- '((t (:inherit font-lock-warning-face)))
- "Face for exception class names"
- :group 'cider-stacktrace
- :package-version '(cider . "0.6.0"))
-
-(defface cider-stacktrace-error-message-face
- '((t (:inherit font-lock-doc-face)))
- "Face for exception messages"
- :group 'cider-stacktrace
- :package-version '(cider . "0.7.0"))
-
-(defface cider-stacktrace-filter-shown-face
- '((t (:inherit button :underline t :weight normal)))
- "Face for filter buttons representing frames currently visible"
- :group 'cider-stacktrace
- :package-version '(cider . "0.6.0"))
-
-(defface cider-stacktrace-filter-hidden-face
- '((t (:inherit button :underline nil :weight normal)))
- "Face for filter buttons representing frames currently filtered out"
- :group 'cider-stacktrace
- :package-version '(cider . "0.6.0"))
-
-(defface cider-stacktrace-face
- '((t (:inherit default)))
- "Face for stack frame text"
- :group 'cider-stacktrace
- :package-version '(cider . "0.6.0"))
-
-(defface cider-stacktrace-ns-face
- '((t (:inherit font-lock-comment-face)))
- "Face for stack frame namespace name"
- :group 'cider-stacktrace
- :package-version '(cider . "0.6.0"))
-
-(defface cider-stacktrace-fn-face
- '((t (:inherit default :weight bold)))
- "Face for stack frame function name"
- :group 'cider-stacktrace
- :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."
- :group 'cider-stacktrace
- :package-version '(cider . "0.12.0"))
-
-(defface cider-stacktrace-suppressed-button-face
- '((((type graphic))
- :box (:line-width 3 :style pressed-button)
- :inherit widget-inactive-face)
- (t :inverse-video t))
- "A button with this face represents a suppressed error type."
- :group 'cider-stacktrace
- :package-version '(cider . "0.12.0"))
-
-;; Colors & Theme Support
-
-(defvar cider-stacktrace-frames-background-color
- (cider-scale-background-color)
- "Background color for stacktrace frames.")
-
-(defadvice enable-theme (after cider-stacktrace-adapt-to-theme activate)
- "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 "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]
- ["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}"
- (setq buffer-read-only t)
- (when cider-special-mode-truncate-lines
- (setq-local truncate-lines t))
- (setq-local electric-indent-chars nil)
- (setq-local cider-stacktrace-prior-filters 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)))
-
-
-;; Stacktrace filtering
-
-(defun cider-stacktrace-indicate-filters (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."
- (with-current-buffer cider-error-buffer
- (save-excursion
- (goto-char (point-min))
- (let ((inhibit-read-only t)
- (get-face (lambda (hide)
- (if hide
- 'cider-stacktrace-filter-hidden-face
- 'cider-stacktrace-filter-shown-face))))
- ;; 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 (funcall get-face (if filter
- (member filter filters)
- 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-apply-filters (filters)
- "Set visibility on stack frames using FILTERS.
-Update `cider-stacktrace-hidden-frame-count' and indicate filters applied.
-Currently collapsed stacktraces are ignored, and do not contribute to the
-hidden count."
- (with-current-buffer cider-error-buffer
- (save-excursion
- (goto-char (point-min))
- (let ((inhibit-read-only t)
- (hidden 0))
- (while (not (eobp))
- (unless (get-text-property (point) 'collapsed)
- (let* ((flags (get-text-property (point) 'flags))
- (hide (if (seq-intersection filters flags) t nil)))
- (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 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 element 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 element ERROR-TYPE from the `cider-stacktrace-suppressed-errors' set."
- (setq cider-stacktrace-suppressed-errors
- (remove error-type cider-stacktrace-suppressed-errors)))
-
-(defun cider-stacktrace-suppressed-error-p (error-type)
- "Return non-nil if element ERROR-TYPE is a member of the `cider-stacktrace-suppressed-errors' set."
- (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', optionally to LEVEL.
-If LEVEL is not specified, 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-all ()
- "Reset `cider-stacktrace-filters' if present; otherwise restore prior filters."
- (interactive)
- (when cider-stacktrace-filters
- (setq-local cider-stacktrace-prior-filters
- cider-stacktrace-filters))
- (cider-stacktrace-apply-filters
- (setq cider-stacktrace-filters
- (unless cider-stacktrace-filters ; when current filters are nil,
- cider-stacktrace-prior-filters)))) ; reenable prior filter set
-
-(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-java ()
- "Toggle display of Java stack frames."
- (interactive)
- (cider-stacktrace-toggle 'java))
-
-(defun cider-stacktrace-toggle-clj ()
- "Toggle display of Clojure stack frames."
- (interactive)
- (cider-stacktrace-toggle 'clj))
-
-(defun cider-stacktrace-toggle-repl ()
- "Toggle display of REPL stack frames."
- (interactive)
- (cider-stacktrace-toggle 'repl))
-
-(defun cider-stacktrace-toggle-tooling ()
- "Toggle display of Tooling stack frames (compiler, nREPL middleware, etc)."
- (interactive)
- (cider-stacktrace-toggle 'tooling))
-
-(defun cider-stacktrace-toggle-duplicates ()
- "Toggle display of stack frames that are duplicates of their descendents."
- (interactive)
- (cider-stacktrace-toggle 'dup))
-
-;; Text button functions
-
-(defun cider-stacktrace-filter (button)
- "Apply filter(s) indicated by the BUTTON."
- (with-temp-message "Filters may also be toggled with the keyboard."
- (let ((flag (button-get button 'filter)))
- (if flag
- (cider-stacktrace-toggle flag)
- (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 the `cider-stacktrace-suppressed-errors' set."
- (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)))
- ;; give priority to `info` files as `info` returns full paths.
- (info (nrepl-dict-put info "file" (or (nrepl-dict-get info "file")
- (button-get button 'file)))))
- (cider--jump-to-loc-from-info info t)
- (forward-line line-shift)
- (back-to-indentation)))
-
-(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
-
-(defun cider-stacktrace-emit-indented (text indent &optional fill)
- "Insert TEXT, and INDENT and optionally FILL the entire block."
- (let ((beg (point)))
- (insert text)
- (goto-char beg)
- (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 filters)
- "Emit into BUFFER toggle buttons for each of the FILTERS."
- (with-current-buffer buffer
- (insert " Show: ")
- (dolist (filter filters)
- (insert-text-button (car filter)
- 'filter (cadr filter)
- 'follow-link t
- 'action 'cider-stacktrace-filter
- 'help-echo (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 into BUFFER toggle buttons for each of the ERROR-TYPES leading this stacktrace buffer."
- (with-current-buffer buffer
- (when error-types
- (insert " This is an unexpected CIDER middleware error.\n Please submit a bug report via `")
- (insert-text-button "M-x cider-report-bug"
- 'follow-link t
- 'action (lambda (_button) (cider-report-bug))
- 'help-echo "Report bug to the CIDER team.")
- (insert "`.\n\n")
- (insert "\
- If these stacktraces are occuring 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 (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
- (nrepl-dbind-response frame (file line flags class method name var ns fn)
- (let ((flags (mapcar 'intern flags))) ; strings -> symbols
- (insert-text-button (format "%26s:%5d %s/%s"
- (if (member 'repl flags) "REPL" file) line
- (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 "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)))
- (insert "\n")))))
-
-(declare-function cider-jump-to "cider-interaction")
-
-(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))))
- (insert (propertize (format " at (%d:%d)" line column)
- 'font-lock-face message-face))))))
-
-(defun cider-stacktrace-render-cause (buffer cause num note)
- "Emit into BUFFER the CAUSE NUM, exception class, message, data, and NOTE."
- (with-current-buffer buffer
- (nrepl-dbind-response cause (class message data stacktrace)
- (let ((indent " ")
- (class-face 'cider-stacktrace-error-class-face)
- (message-face 'cider-stacktrace-error-message-face))
- (cider-propertize-region `(cause ,num)
- ;; Detail level 0: exception class
- (cider-propertize-region '(detail 0)
- (insert (format "%d. " num)
- (propertize note 'font-lock-face 'font-lock-comment-face) " "
- (propertize class 'font-lock-face class-face)
- "\n"))
- ;; Detail level 1: message + ex-data
- (cider-propertize-region '(detail 1)
- (if (equal class "clojure.lang.Compiler$CompilerException")
- (cider-stacktrace-render-compile-error buffer cause)
- (cider-stacktrace-emit-indented
- (propertize (or message "(No message)")
- 'font-lock-face message-face) indent t))
- (insert "\n")
- (when data
- (cider-stacktrace-emit-indented
- (cider-font-lock-as-clojure data) indent nil)))
- ;; Detail level 2: stacktrace
- (cider-propertize-region '(detail 2)
- (insert "\n")
- (let ((beg (point))
- (bg `(:background ,cider-stacktrace-frames-background-color)))
- (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))
- (goto-char (next-single-property-change (point) 'flags)))))))))
-
-(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
- `(("Clojure" clj) ("Java" java) ("REPL" repl)
- ("Tooling" tooling) ("Duplicates" dup) ("All" ,nil)))
- (insert "\n")
- ;; Option to suppress internal/middleware errors
- (when error-types
- (cider-stacktrace-render-suppression-toggle buffer error-types)
- (insert "\n\n"))
- ;; Stacktrace exceptions & frames
- (let ((num (length causes)))
- (dolist (cause causes)
- (let ((note (if (= num (length causes)) "Unhandled" "Caused by")))
- (cider-stacktrace-render-cause buffer cause num note)
- (setq num (1- num))))))
- (cider-stacktrace-initialize causes)
- (font-lock-refresh-defaults)))
-
-(provide 'cider-stacktrace)
-
-;;; cider-stacktrace.el ends here
+++ /dev/null
-;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*-
-
-;; Copyright © 2014-2017 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 'cider-common)
-(require 'cider-client)
-(require 'cider-popup)
-(require 'cider-stacktrace)
-(require 'subr-x)
-(require 'cider-compat)
-(require 'cider-overlays)
-
-(require 'button)
-(require 'easymenu)
-(require 'seq)
-
-;;; 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
- :group 'cider-test
- :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
- :group 'cider-test
- :package-version '(cider . "0.9.0"))
-
-(defcustom cider-test-defining-forms '("deftest" "defspec")
- "Forms that define individual tests.
-CIDER considers the top-level form around point to define a test if the
-form starts with one of these forms.
-Add to this list to have CIDER recognize additional test defining macros."
- :type '(repeat string)
- :group 'cider-test
- :package-version '(cider . "0.15.0"))
-
-(defvar cider-test-last-summary nil
- "The summary of the last run test.")
-
-(defvar cider-test-last-results nil
- "The results of the last run test.")
-
-(defconst cider-test-report-buffer "*cider-test-report*"
- "Buffer name in which to display test reports.")
-(add-to-list 'cider-ancillary-buffers cider-test-report-buffer)
-
-
-;;; Faces
-
-(defface cider-test-failure-face
- '((((class color) (background light))
- :background "orange red")
- (((class color) (background dark))
- :background "firebrick"))
- "Face for failed tests."
- :group 'cider-test
- :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."
- :group 'cider-test
- :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."
- :group 'cider-test
- :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.")
-
-(defadvice enable-theme (after cider-test-adapt-to-theme activate)
- "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-g") #'cider-test-rerun-test)
- (define-key map (kbd "C-n") #'cider-test-run-ns-tests)
- (define-key map (kbd "C-l") #'cider-test-run-loaded-tests)
- (define-key map (kbd "C-p") #'cider-test-run-project-tests)
- (define-key map (kbd "C-b") #'cider-test-show-report)
- ;; Single-key bindings defined last for display in menu
- (define-key map (kbd "r") #'cider-test-rerun-failed-tests)
- (define-key map (kbd "t") #'cider-test-run-test)
- (define-key map (kbd "g") #'cider-test-rerun-test)
- (define-key map (kbd "n") #'cider-test-run-ns-tests)
- (define-key map (kbd "l") #'cider-test-run-loaded-tests)
- (define-key map (kbd "p") #'cider-test-run-project-tests)
- (define-key map (kbd "b") #'cider-test-show-report)
- map))
-
-(defconst cider-test-menu
- '("Test"
- ["Run test" cider-test-run-test]
- ["Run namespace tests" cider-test-run-ns-tests]
- ["Run all loaded tests" cider-test-run-loaded-tests]
- ["Run all project tests" cider-test-run-project-tests]
- ["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 "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 loaded tests" cider-test-run-loaded-tests]
- ["Run all project tests" cider-test-run-project-tests]
- "--"
- ["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 electric-indent-chars nil))
-
-;; 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))))))
-
-(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
- (append
- (list "op" "test-stacktrace"
- "ns" ns "var" var "index" index)
- (when (cider--pprint-fn)
- (list "pprint-fn" (cider--pprint-fn)))
- (when cider-stacktrace-print-length
- (list "print-length" cider-stacktrace-print-length))
- (when cider-stacktrace-print-level
- (list "print-level" cider-stacktrace-print-level)))
- (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)
- (reverse causes))))))))))
-
-(defun cider-test-stacktrace ()
- "Display stacktrace for the erring test at point."
- (interactive)
- (let ((ns (get-text-property (point) 'ns))
- (var (get-text-property (point) 'var))
- (index (get-text-property (point) 'index))
- (err (get-text-property (point) 'error)))
- (if (and err ns var index)
- (cider-test-stacktrace-for ns var index)
- (message "No test error at point"))))
-
-
-;;; Expected vs actual diffing
-
-(defvar cider-test-ediff-buffers nil
- "The expected/actual buffers used to display diff.")
-
-(defun cider-test-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 (get-text-property (point) 'expected))
- (actual (get-text-property (point) 'actual)))
- (if (and expected actual)
- (let ((expected-buffer (generate-new-buffer " *expected*"))
- (actual-buffer (generate-new-buffer " *actual*")))
- (with-current-buffer expected-buffer
- (insert expected)
- (clojure-mode))
- (with-current-buffer actual-buffer
- (insert actual)
- (goto-char (point-min))
- (forward-char)
- (forward-sexp)
- (forward-whitespace 1)
- (let ((beg (point)))
- (forward-sexp)
- (let ((actual* (buffer-substring beg (point))))
- (erase-buffer)
- (insert actual*)))
- (clojure-mode))
- (apply 'ediff-buffers
- (setq cider-test-ediff-buffers
- (list (buffer-name expected-buffer)
- (buffer-name actual-buffer)))))
- (message "No test failure at point"))))
-
-(defun cider-test-ediff-cleanup ()
- "Cleanup expected/actual buffers used for diff."
- (interactive)
- (mapc (lambda (b) (when (get-buffer b) (kill-buffer b)))
- cider-test-ediff-buffers))
-
-(add-hook 'ediff-cleanup-hook #'cider-test-ediff-cleanup)
-
-
-;;; Report rendering
-
-(defun cider-test-type-face (type)
- "Return the font lock face for the test result TYPE."
- (pcase type
- ("pass" 'cider-test-success-face)
- ("fail" 'cider-test-failure-face)
- ("error" 'cider-test-error-face)
- (_ 'default)))
-
-(defun cider-test-type-simple-face (type)
- "Return a face for the test result TYPE using the highlight color as foreground."
- (let ((face (cider-test-type-face type)))
- `(:foreground ,(face-attribute face :background))))
-
-(defun cider-test-render-summary (buffer summary)
- "Emit into BUFFER the report SUMMARY statistics."
- (with-current-buffer buffer
- (nrepl-dbind-response summary (ns var test pass fail error)
- (insert (format "Tested %d namespaces\n" ns))
- (insert (format "Ran %d assertions, in %d test functions\n" test var))
- (unless (zerop fail)
- (cider-insert (format "%d failures" fail) 'cider-test-failure-face t))
- (unless (zerop error)
- (cider-insert (format "%d errors" error) 'cider-test-error-face t))
- (when (zerop (+ fail error))
- (cider-insert (format "%d passed" pass) 'cider-test-success-face t))
- (insert "\n\n"))))
-
-(defun cider-test-render-assertion (buffer test)
- "Emit into BUFFER report detail for the TEST assertion."
- (with-current-buffer buffer
- (nrepl-dbind-response test (var context type message expected actual error gen-input)
- (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)))
- (cider-insert (capitalize type) type-face nil " in ")
- (cider-insert var 'font-lock-function-name-face t)
- (when context (cider-insert context 'font-lock-doc-face t))
- (when message (cider-insert message 'font-lock-doc-string-face t))
- (when expected
- (cider-insert "expected: " 'font-lock-comment-face nil
- (cider-font-lock-as-clojure expected)))
- (when actual
- (cider-insert " actual: " 'font-lock-comment-face nil
- (cider-font-lock-as-clojure actual)))
- (when error
- (cider-insert " error: " 'font-lock-comment-face nil)
- (insert-text-button error
- 'follow-link t
- 'action '(lambda (_button) (cider-test-stacktrace))
- 'help-echo "View causes and stacktrace")
- (insert "\n"))
- (when gen-input
- (cider-insert " input: " 'font-lock-comment-face nil
- (cider-font-lock-as-clojure gen-input)))
- (overlay-put (make-overlay beg (point)) 'font-lock-face bg))
- (insert "\n")))))
-
-(defun cider-test-non-passing (tests)
- "For a list of TESTS, each an nrepl-dict, return only those that did not pass."
- (seq-filter (lambda (test)
- (unless (equal (nrepl-dict-get test "type") "pass")
- test))
- tests))
-
-(defun cider-test-render-report (buffer summary results)
- "Emit into BUFFER the report for the SUMMARY, and test RESULTS."
- (with-current-buffer buffer
- (let ((inhibit-read-only t))
- (cider-test-report-mode)
- (cider-insert "Test Summary" 'bold t)
- (dolist (ns (nrepl-dict-keys results))
- (insert (cider-propertize ns 'ns) "\n"))
- (cider-insert "\n")
- (cider-test-render-summary buffer summary)
- (nrepl-dbind-response summary (fail error)
- (unless (zerop (+ fail error))
- (cider-insert "Results" 'bold t "\n")
- ;; Results are a nested dict, keyed first by ns, then var. Within each
- ;; var is a sequence of test assertion results.
- (nrepl-dict-map
- (lambda (ns vars)
- (nrepl-dict-map
- (lambda (_var tests)
- (let* ((problems (cider-test-non-passing tests))
- (count (length problems)))
- (when (< 0 count)
- (insert (format "%s\n%d non-passing tests:\n\n"
- (cider-propertize ns 'ns) count))
- (dolist (test problems)
- (cider-test-render-assertion buffer test)))))
- vars))
- results)))
- (goto-char (point-min))
- (current-buffer))))
-
-
-;;; Message echo
-
-(defun cider-test-echo-running (ns &optional test)
- "Echo a running message for the test NS, which may be a keyword.
-The optional arg TEST denotes an individual test name."
- (if test
- (message "Running test %s in %s..."
- (cider-propertize test 'bold)
- (cider-propertize ns 'ns))
- (message "Running tests in %s..."
- (concat (cider-propertize
- (cond ((stringp ns) ns)
- ((eq :non-passing ns) "failing")
- ((eq :loaded ns) "all loaded")
- ((eq :project ns) "all project"))
- 'ns)
- (unless (stringp ns) " namespaces")))))
-
-(defun cider-test-echo-summary (summary results)
- "Echo SUMMARY statistics for a test run returning RESULTS."
- (nrepl-dbind-response summary (ns test var fail error)
- (if (nrepl-dict-empty-p results)
- (message (concat (propertize "No assertions (or no tests) were run." 'face 'cider-test-error-face)
- "Did you forget to use `is' in your tests?"))
- (message (propertize
- "%sRan %d assertions, in %d test functions. %d failures, %d errors."
- 'face (cond ((not (zerop error)) 'cider-test-error-face)
- ((not (zerop fail)) 'cider-test-failure-face)
- (t 'cider-test-success-face)))
- (concat (if (= 1 ns) ; ns count from summary
- (cider-propertize (car (nrepl-dict-keys results)) 'ns)
- (propertize (format "%d namespaces" ns) 'face 'default))
- (propertize ": " 'face 'default))
- test var fail error))))
-
-;;; Test definition highlighting
-;; On receipt of test results, failing/erring test definitions are highlighted.
-;; Highlights are cleared on the next report run, and may be cleared manually
-;; by the user.
-
-;; NOTE If keybindings specific to test sources are desired, it would be
-;; straightforward to turn this into a `cider-test-mode' minor mode, which we
-;; enable on test sources, much like the legacy `clojure-test-mode'. At present,
-;; though, there doesn't seem to be much value in this, since the report buffer
-;; provides the primary means of interacting with test results.
-
-(defun cider-test-highlight-problem (buffer test)
- "Highlight the BUFFER test definition for the non-passing TEST."
- (with-current-buffer buffer
- (nrepl-dbind-response test (type file line message expected actual)
- ;; we have to watch out for vars without proper location metadata
- ;; right now everything evaluated interactively lacks this data
- ;; TODO: Figure out what to do when the metadata is missing
- (when (and file line (not (cider--tooling-file-p file)))
- (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."
- (cider-ensure-op-supported "info")
- (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
- :group 'cider-test
- :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"))
- ;; string-suffix-p is only available in Emacs 24.4+
- (if (string-match-p (rx-to-string `(: ,suffix eos) t) ns)
- ns
- (concat ns suffix)))))
-
-
-;;; Test execution
-
-(declare-function cider-emit-interactive-eval-output "cider-interaction")
-(declare-function cider-emit-interactive-eval-err-output "cider-interaction")
-
-(defun cider-test-execute (ns &optional tests silent)
- "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."
- (cider-test-clear-highlights)
- (cider-map-connections
- (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)))
- (cider-nrepl-send-request
- (list "op" (cond ((stringp ns) "test")
- ((eq :project ns) "test-all")
- ((eq :loaded ns) "test-all")
- ((eq :non-passing ns) "retest"))
- "ns" (when (stringp ns) ns)
- "tests" (when (stringp ns) tests)
- "load?" (when (or (stringp ns)
- (eq :project ns))
- "true"))
- (lambda (response)
- (nrepl-dbind-response response (summary results status out err)
- (cond ((member "namespace-not-found" status)
- (unless silent
- (message "No test namespace: %s" (cider-propertize ns 'ns))))
- (out (cider-emit-interactive-eval-output out))
- (err (cider-emit-interactive-eval-err-output err))
- (results
- (nrepl-dbind-response summary (error fail)
- (setq cider-test-last-summary summary)
- (setq cider-test-last-results results)
- (cider-test-highlight-problems results)
- (cider-test-echo-summary summary results)
- (if (or (not (zerop (+ error fail)))
- cider-test-show-report-on-success)
- (cider-test-render-report
- (cider-popup-buffer cider-test-report-buffer
- cider-auto-select-test-report-buffer)
- summary results)
- (when (get-buffer cider-test-report-buffer)
- (with-current-buffer cider-test-report-buffer
- (let ((inhibit-read-only t))
- (erase-buffer)))
- (cider-test-render-report
- cider-test-report-buffer
- summary results))))))))
- conn))
- :clj))
-
-(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 ()
- "Run all tests defined in currently loaded namespaces."
- (interactive)
- (cider-test-execute :loaded))
-
-(defun cider-test-run-project-tests ()
- "Run all tests defined in all project namespaces, loading these as needed."
- (interactive)
- (cider-test-execute :project))
-
-(defun cider-test-run-ns-tests (suppress-inference &optional silent)
- "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."
- (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)
- (if (eq major-mode 'cider-test-report-mode)
- (when (y-or-n-p (concat "Test report does not define a namespace. "
- "Rerun failed/erring tests?"))
- (cider-test-rerun-failed-tests))
- (unless silent
- (message "No namespace to test in current context")))))
-
-(defvar cider-test-last-test-ns nil
- "The ns of the last test ran with `cider-test-run-test'.")
-(defvar cider-test-last-test-var nil
- "The var of the last test ran with `cider-test-run-test'.")
-
-(defun cider-test-update-last-test (ns var)
- "Update the last test by setting NS and VAR.
-
-See `cider-test-rerun-test'."
- (setq cider-test-last-test-ns ns
- cider-test-last-test-var var))
-
-(defun cider-test-run-test ()
- "Run the test at point.
-The test ns/var exist as text properties on report items and on highlighted
-failed/erred test definitions. When not found, a test definition at point
-is searched."
- (interactive)
- (let ((ns (get-text-property (point) 'ns))
- (var (get-text-property (point) 'var)))
- (if (and ns var)
- (progn
- (cider-test-update-last-test ns var)
- (cider-test-execute ns (list var)))
- (let ((ns (clojure-find-ns))
- (def (clojure-find-def)))
- (if (and ns (member (car def) cider-test-defining-forms))
- (progn
- (cider-test-update-last-test ns (cdr def))
- (cider-test-execute ns (cdr def)))
- (message "No test at point"))))))
-
-(defun cider-test-rerun-test ()
- "Re-run the test that was previously ran."
- (interactive)
- (if (and cider-test-last-test-ns cider-test-last-test-var)
- (cider-test-execute cider-test-last-test-ns cider-test-last-test-var)
- (user-error "No test to re-run")))
-
-;;; Auto-test mode
-(defun cider--test-silently ()
- "Like `cider-test-run-tests', but with less feedback.
-Only notify the user if there actually were any tests to run and only after
-the results are received."
- (when (cider-connected-p)
- (let ((cider-auto-select-test-report-buffer nil)
- (cider-test-show-report-on-success nil))
- (cider-test-run-ns-tests nil 'soft))))
-
-;;;###autoload
-(define-minor-mode cider-auto-test-mode
- "Toggle automatic testing of Clojure files.
-
-When enabled this reruns tests every time a Clojure file is loaded.
-Only runs tests corresponding to the loaded file's namespace and does
-nothing if no tests are defined or if the file failed to load."
- nil (cider-mode " Test") 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-util.el --- Common utility functions that don't belong anywhere else -*- lexical-binding: t -*-
-
-;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
-;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; 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:
-
-(require 'seq)
-(require 'cl-lib)
-(require 'clojure-mode)
-(require 'subr-x)
-(require 'cider-compat)
-(require 'nrepl-dict)
-
-(defalias 'cider-pop-back 'pop-tag-mark)
-
-(defcustom cider-font-lock-max-length 10000
- "The max length of strings to fontify in `cider-font-lock-as'.
-
-Setting this to nil removes the fontification restriction."
- :group 'cider
- :type 'boolean
- :package-version '(cider . "0.10.0"))
-
-(defun cider-util--hash-keys (hashtable)
- "Return a list of keys in HASHTABLE."
- (let ((keys '()))
- (maphash (lambda (k _v) (setq keys (cons k keys))) hashtable)
- keys))
-
-(defun cider-util--clojure-buffers ()
- "Return a list of all existing `clojure-mode' buffers."
- (seq-filter
- (lambda (buffer) (with-current-buffer buffer (derived-mode-p 'clojure-mode)))
- (buffer-list)))
-
-(defun cider-current-dir ()
- "Return the directory of the current buffer."
- (if buffer-file-name
- (file-name-directory buffer-file-name)
- default-directory))
-
-(defun cider-in-string-p ()
- "Return true if point is in a string."
- (let ((beg (save-excursion (beginning-of-defun) (point))))
- (nth 3 (parse-partial-sexp beg (point)))))
-
-(defun cider-in-comment-p ()
- "Return true if point is in a comment."
- (let ((beg (save-excursion (beginning-of-defun) (point))))
- (nth 4 (parse-partial-sexp beg (point)))))
-
-(defun cider--tooling-file-p (file-name)
- "Return t if FILE-NAME is not a 'real' source file.
-Currently, only check if the relative file name starts with 'form-init'
-which nREPL uses for temporary evaluation file names."
- (let ((fname (file-name-nondirectory file-name)))
- (string-match-p "^form-init" fname)))
-
-(defun cider--cljc-or-cljx-buffer-p (&optional buffer)
- "Return true if the current buffer is visiting a cljc or cljx file.
-
-If BUFFER is provided act on that buffer instead."
- (with-current-buffer (or buffer (current-buffer))
- (or (derived-mode-p 'clojurec-mode) (derived-mode-p 'clojurex-mode))))
-
-\f
-;;; Thing at point
-(defun cider-defun-at-point (&optional bounds)
- "Return the text of the top-level sexp at point.
-If BOUNDS is non-nil, return a list of its starting and ending position
-instead."
- (save-excursion
- (save-match-data
- (end-of-defun)
- (let ((end (point)))
- (clojure-backward-logical-sexp 1)
- (funcall (if bounds #'list #'buffer-substring-no-properties)
- (point) end)))))
-
-(defun cider-ns-form ()
- "Retrieve the ns form."
- (when (clojure-find-ns)
- (save-excursion
- (goto-char (match-beginning 0))
- (cider-defun-at-point))))
-
-(defun cider-symbol-at-point (&optional look-back)
- "Return the name of the symbol at point, otherwise nil.
-Ignores the REPL prompt. If LOOK-BACK is non-nil, move backwards trying to
-find a symbol if there isn't one at point."
- (or (when-let ((str (thing-at-point 'symbol)))
- (unless (text-property-any 0 (length str) 'field 'cider-repl-prompt str)
- (substring-no-properties str)))
- (when look-back
- (save-excursion
- (ignore-errors
- (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-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)
- (skip-chars-forward "[:blank:]")
- (when (looking-at-p "\n") (forward-char 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))))
-
-\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))
- (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
-;;; Font lock
-
-(defalias 'cider--font-lock-ensure
- (if (fboundp 'font-lock-ensure)
- #'font-lock-ensure
- (with-no-warnings
- (lambda (&optional _beg _end)
- (when font-lock-mode
- (font-lock-fontify-buffer))))))
-
-(defalias 'cider--font-lock-flush
- (if (fboundp 'font-lock-flush)
- #'font-lock-flush
- (with-no-warnings
- (lambda (&optional _beg _end)
- (when font-lock-mode
- (font-lock-fontify-buffer))))))
-
-(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-font-lock-as (mode string)
- "Use MODE to font-lock the 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)
- (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."
- (cider-font-lock-as 'clojure-mode string))
-
-;; Button allowing use of `font-lock-face', ignoring any inherited `face'
-(define-button-type 'cider-plain-button
- 'face nil)
-
-;;; Colors
-
-(defun cider-scale-color (color scale)
- "For a COLOR hex string or name, adjust intensity of RGB components by SCALE."
- (let* ((rgb (color-values color))
- (scaled-rgb (mapcar (lambda (n)
- (format "%04x" (round (+ n (* scale 65535)))))
- rgb)))
- (apply #'concat "#" scaled-rgb)))
-
-(defun cider-scale-background-color ()
- "Scale the current background color to get a slighted muted version."
- (let ((color (frame-parameter nil 'background-color))
- (dark (eq (frame-parameter nil 'background-mode) 'dark)))
- (cider-scale-color color (if dark 0.05 -0.05))))
-
-(autoload 'pkg-info-version-info "pkg-info.el")
-
-(defvar cider-version)
-(defvar cider-codename)
-
-(defun cider--version ()
- "Retrieve CIDER's version.
-A codename is added to stable versions."
- (let ((version (condition-case nil
- (pkg-info-version-info 'cider)
- (error cider-version))))
- (if (string-match-p "-snapshot" cider-version)
- version
- (format "%s (%s)" 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 "http://cider.readthedocs.org/en/%s/"
- "The URL to CIDER's manual.")
-
-(defun cider--manual-version ()
- "Convert the version to a ReadTheDocs-friendly version."
- (if (string-match-p "-snapshot" cider-version)
- "latest"
- "stable"))
-
-(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/doc/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 "`\\(.*?\\)`"
- "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")
-
-;; 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))))))
-
- ;; create back and forward buttons if appropiate
- (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")))
-
-\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"
- "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."
- ,(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'."
- (eval (nth (random (length cider-words-of-inspiration))
- cider-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-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)."
- "Press <\\[cider-find-resource]> to find a resource on the classpath."
- "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-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-refresh]> to reload modified and unloaded namespaces."
- "You can define Clojure functions to be called before and after `cider-refresh' (see `cider-refresh-before-fn' and `cider-refresh-after-fn'."
- "Press <\\[cider-display-connection-info]> 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.")
- "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)
- (`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.el --- Clojure Interactive Development Environment that Rocks -*- lexical-binding: t -*-
-
-;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
-;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
-;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
-;; Steve Purcell <steveNOSPAMsanityinc.com>
-;; Maintainer: Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; URL: http://www.github.com/clojure-emacs/cider
-;; Version: 0.15.0-snapshot
-;; Package-Requires: ((emacs "24.4") (clojure-mode "5.6.0") (pkg-info "0.4") (queue "0.1.1") (spinner "1.7") (seq "2.16"))
-;; 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.
-
-;;; Installation:
-
-;; Available as a package in melpa.org and stable.melpa.org
-
-;; (add-to-list 'package-archives
-;; '("melpa" . "https://melpa.org/packages/"))
-;;
-;; or
-;;
-;; (add-to-list 'package-archives
-;; '("melpa-stable" . "https://stable.melpa.org/packages/") t)
-;;
-;; M-x package-install cider
-
-;;; Usage:
-
-;; M-x cider-jack-in
-
-;;; 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 "Online Manual" "https://cider.readthedocs.org")
- :link '(emacs-commentary-link :tag "Commentary" "cider"))
-
-(defcustom cider-prompt-for-project-on-connect 'when-needed
- "Controls whether to prompt for associated project on `cider-connect'.
-
-When set to when-needed, the project will be derived from the buffer you're
-visiting, when invoking `cider-connect'.
-When set to t, you'll always to prompted to select the matching project.
-When set to nil, you'll never be prompted to select a project and no
-project inference will take place."
- :type '(choice (const :tag "always" t)
- (const when-needed)
- (const :tag "never" nil))
- :group 'cider
- :package-version '(cider . "0.10.0"))
-
-(require 'cider-client)
-(require 'cider-eldoc)
-(require 'cider-repl)
-(require 'cider-mode)
-(require 'cider-common)
-(require 'subr-x)
-(require 'cider-compat)
-(require 'cider-debug)
-(require 'tramp-sh)
-(require 'cider-repl-history)
-
-(require 'seq)
-
-(defconst cider-version "0.15.0-snapshot"
- "Fallback version used when it cannot be extracted automatically.
-Normally it won't be used, unless `pkg-info' fails to extract the
-version from the CIDER package or library.")
-
-(defconst cider-codename "London"
- "Codename used to denote stable releases.")
-
-(defcustom cider-lein-command
- "lein"
- "The command used to execute Leiningen."
- :type 'string
- :group 'cider)
-
-(defcustom cider-lein-global-options
- nil
- "Command global options used to execute Leiningen (e.g.: -o for offline)."
- :type 'string
- :group 'cider)
-
-(defcustom cider-lein-parameters
- "repl :headless"
- "Params passed to Leiningen to start an nREPL server via `cider-jack-in'."
- :type 'string
- :group 'cider)
-
-(defcustom cider-boot-command
- "boot"
- "The command used to execute Boot."
- :type 'string
- :group 'cider
- :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
- :group 'cider
- :package-version '(cider . "0.14.0"))
-
-(defcustom cider-boot-parameters
- "repl -s wait"
- "Params passed to boot to start an nREPL server via `cider-jack-in'."
- :type 'string
- :group 'cider
- :package-version '(cider . "0.9.0"))
-
-(defcustom cider-gradle-command
- "gradle"
- "The command used to execute Gradle."
- :type 'string
- :group 'cider
- :package-version '(cider . "0.10.0"))
-
-(defcustom cider-gradle-global-options
- "--no-daemon"
- "Command line options used to execute Gradle (e.g.: -m for dry run)."
- :type 'string
- :group 'cider
- :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
- :group 'cider
- :package-version '(cider . "0.10.0"))
-
-(defcustom cider-default-repl-command
- "lein"
- "The default command and parameters to use when connecting to nREPL.
-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."
- :type 'string
- :group 'cider
- :package-version '(cider . "0.9.0"))
-
-(defcustom cider-preferred-build-tool
- nil
- "Allow choosing a build system when there are many.
-When there are artifacts from multiple build systems (\"lein\", \"boot\",
-\"gradle\") 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 "gradle")
- (const :tag "Always ask" nil))
- :group 'cider
- :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))
- :group 'cider
- :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")))
- :group 'cider)
-
-(defcustom cider-connected-hook nil
- "List of functions to call when connected to Clojure nREPL server."
- :type 'hook
- :group 'cider
- :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
- :group 'cider
- :package-version '(cider . "0.9.0"))
-
-(defcustom cider-auto-mode t
- "When non-nil, automatically enable `cider-mode' for all Clojure buffers."
- :type 'boolean
- :package-version '(cider . "0.9.0"))
-
-(defcustom cider-inject-dependencies-at-jack-in t
- "When nil, do not inject repl dependencies (most likely nREPL middlewares) at `cider-jack-in' time."
- :type 'boolean
- :version '(cider . "0.11.0"))
-
-(defvar cider-ps-running-nrepls-command "ps u | grep leiningen"
- "Process snapshot command used in `cider-locate-running-nrepl-ports'.")
-
-(defvar cider-ps-running-nrepl-path-regexp-list
- '("\\(?:leiningen.original.pwd=\\)\\(.+?\\) -D"
- "\\(?:-classpath +:?\\(.+?\\)/self-installs\\)")
- "Regexp list to get project paths.
-Extract project paths from output of `cider-ps-running-nrepls-command'.
-Sub-match 1 must be the project path.")
-
-(defvar cider-host-history nil
- "Completion history for connection hosts.")
-
-;;;###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)
- ("gradle" cider-gradle-command)
- (_ (user-error "Unsupported project type `%s'" project-type))))
-
-(defun cider-jack-in-resolve-command (project-type)
- "Determine the resolved file path to `cider-jack-in-command' if it can be
-found for the PROJECT-TYPE"
- (pcase project-type
- ("lein" (cider--lein-resolve-command))
- ("boot" (cider--boot-resolve-command))
- ("gradle" (cider--gradle-resolve-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)
- ("gradle" cider-gradle-global-options)
- (_ (user-error "Unsupported project type `%s'" project-type))))
-
-(defun cider-jack-in-params (project-type)
- "Determine the commands params for `cider-jack-in' for the PROJECT-TYPE."
- (pcase project-type
- ("lein" cider-lein-parameters)
- ("boot" cider-boot-parameters)
- ("gradle" cider-gradle-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)
-(cider-add-to-alist 'cider-jack-in-dependencies
- "org.clojure/tools.nrepl" "0.2.12")
-
-(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)
-(cider-add-to-alist 'cider-jack-in-dependencies-exclusions
- "org.clojure/tools.nrepl" '("org.clojure/clojure"))
-
-(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 cider-jack-in-lein-plugins nil
- "List of Leiningen plugins where elements are lists of artifact name and version.")
-(put 'cider-jack-in-lein-plugins 'risky-local-variable t)
-(cider-add-to-alist 'cider-jack-in-lein-plugins
- "cider/cider-nrepl" (upcase cider-version))
-
-(defvar cider-jack-in-nrepl-middlewares nil
- "List of Clojure variable names.
-Each of these Clojure variables should hold a vector of nREPL middlewares.")
-(put 'cider-jack-in-nrepl-middlewares 'risky-local-variable t)
-(add-to-list 'cider-jack-in-nrepl-middlewares "cider.nrepl/cider-middleware")
-
-(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-boot-dependencies (dependencies)
- "Return a list of boot artifact strings created from DEPENDENCIES."
- (concat (mapconcat #'cider--list-as-boot-artifact dependencies " ")
- (when (not (seq-empty-p dependencies)) " ")))
-
-(defun cider-boot-middleware-task (params middlewares)
- (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 plugins middlewares)
- (concat global-opts
- (when (not (seq-empty-p global-opts)) " ")
- "-i \"(require 'cider.tasks)\" " ;; Note the white space at the end here
- (cider-boot-dependencies (append dependencies plugins))
- (cider-boot-middleware-task 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)
- (concat
- global-opts
- (when (not (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))
- " -- ")
- " -- "
- 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)
- "Return 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. 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
- cider-jack-in-dependencies)
- cider-jack-in-dependencies-exclusions
- cider-jack-in-lein-plugins))
- ("boot" (cider-boot-jack-in-dependencies
- global-opts
- params
- (cider-add-clojure-dependencies-maybe
- cider-jack-in-dependencies)
- cider-jack-in-lein-plugins
- cider-jack-in-nrepl-middlewares))
- ("gradle" (concat
- global-opts
- (when (not (seq-empty-p global-opts)) " ")
- params))
- (_ (error "Unsupported project type `%s'" project-type))))
-
-\f
-;;; ClojureScript REPL creation
-(defconst cider--cljs-repl-types
- '(("(cemerick.piggieback/cljs-repl (cljs.repl.rhino/repl-env))"
- "Rhino" "")
- ("(do (require 'figwheel-sidecar.repl-api) (figwheel-sidecar.repl-api/start-figwheel!) (figwheel-sidecar.repl-api/cljs-repl))"
- "Figwheel-sidecar" " (add figwheel-sidecar to your plugins)")
- ("(do (require 'cljs.repl.node) (cemerick.piggieback/cljs-repl (cljs.repl.node/repl-env)))"
- "Node" " (requires NodeJS to be installed)")
- ("(do (require 'weasel.repl.websocket) (cemerick.piggieback/cljs-repl (weasel.repl.websocket/repl-env :ip \"127.0.0.1\" :port 9001)))"
- "Weasel" " (see http://cider.readthedocs.io/en/latest/up_and_running/#browser-connected-clojurescript-repl)")
- ("(do (require 'adzerk.boot-cljs-repl) (adzerk.boot-cljs-repl/start-repl))"
- "Boot-cljs-repl" " (see https://github.com/adzerk-oss/boot-cljs-repl/blob/master/README.md")))
-
-(defcustom cider-cljs-lein-repl "(cemerick.piggieback/cljs-repl (cljs.repl.rhino/repl-env))"
- "Clojure form that returns a ClojureScript REPL environment.
-This is only used in lein projects. It is evaluated in a Clojure REPL and
-it should start a ClojureScript REPL."
- :type `(choice ,@(seq-map (lambda (x) `(const :tag ,(apply #'concat (cdr x)) ,(car x)))
- cider--cljs-repl-types)
- (string :tag "Custom"))
- :safe (lambda (x) (assoc x cider--cljs-repl-types))
- :package-version '(cider . "0.11.0")
- :group 'cider)
-
-(defcustom cider-cljs-boot-repl "(do (require 'adzerk.boot-cljs-repl) (adzerk.boot-cljs-repl/start-repl))"
- "Clojure form that returns a ClojureScript REPL environment.
-This is only used in boot projects. It is evaluated in a Clojure REPL and
-it should start a ClojureScript REPL."
- :type `(choice ,@(seq-map (lambda (x) `(const :tag ,(apply #'concat (cdr x)) ,(car x)))
- cider--cljs-repl-types)
- (string :tag "Custom"))
- :safe (lambda (x) (assoc x cider--cljs-repl-types))
- :package-version '(cider . "0.15.0")
- :group 'cider)
-
-(defcustom cider-cljs-gradle-repl "(cemerick.piggieback/cljs-repl (cljs.repl.rhino/repl-env))"
- "Clojure form that returns a ClojureScript REPL environment.
-This is only used in gradle projects. It is evaluated in a Clojure REPL and
-it should start a ClojureScript REPL."
- :type `(choice ,@(seq-map (lambda (x) `(const :tag ,(apply #'concat (cdr x)) ,(car x)))
- cider--cljs-repl-types)
- (string :tag "Custom"))
- :safe (lambda (x) (assoc x cider--cljs-repl-types))
- :package-version '(cider . "0.15.0")
- :group 'cider)
-
-(defun cider-cljs-repl-form (project-type)
- "Return a Clojure form that returns a ClojureScript REPL environment
-based on PROJECT-TYPE."
- (pcase project-type
- ("lein" cider-cljs-lein-repl)
- ("boot" cider-cljs-boot-repl)
- ("gradle" cider-cljs-gradle-repl)
- (_ (error "Unsupported project type `%s'" project-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)))))))
-
-(defun cider-create-sibling-cljs-repl (client-buffer)
- "Create a ClojureScript REPL with the same server as CLIENT-BUFFER.
-The new buffer will correspond to the same project as CLIENT-BUFFER, which
-should be the regular Clojure REPL started by the server process filter."
- (interactive (list (cider-current-connection)))
- (let* ((nrepl-repl-buffer-name-template "*cider-repl CLJS%s*")
- (nrepl-create-client-buffer-function #'cider-repl-create)
- (nrepl-use-this-as-repl-buffer 'new)
- (client-process-args (with-current-buffer client-buffer
- (unless (or nrepl-server-buffer nrepl-endpoint)
- (error "This is not a REPL buffer, is there a REPL active?"))
- (list (car nrepl-endpoint)
- (elt nrepl-endpoint 1)
- (when (buffer-live-p nrepl-server-buffer)
- (get-buffer-process nrepl-server-buffer)))))
- (cljs-proc (apply #'nrepl-start-client-process client-process-args))
- (cljs-buffer (process-buffer cljs-proc))
- (cljs-repl-form (cider-cljs-repl-form (cider-project-type))))
- (with-current-buffer cljs-buffer
- ;; The new connection has now been bumped to the top, but it's still a
- ;; Clojure REPL! Additionally, some ClojureScript REPLs can actually take
- ;; a while to start (some even depend on the user opening a browser).
- ;; Meanwhile, this REPL will gladly receive requests in place of the
- ;; original Clojure REPL. Our solution is to bump the original REPL back
- ;; up the list, so it takes priority on Clojure requests.
- (cider-make-connection-default client-buffer)
- (pcase (assoc cljs-repl-form cider--cljs-repl-types)
- (`(,_ ,name ,info)
- (message "Starting a %s REPL%s" name (or info "")))
- (_ (message "Starting a custom ClojureScript REPL")))
- (cider-nrepl-send-request
- (list "op" "eval"
- "ns" (cider-current-ns)
- "code" cljs-repl-form)
- (cider-repl-handler (current-buffer)))
- (cider--offer-to-open-app-in-browser nrepl-server-buffer))))
-
-(defun cider--select-zombie-buffer (repl-buffers)
- "Return a zombie buffer from REPL-BUFFERS, or nil if none exists."
- (when-let ((zombie-buffs (seq-remove #'get-buffer-process repl-buffers)))
- (when (y-or-n-p
- (format "Zombie REPL buffers exist (%s). Reuse? "
- (mapconcat #'buffer-name zombie-buffs ", ")))
- (if (= (length zombie-buffs) 1)
- (car zombie-buffs)
- (completing-read "Choose REPL buffer: "
- (mapcar #'buffer-name zombie-buffs)
- nil t)))))
-
-(defun cider-find-reusable-repl-buffer (endpoint project-directory)
- "Check whether a reusable connection buffer already exists.
-Looks for buffers where `nrepl-endpoint' matches ENDPOINT, or
-`nrepl-project-dir' matches PROJECT-DIRECTORY. If such a buffer was found,
-and has no process, return it. If the process is alive, ask the user for
-confirmation and return 'new/nil for y/n answer respectively. If other
-REPL buffers with dead process exist, ask the user if any of those should
-be reused."
- (if-let ((repl-buffers (cider-repl-buffers))
- (exact-buff (seq-find
- (lambda (buff)
- (with-current-buffer buff
- (or (and endpoint
- (equal endpoint nrepl-endpoint))
- (and project-directory
- (equal project-directory nrepl-project-dir)))))
- repl-buffers)))
- (if (get-buffer-process exact-buff)
- (when (y-or-n-p (format "REPL buffer already exists (%s). \
-Do you really want to create a new one? "
- exact-buff))
- 'new)
- exact-buff)
- (or (cider--select-zombie-buffer repl-buffers) 'new)))
-
-;;;###autoload
-(defun cider-jack-in (&optional prompt-project cljs-too)
- "Start an nREPL server for the current project and connect to it.
-If PROMPT-PROJECT is t, then prompt for the project for which to
-start the server.
-If CLJS-TOO is non-nil, also start a ClojureScript REPL session with its
-own buffer."
- (interactive "P")
- (setq cider-current-clojure-buffer (current-buffer))
- (let* ((project-type (cider-project-type))
- (command (cider-jack-in-command project-type))
- (command-resolved (cider-jack-in-resolve-command project-type))
- (command-global-opts (cider-jack-in-global-options project-type))
- (command-params (cider-jack-in-params project-type)))
- (if command-resolved
- (let* ((project (when prompt-project
- (read-directory-name "Project: ")))
- (project-dir (clojure-project-dir
- (or project (cider-current-dir))))
- (params (if prompt-project
- (read-string (format "nREPL server command: %s "
- command-params)
- command-params)
- command-params))
- (params (if cider-inject-dependencies-at-jack-in
- (cider-inject-jack-in-dependencies command-global-opts params project-type)
- params))
-
- (cmd (format "%s %s" command-resolved params)))
- (if (or project-dir cider-allow-jack-in-without-project)
- (progn
- (when (or project-dir
- (eq cider-allow-jack-in-without-project t)
- (and (null project-dir)
- (eq cider-allow-jack-in-without-project 'warn)
- (y-or-n-p "Are you sure you want to run `cider-jack-in' without a Clojure project? ")))
- (when-let ((repl-buff (cider-find-reusable-repl-buffer nil project-dir)))
- (let ((nrepl-create-client-buffer-function #'cider-repl-create)
- (nrepl-use-this-as-repl-buffer repl-buff))
- (nrepl-start-server-process
- project-dir cmd
- (when cljs-too #'cider-create-sibling-cljs-repl))))))
- (user-error "`cider-jack-in' is not allowed without a Clojure project")))
- (user-error "The %s executable isn't on your `exec-path'" command))))
-
-;;;###autoload
-(defun cider-jack-in-clojurescript (&optional prompt-project)
- "Start an nREPL server and connect to it both Clojure and ClojureScript REPLs.
-If PROMPT-PROJECT is t, then prompt for the project for which to
-start the server."
- (interactive "P")
- (cider-jack-in prompt-project 'cljs-too))
-
-;;;###autoload
-(defun cider-connect (host port &optional project-dir)
- "Connect to an nREPL server identified by HOST and PORT.
-Create REPL buffer and start an nREPL client connection.
-
-When the optional param PROJECT-DIR is present, the connection
-gets associated with it."
- (interactive (cider-select-endpoint))
- (setq cider-current-clojure-buffer (current-buffer))
- (when-let ((repl-buff (cider-find-reusable-repl-buffer `(,host ,port) nil)))
- (let* ((nrepl-create-client-buffer-function #'cider-repl-create)
- (nrepl-use-this-as-repl-buffer repl-buff)
- (conn (process-buffer (nrepl-start-client-process host port))))
- (with-current-buffer conn
- (setq cider-connection-created-with 'connect))
- (if project-dir
- (cider-assoc-project-with-connection project-dir conn)
- (let ((project-dir (clojure-project-dir)))
- (cond
- ;; associate only if we're in a project
- ((and project-dir (null cider-prompt-for-project-on-connect)) (cider-assoc-project-with-connection project-dir conn))
- ;; associate if we're in a project, prompt otherwise
- ((eq cider-prompt-for-project-on-connect 'when-needed) (cider-assoc-project-with-connection project-dir conn))
- ;; always prompt
- (t (cider-assoc-project-with-connection nil conn))))))))
-
-(defun cider-current-host ()
- "Retrieve the current host."
- (if (and (stringp buffer-file-name)
- (file-remote-p buffer-file-name))
- tramp-current-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
- (when (file-remote-p default-directory)
- ;; add localhost even in remote buffers
- '(("localhost"))))))
- (sel-host (cider--completing-read-host hosts))
- (host (car sel-host))
- (port (or (cadr sel-host)
- (cider--completing-read-port host (cider--infer-ports host ssh-hosts)))))
- (list host port)))
-
-(defun cider--ssh-hosts ()
- "Retrieve all ssh host from local configuration files."
- (seq-map (lambda (s) (list (replace-regexp-in-string ":$" "" s)))
- (let ((tramp-completion-mode 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--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)))
- (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 vec)
- (with-current-buffer (tramp-get-connection-buffer 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-locate-running-nrepl-ports (&optional dir)
- "Locate ports of running nREPL servers.
-When DIR is non-nil also look for nREPL port files in DIR. Return a list
-of list of the form (project-dir port)."
- (let* ((paths (cider--running-nrepl-paths))
- (proj-ports (mapcar (lambda (d)
- (when-let ((port (and d (nrepl-extract-port (cider--file-path d)))))
- (list (file-name-nondirectory (directory-file-name d)) port)))
- (cons (clojure-project-dir dir) paths))))
- (seq-uniq (delq nil proj-ports))))
-
-(defun cider--running-nrepl-paths ()
- "Retrieve project paths of running nREPL servers.
-Use `cider-ps-running-nrepls-command' and `cider-ps-running-nrepl-path-regexp-list'."
- (let (paths)
- (with-temp-buffer
- (insert (shell-command-to-string cider-ps-running-nrepls-command))
- (dolist (regexp cider-ps-running-nrepl-path-regexp-list)
- (goto-char 1)
- (while (re-search-forward regexp nil t)
- (setq paths (cons (match-string 1) paths)))))
- (seq-uniq paths)))
-
-(defun cider--identify-buildtools-present ()
- "Identify build systems present by their build files."
- (let* ((default-directory (clojure-project-dir (cider-current-dir)))
- (build-files '(("lein" . "project.clj")
- ("boot" . "build.boot")
- ("gradle" . "build.gradle"))))
- (delq nil
- (mapcar (lambda (candidate)
- (when (file-exists-p (cdr candidate))
- (car candidate)))
- build-files))))
-
-(defun cider-project-type ()
- "Determine the type, either leiningen, boot or gradle, of the current project.
-If more than one project file types are present, check for a preferred
-build tool in `cider-preferred-build-tool', otherwise prompt the user to
-choose."
- (let* ((choices (cider--identify-buildtools-present))
- (multiple-project-choices (> (length choices) 1))
- (default (car choices)))
- (cond ((and multiple-project-choices
- (member cider-preferred-build-tool choices))
- cider-preferred-build-tool)
- (multiple-project-choices
- (completing-read (format "Which command should be used (default %s): " default)
- choices nil t nil nil default))
- (choices
- (car choices))
- (t cider-default-repl-command))))
-
-
-;; TODO: Implement a check for `cider-lein-command' over tramp
-(defun cider--lein-resolve-command ()
- "Find `cider-lein-command' on `exec-path' if possible, or return `nil'.
-
-In case `default-directory' is non-local we assume the command is available."
- (when-let ((command (or (and (file-remote-p default-directory) cider-lein-command)
- (executable-find cider-lein-command)
- (executable-find (concat cider-lein-command ".bat")))))
- (shell-quote-argument command)))
-
-;; TODO: Implement a check for `cider-boot-command' over tramp
-(defun cider--boot-resolve-command ()
- "Find `cider-boot-command' on `exec-path' if possible, or return `nil'.
-
-In case `default-directory' is non-local we assume the command is available."
- (when-let ((command (or (and (file-remote-p default-directory) cider-boot-command)
- (executable-find cider-boot-command)
- (executable-find (concat cider-boot-command ".exe")))))
- (shell-quote-argument command)))
-
-;; TODO: Implement a check for `cider-gradle-command' over tramp
-(defun cider--gradle-resolve-command ()
- "Find `cider-gradle-command' on `exec-path' if possible, or return `nil'.
-
-In case `default-directory' is non-local we assume the command is available."
- (when-let ((command (or (and (file-remote-p default-directory) cider-gradle-command)
- (executable-find cider-gradle-command)
- (executable-find (concat cider-gradle-command ".exe")))))
- (shell-quote-argument command)))
-
-\f
-;;; Check that the connection is working well
-;; TODO: This is nrepl specific. It should eventually go into some cider-nrepl-client
-;; file.
-(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-repl-manual-warning "troubleshooting/#warning-saying-you-have-to-use-nrepl-0212"
- "CIDER requires nREPL %s (or newer) to work properly"
- cider-required-nrepl-version))
- (cider-repl-manual-warning "troubleshooting/#warning-saying-you-have-to-use-nrepl-0212"
- "Can't determine nREPL's version.\nPlease, update nREPL to %s."
- cider-required-nrepl-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)))
- (when (version< clojure-version cider-minimum-clojure-version)
- (cider-repl-manual-warning "installation/#prerequisites"
- "Clojure version (%s) is not supported (minimum %s). CIDER will not work."
- clojure-version cider-minimum-clojure-version))
- (cider-repl-manual-warning "installation/#prerequisites"
- "Can't determine Clojure's version. CIDER requires Clojure %s (or newer)."
- cider-minimum-clojure-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-connection)))
- (middleware-version (nrepl-dict-get version-dict "version-string" "not installed")))
- (unless (equal cider-version middleware-version)
- (cider-repl-manual-warning "troubleshooting/#cider-complains-of-the-cider-nrepl-version"
- "CIDER's version (%s) does not match cider-nrepl's version (%s). Things will break!"
- cider-version middleware-version))))
-
-(defun cider--subscribe-repl-to-server-out ()
- "Subscribe to the server's *out*."
- (cider-nrepl-send-request '("op" "out-subscribe")
- (cider-interactive-eval-handler (current-buffer))))
-
-(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-make-connection-default (current-buffer))
- (cider-repl-init (current-buffer))
- (cider--check-required-nrepl-version)
- (cider--check-clojure-version-supported)
- (cider--check-middleware-compatibility)
- (cider--debug-init-connection)
- (cider--subscribe-repl-to-server-out)
- (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
- (cider-possibly-disable-on-existing-clojure-buffers)
- (run-hooks 'cider-disconnected-hook))
-
-;;;###autoload
-(eval-after-load 'clojure-mode
- '(progn
- (define-key clojure-mode-map (kbd "C-c M-j") #'cider-jack-in)
- (define-key clojure-mode-map (kbd "C-c M-J") #'cider-jack-in-clojurescript)
- (define-key clojure-mode-map (kbd "C-c M-c") #'cider-connect)))
-
-(provide 'cider)
-
-;;; cider.el ends here
+++ /dev/null
-;;; nrepl-client.el --- Client for Clojure nREPL -*- lexical-binding: t -*-
-
-;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
-;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; 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 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 leiningen or boot). 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 'cider-compat)
-(require 'cl-lib)
-(require 'nrepl-dict)
-(require 'queue)
-(require 'tramp)
-
-\f
-;;; 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)
-
-(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)
-
-(defcustom nrepl-connected-hook nil
- "List of functions to call when connecting to the nREPL server."
- :type 'hook
- :group 'nrepl)
-
-(defcustom nrepl-disconnected-hook nil
- "List of functions to call when disconnected from the nREPL server."
- :type 'hook
- :group 'nrepl)
-
-(defcustom nrepl-file-loaded-hook nil
- "List of functions to call when a load file has completed."
- :type 'hook
- :group 'nrepl)
-
-(defcustom nrepl-force-ssh-for-remote-hosts nil
- "If non-nil, do not attempt a direct connection for remote hosts."
- :type 'boolean
- :group 'nrepl)
-
-(defcustom nrepl-use-ssh-fallback-for-remote-hosts nil
- "If non-nil, attempt to connect via ssh to remote hosts when unable to connect directly."
- :type 'boolean
- :group 'nrepl)
-
-(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
- :group 'nrepl)
-
-(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
- :group 'nrepl)
-
-(defcustom nrepl-prompt-to-kill-server-buffer-on-quit t
- "If non-nil, prompt the user for confirmation before killing the nrepl server buffer and associated process."
- :type 'boolean
- :group 'nrepl)
-
-(defvar nrepl-create-client-buffer-function 'nrepl-create-client-buffer-default
- "Name of a function that returns a client process buffer.
-It is called with one argument, a plist containing :host, :port and :proc
-as returned by `nrepl-connect'.")
-
-(defvar nrepl-use-this-as-repl-buffer 'new
- "Name of the buffer to use as REPL buffer.
-In case of a special value 'new, a new buffer is created.")
-
-\f
-;;; Buffer Local Declarations
-
-;; These variables are used to track the state of nREPL connections
-(defvar-local nrepl-client-buffers nil
- "List of buffers connected to this server.")
-(defvar-local nrepl-connection-buffer nil)
-(defvar-local nrepl-server-buffer nil)
-(defvar-local nrepl-endpoint nil)
-(defvar-local nrepl-project-dir 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
- "Auxillary information received from the describe op.")
-
-\f
-;;; nREPL Buffer Names
-
-(defconst nrepl-message-buffer-name-template "*nrepl-messages %s*")
-(defconst nrepl-error-buffer-name "*nrepl-error*")
-(defconst nrepl-repl-buffer-name-template "*cider-repl%s*")
-(defconst nrepl-connection-buffer-name-template "*nrepl-connection%s*")
-(defconst nrepl-server-buffer-name-template "*nrepl-server%s*")
-(defconst nrepl-tunnel-buffer-name-template "*nrepl-tunnel%s*")
-
-(defun nrepl-format-buffer-name-template (buffer-name-template designation)
- "Apply the DESIGNATION to the corresponding BUFFER-NAME-TEMPLATE."
- (format buffer-name-template
- (if (> (length designation) 0)
- (concat nrepl-buffer-name-separator designation)
- "")))
-
-(defun nrepl-make-buffer-name (buffer-name-template &optional project-dir host port dup-ok)
- "Generate a buffer name using BUFFER-NAME-TEMPLATE.
-
-If not supplied PROJECT-DIR, HOST and PORT default to the buffer local
-value of the `nrepl-project-dir' and `nrepl-endpoint'.
-
-The name will include the project name if available or the endpoint host if
-it is not. The name will also include the connection port if
-`nrepl-buffer-name-show-port' is true.
-
-If optional DUP-OK is non-nil, the returned buffer is not \"uniquified\" by
-`generate-new-buffer-name'."
- (let* ((project-dir (or project-dir nrepl-project-dir))
- (project-name (when project-dir (file-name-nondirectory (directory-file-name project-dir))))
- (nrepl-proj-port (or port (cadr nrepl-endpoint)))
- (name (nrepl-format-buffer-name-template
- buffer-name-template
- (concat (if project-name project-name (or host (car nrepl-endpoint)))
- (if (and nrepl-proj-port nrepl-buffer-name-show-port)
- (format ":%s" nrepl-proj-port) "")))))
- (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-connection-buffer-name (&optional project-dir host port)
- "Return the name of the connection buffer.
-PROJECT-DIR, HOST and PORT are as in `/nrepl-make-buffer-name'."
- (nrepl--make-hidden-name
- (nrepl-make-buffer-name nrepl-connection-buffer-name-template
- project-dir host port)))
-
-(defun nrepl-connection-identifier (conn)
- "Return the string which identifies a connection CONN."
- (thread-last (buffer-name conn)
- (replace-regexp-in-string "\\`*cider-repl " "")
- (replace-regexp-in-string "*\\'" "" )))
-
-(defun nrepl-server-buffer-name (&optional project-dir host port)
- "Return the name of the server buffer.
-PROJECT-DIR, HOST and PORT are as in `nrepl-make-buffer-name'."
- (nrepl--make-hidden-name
- (nrepl-make-buffer-name nrepl-server-buffer-name-template
- project-dir host port)))
-
-(defun nrepl-tunnel-buffer-name (&optional project-dir host port)
- "Return the name of the tunnel buffer.
-PROJECT-DIR, HOST and PORT are as in `nrepl-make-buffer-name'."
- (nrepl--make-hidden-name
- (nrepl-make-buffer-name nrepl-tunnel-buffer-name-template
- project-dir host port)))
-
-\f
-;;; Utilities
-(defun nrepl-op-supported-p (op connection)
- "Return t iff the given operation OP is supported by the nREPL 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 .nrepl-port, nrepl-port or target/repl-port files in directory DIR."
- (or (nrepl--port-from-file (expand-file-name "repl-port" dir))
- (nrepl--port-from-file (expand-file-name ".nrepl-port" dir))
- (nrepl--port-from-file (expand-file-name "target/repl-port" dir))))
-
-(defun nrepl--port-from-file (file)
- "Attempts to read port from a file named by FILE."
- (when (file-exists-p file)
- (with-temp-buffer
- (insert-file-contents file)
- (buffer-string))))
-
-\f
-;;; 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))
- ;; handle both \n\r and \r\n
- (result (replace-regexp-in-string "\r\n\\|\n\r" "\n" original))
- ;; we don't handle single carriage returns, insert newline
- (result (replace-regexp-in-string "\r" "\n" result)))
- (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-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-temp-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))
- (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))))
-
-\f
-;;; 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 behaviour of the callbacks. Errors signaled by these
-functions are demoted to messages, so that they don't prevent the
-callbacks from running.")
-
-(defun nrepl-client-filter (proc string)
- "Decode message(s) from PROC contained in STRING and dispatch them."
- (let ((string-q (process-get proc :string-q)))
- (queue-enqueue string-q string)
- ;; Start decoding only if the last letter is 'e'
- (when (eq ?e (aref string (1- (length string))))
- (let ((response-q (process-get proc :response-q)))
- (nrepl-bdecode string-q response-q)
- (while (queue-head response-q)
- (with-current-buffer (process-buffer proc)
- (let ((response (queue-dequeue response-q)))
- (with-demoted-errors "Error in one of the `nrepl-response-handler-functions': %s"
- (run-hook-with-args 'nrepl-response-handler-functions response))
- (nrepl--dispatch-response response))))))))
-
-(defun nrepl--dispatch-response (response)
- "Dispatch the RESPONSE to associated callback.
-First we check the callbacks of pending requests. If no callback was found,
-we check the completed requests, since responses could be received even for
-older requests with \"done\" status."
- (nrepl-dbind-response response (id)
- (nrepl-log-message response 'response)
- (let ((callback (or (gethash id nrepl-pending-requests)
- (gethash id nrepl-completed-requests))))
- (if callback
- (funcall callback response)
- (error "[nREPL] No response handler with id %s found" id)))))
-
-(defun nrepl-client-sentinel (process message)
- "Handle sentinel events from PROCESS.
-Notify MESSAGE and if the process is closed run `nrepl-disconnected-hook'
-and kill the process buffer."
- (if (string-match "deleted\\b" message)
- (message "[nREPL] Connection closed")
- (message "[nREPL] Connection closed unexpectedly (%s)"
- (substring message 0 -1)))
- (when (equal (process-status process) 'closed)
- (when-let ((client-buffer (process-buffer process)))
- (nrepl--clear-client-sessions client-buffer)
- (with-current-buffer client-buffer
- (run-hooks 'nrepl-disconnected-hook)
- (when (buffer-live-p nrepl-server-buffer)
- (with-current-buffer nrepl-server-buffer
- (setq nrepl-client-buffers (delete client-buffer nrepl-client-buffers)))
- (nrepl--maybe-kill-server-buffer nrepl-server-buffer))))))
-
-\f
-;;; Network
-
-(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))
- (nrepl--direct-connect host port 'no-error)
- ;; direct connection failed or `nrepl-force-ssh-for-remote-hosts' is non-nil
- (when (or nrepl-use-ssh-fallback-for-remote-hosts
- nrepl-force-ssh-for-remote-hosts)
- (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
- (error "Host (%s) and port (%s) must be provided" host port))
- (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 established"))
- (error (let ((mes "[nREPL] Direct connection failed"))
- (if no-error (message mes) (error mes))
- 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 ...")
- (let* ((remote-dir (if host (format "/ssh:%s:" host) 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))
- (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 nil
- ;; 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'"
- `((?s . ,ssh)
- (?p . ,port)
- (?h . ,host)
- (?u . ,(if user (format "-l '%s' " user) ""))))))
-
-(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)))))))))
-
-\f
-;;; Client: Process Handling
-
-(defun nrepl--maybe-kill-server-buffer (server-buf)
- "Kill SERVER-BUF and its process, subject to user confirmation.
-Do nothing if there is a REPL connected to that server."
- (with-current-buffer server-buf
- ;; Don't kill the server if there is a REPL connected to it.
- (when (and (not nrepl-client-buffers)
- (or (not nrepl-prompt-to-kill-server-buffer-on-quit)
- (y-or-n-p "Also kill server process and buffer? ")))
- (let ((proc (get-buffer-process server-buf)))
- (when (process-live-p proc)
- (set-process-query-on-exit-flag proc nil)
- (kill-process proc))
- (kill-buffer server-buf)))))
-
-;; `nrepl-start-client-process' is called from `nrepl-server-filter'. It
-;; starts the client process described by `nrepl-client-filter' and
-;; `nrepl-client-sentinel'.
-(defun nrepl-start-client-process (&optional host port server-proc)
- "Create new client process identified by HOST and PORT.
-In remote buffers, HOST and PORT are taken from the current tramp
-connection. SERVER-PROC must be a running nREPL server process within
-Emacs. This function creates connection buffer by a call to
-`nrepl-create-client-buffer-function'. Return newly created client
-process."
- (let* ((endpoint (nrepl-connect host port))
- (client-proc (plist-get endpoint :proc))
- (host (plist-get endpoint :host))
- (port (plist-get endpoint :port))
- (client-buf (funcall nrepl-create-client-buffer-function 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 `(,host ,port)
- 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)))
-
-\f
-;;; 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)))
-
-(defvar cider-buffer-ns)
-(defvar cider-special-mode-truncate-lines)
-(declare-function cider-need-input "cider-interaction")
-(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
- pprint-out-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',
-'pprint-out' 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, and PPRINT-OUT-HANDLER. 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 (value ns out err status id pprint-out)
- (when (buffer-live-p buffer)
- (with-current-buffer buffer
- (when (and ns (not (derived-mode-p 'clojure-mode)))
- (cider-set-buffer-ns ns))))
- (cond (value
- (when value-handler
- (funcall value-handler buffer value)))
- (out
- (when stdout-handler
- (funcall stdout-handler buffer out)))
- (pprint-out
- (cond (pprint-out-handler (funcall pprint-out-handler buffer pprint-out))
- (stdout-handler (funcall stdout-handler buffer pprint-out))))
- (err
- (when stderr-handler
- (funcall stderr-handler buffer err)))
- (status
- (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 not found."))
- (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))))))))
-
-\f
-;;; 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/clojure/tools.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
- (list "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-interaction")
-
-(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
- (> (cadr (time-subtract (current-time) time0))
- nrepl-sync-request-timeout))
- (error "Sync nREPL request timed out %s" request)))
- ;; 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 (list "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 (list "op" "interrupt"
- "interrupt-id" pending-request-id)
- callback
- connection))
-
-(define-minor-mode cider-enlighten-mode nil nil (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."
- (append (and ns (list "ns" ns))
- (list "op" "eval"
- "code" input)
- (when cider-enlighten-mode
- (list "enlighten" "true"))
- (let ((file (or (buffer-file-name) (buffer-name))))
- (when (and line column file)
- (list "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 (list "op" "close")
- connection)
- (nrepl-send-sync-request (list "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:eval (input connection &optional ns)
- "Send the INPUT to the nREPL server synchronously.
-The request is dispatched via CONNECTION.
-If NS is non-nil, include it in the request."
- (nrepl-send-sync-request
- (nrepl--eval-request input ns)
- connection))
-
-(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"))
-
-\f
-;;; 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.
-
-(defvar-local nrepl-post-client-callback nil
- "Function called after the client process is started.
-Used by `nrepl-start-server-process'.")
-
-(defun nrepl-start-server-process (directory cmd &optional 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.
-If CALLBACK is non-nil, it should be function of 1 argument. Once the
-client process is started, the function is called with the client buffer."
- (let* ((default-directory (or directory default-directory))
- (serv-buf (get-buffer-create (generate-new-buffer-name
- (nrepl-server-buffer-name directory))))
- (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)
- (with-current-buffer serv-buf
- (setq nrepl-project-dir directory)
- (setq nrepl-post-client-callback callback)
- ;; Ensure that `nrepl-start-client-process' sees right things. This
- ;; causes warnings about making a local within a let-bind. This is safe
- ;; as long as `serv-buf' is not the buffer where the let-binding was
- ;; started. http://www.gnu.org/software/emacs/manual/html_node/elisp/Creating-Buffer_002dLocal.html
- (setq-local nrepl-create-client-buffer-function
- nrepl-create-client-buffer-function)
- (setq-local nrepl-use-this-as-repl-buffer
- nrepl-use-this-as-repl-buffer))
- (message "Starting nREPL server via %s..."
- (propertize cmd 'face 'font-lock-keyword-face))
- serv-proc))
-
-(defun nrepl-server-filter (process output)
- "Process nREPL server output from PROCESS contained in OUTPUT."
- ;; 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 (string-match "nREPL server started on port \\([0-9]+\\)" output)
- (let ((port (string-to-number (match-string 1 output))))
- (message "nREPL server started on %s" port)
- (with-current-buffer server-buffer
- (let* ((client-proc (nrepl-start-client-process nil port process))
- (client-buffer (process-buffer client-proc)))
- (setq nrepl-client-buffers
- (cons client-buffer
- (delete client-buffer nrepl-client-buffers)))
-
- (when (functionp nrepl-post-client-callback)
- (funcall nrepl-post-client-callback client-buffer)))))))))
-
-(declare-function cider--close-connection-buffer "cider-client")
-
-(defun nrepl-server-sentinel (process event)
- "Handle nREPL server PROCESS EVENT."
- (let* ((server-buffer (process-buffer process))
- (clients (buffer-local-value 'nrepl-client-buffers server-buffer))
- (problem (if (and server-buffer (buffer-live-p server-buffer))
- (with-current-buffer server-buffer
- (buffer-substring (point-min) (point-max)))
- "")))
- (when server-buffer
- (kill-buffer server-buffer))
- (cond
- ((string-match-p "^killed\\|^interrupt" event)
- nil)
- ((string-match-p "^hangup" event)
- (mapc #'cider--close-connection-buffer clients))
- ;; On Windows, a failed start sends the "finished" event. On Linux it sends
- ;; "exited abnormally with code 1".
- (t (error "Could not start nREPL server: %s" problem)))))
-
-\f
-;;; 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
- :group 'nrepl)
-
-(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}"
- (setq buffer-read-only t)
- (when cider-special-mode-truncate-lines
- (setq-local truncate-lines t))
- (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
- (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 `nrepl-messages-buffer'."
- :type '(repeat color)
- :group 'nrepl)
-
-(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))
- (let ((indent (+ 2 (- (current-column) (length head))))
- (l (point)))
- (if (null (cdr object))
- (insert ")\n")
- (insert " \n")
- (cl-loop for l on (cdr object) by #'cddr
- do (let ((str (format "%s%s " (make-string indent ?\s)
- (propertize (car l) 'face
- ;; Only highlight top-level keys.
- (unless (eq (car object) 'dict)
- 'font-lock-keyword-face)))))
- (insert 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")))))
-
-(defun nrepl-messages-buffer-name (conn)
- "Return the name for the message buffer matching CONN."
- (format nrepl-message-buffer-name-template (nrepl-connection-identifier conn)))
-
-(defun nrepl-messages-buffer (conn)
- "Return or create the buffer for CONN.
-The default buffer name is *nrepl-messages connection*."
- (let ((msg-buffer-name (nrepl-messages-buffer-name conn)))
- (or (get-buffer msg-buffer-name)
- (let ((buffer (get-buffer-create msg-buffer-name)))
- (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)
- (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)))
-
-(defun nrepl-create-client-buffer-default (endpoint)
- "Create an nREPL client process buffer.
-ENDPOINT is a plist returned by `nrepl-connect'."
- (let ((buffer (generate-new-buffer
- (nrepl-connection-buffer-name default-directory
- (plist-get endpoint :host)
- (plist-get endpoint :port)))))
- (with-current-buffer buffer
- (buffer-disable-undo)
- (setq-local kill-buffer-query-functions nil))
- buffer))
-
-(provide 'nrepl-client)
-
-;;; nrepl-client.el ends here
+++ /dev/null
-;;; nrepl-dict.el --- Dictionary functions for Clojure nREPL -*- lexical-binding: t -*-
-
-;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
-;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
-;;
-;; Author: Tim King <kingtimNOSPAMgmail.com>
-;; Phil Hagelberg <technomancyNOSPAMgmail.com>
-;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
-;; 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.
-
-;;; Code:
-(require 'cl-lib)
-
-
-(defun nrepl-dict (&rest key-vals)
- "Create nREPL dict from KEY-VALS."
- (cons 'dict key-vals))
-
-(defun nrepl-dict-p (object)
- "Return t if OBJECT is an nREPL dict."
- (and (listp object)
- (eq (car object) 'dict)))
-
-(defun nrepl-dict-empty-p (dict)
- "Return t if nREPL dict DICT is empty."
- (null (cdr dict)))
-
-(defun nrepl-dict-contains (dict key)
- "Return nil if nREPL dict DICT doesn't contain KEY.
-If DICT does contain KEY, then a non-nil value is returned. Due to the
-current implementation, this return value is the tail of DICT's key-list
-whose car is KEY. Comparison is done with `equal'."
- (member key (nrepl-dict-keys dict)))
-
-(defun nrepl-dict-get (dict key &optional default)
- "Get from DICT value associated with KEY, optional DEFAULT if KEY not in DICT.
-If dict is nil, return nil. If DEFAULT not provided, and KEY not in DICT,
-return nil. If DICT is not an nREPL dict object, an error is thrown."
- (when dict
- (if (nrepl-dict-p dict)
- (if (nrepl-dict-contains dict key)
- (lax-plist-get (cdr dict) key)
- default)
- (error "Not an nREPL dict object: %s" dict))))
-
-(defun nrepl-dict-put (dict key value)
- "Associate in DICT, KEY to VALUE.
-Return new dict. Dict is modified by side effects."
- (if (null dict)
- (list 'dict key value)
- (if (not (nrepl-dict-p dict))
- (error "Not an nREPL dict object: %s" dict)
- (setcdr dict (lax-plist-put (cdr dict) key value))
- dict)))
-
-(defun nrepl-dict-keys (dict)
- "Return all the keys in the nREPL DICT."
- (if (nrepl-dict-p dict)
- (cl-loop for l on (cdr dict) by #'cddr
- collect (car l))
- (error "Not an nREPL dict")))
-
-(defun nrepl-dict-vals (dict)
- "Return all the values in the nREPL DICT."
- (if (nrepl-dict-p dict)
- (cl-loop for l on (cdr dict) by #'cddr
- collect (cadr l))
- (error "Not an nREPL dict")))
-
-(defun nrepl-dict-map (fn dict)
- "Map FN on nREPL DICT.
-FN must accept two arguments key and value."
- (if (nrepl-dict-p dict)
- (cl-loop for l on (cdr dict) by #'cddr
- collect (funcall fn (car l) (cadr l)))
- (error "Not an nREPL dict")))
-
-(defun nrepl-dict-merge (dict1 dict2)
- "Destructively merge DICT2 into DICT1.
-Keys in DICT2 override those in DICT1."
- (let ((base (or dict1 '(dict))))
- (nrepl-dict-map (lambda (k v)
- (nrepl-dict-put base k v))
- (or dict2 '(dict)))
- base))
-
-(defun nrepl-dict-get-in (dict keys)
- "Return the value in a nested DICT.
-KEYS is a list of keys. Return nil if any of the keys is not present or if
-any of the values is nil."
- (let ((out dict))
- (while (and keys out)
- (setq out (nrepl-dict-get out (pop keys))))
- out))
-
-(defun nrepl-dict-flat-map (function dict)
- "Map FUNCTION over DICT and flatten the result.
-FUNCTION follows the same restrictions as in `nrepl-dict-map', and it must
-also alway return a sequence (since the result will be flattened)."
- (when dict
- (apply #'append (nrepl-dict-map function dict))))
-
-\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 (list dict1 dict2)))))
-
-\f
-;;; Dbind
-(defmacro nrepl-dbind-response (response keys &rest body)
- "Destructure an nREPL RESPONSE dict.
-Bind the value of the provided KEYS and execute BODY."
- (declare (debug (form (&rest symbolp) body)))
- `(let ,(cl-loop for key in keys
- collect `(,key (nrepl-dict-get ,response ,(format "%s" key))))
- ,@body))
-(put 'nrepl-dbind-response 'lisp-indent-function 2)
-
-(provide 'nrepl-dict)
-
-;;; nrepl-dict.el ends here
--- /dev/null
+;;; cider-apropos.el --- Apropos functionality for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2018 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)
+(require 'cider-util)
+(require 'subr-x)
+(require 'cider-compat)
+
+(require 'cider-client)
+(require 'cider-popup)
+(require 'nrepl-dict)
+
+(require 'clojure-mode)
+(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-grimoire" . cider-grimoire-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)
+
+(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))))
+ (cider-propertize-region (list 'apropos-symbol name
+ 'action 'cider-apropos-doc
+ 'help-echo help)
+ (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")))))
+
+(declare-function cider-mode "cider-mode")
+
+(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
+;;
+;;; Code:
+
+(add-to-list 'load-path (directory-file-name
+ (or (file-name-directory #$) (car load-path))))
+
+\f
+;;;### (autoloads nil "cider" "cider.el" (0 0 0 0))
+;;; Generated autoloads from cider.el
+
+(autoload 'cider-version "cider" "\
+Display CIDER's version.
+
+\(fn)" t nil)
+ (autoload 'cider-start-map "cider" "CIDER jack-in and connect keymap." t 'keymap)
+
+(autoload 'cider-jack-in-clj "cider" "\
+Start an nREPL server for the current project and connect to it.
+PARAMS is a plist optionally containing :project-dir and :jack-in-cmd.
+With the prefix argument, prompt for all these parameters.
+
+\(fn PARAMS)" t nil)
+
+(autoload 'cider-jack-in-cljs "cider" "\
+Start an nREPL server for the current project and connect to it.
+PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and
+:cljs-repl-type (e.g. Node, Figwheel, etc). With the prefix argument,
+prompt for all these parameters.
+
+\(fn PARAMS)" t nil)
+
+(autoload 'cider-jack-in-clj&cljs "cider" "\
+Start an nREPL server and connect with clj and cljs REPLs.
+PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and
+:cljs-repl-type (e.g. Node, Figwheel, etc). With the prefix argument,
+prompt for all these parameters. When SOFT-CLJS-START is non-nil, start
+cljs REPL only when the ClojureScript dependencies are met.
+
+\(fn &optional PARAMS SOFT-CLJS-START)" t nil)
+
+(autoload 'cider-connect-sibling-clj "cider" "\
+Create a Clojure REPL with the same server as OTHER-REPL.
+PARAMS is for consistency with other connection commands and is currently
+ignored. OTHER-REPL defaults to `cider-current-repl' and in programs can
+also be a server buffer, in which case a new session with a REPL for that
+server is created.
+
+\(fn PARAMS &optional OTHER-REPL)" t nil)
+
+(autoload 'cider-connect-sibling-cljs "cider" "\
+Create a ClojureScript REPL with the same server as OTHER-REPL.
+PARAMS is a plist optionally containing :cljs-repl-type (e.g. Node,
+Figwheel, etc). All other parameters are inferred from the OTHER-REPL.
+OTHER-REPL defaults to `cider-current-repl' but in programs can also be a
+server buffer, in which case a new session for that server is created.
+
+\(fn PARAMS &optional OTHER-REPL)" t nil)
+
+(autoload 'cider-connect-clj "cider" "\
+Initialize a Clojure connection to an nREPL server.
+PARAMS is a plist optionally containing :host, :port and :project-dir. On
+prefix argument, prompt for all the parameters.
+
+\(fn &optional PARAMS)" t nil)
+
+(autoload 'cider-connect-cljs "cider" "\
+Initialize a ClojureScript connection to an nREPL server.
+PARAMS is a plist optionally containing :host, :port, :project-dir and
+:cljs-repl-type (e.g. Node, Figwheel, etc). On prefix, prompt for all the
+parameters regardless of their supplied or default values.
+
+\(fn &optional PARAMS)" t nil)
+
+(autoload 'cider-connect-clj&cljs "cider" "\
+Initialize a Clojure and ClojureScript connection to an nREPL server.
+PARAMS is a plist optionally containing :host, :port, :project-dir and
+:cljs-repl-type (e.g. Node, Figwheel, etc). When SOFT-CLJS-START is
+non-nil, don't start if ClojureScript requirements are not met.
+
+\(fn PARAMS &optional SOFT-CLJS-START)" t nil)
+
+(autoload 'cider "cider" "\
+Start a connection of any type interactively.
+
+\(fn)" t nil)
+
+(defalias 'cider-jack-in #'cider-jack-in-clj)
+
+(defalias 'cider-jack-in-clojure #'cider-jack-in-clj)
+
+(defalias 'cider-jack-in-clojurescript #'cider-jack-in-cljs)
+
+(defalias 'cider-connect #'cider-connect-clj)
+
+(defalias 'cider-connect-clojure #'cider-connect-clj)
+
+(defalias 'cider-connect-clojurescript #'cider-connect-cljs)
+
+(defalias 'cider-connect-sibling-clojure #'cider-connect-sibling-clj)
+
+(defalias 'cider-connect-sibling-clojurescript #'cider-connect-sibling-cljs)
+
+(with-eval-after-load 'clojure-mode (define-key clojure-mode-map (kbd "C-c M-x") #'cider) (define-key clojure-mode-map (kbd "C-c M-j") #'cider-jack-in-clj) (define-key clojure-mode-map (kbd "C-c M-J") #'cider-jack-in-cljs) (define-key clojure-mode-map (kbd "C-c M-c") #'cider-connect-clj) (define-key clojure-mode-map (kbd "C-c M-C") #'cider-connect-cljs) (define-key clojure-mode-map (kbd "C-c C-x") 'cider-start-map) (define-key clojure-mode-map (kbd "C-c C-s") 'sesman-map) (require 'sesman) (sesman-install-menu clojure-mode-map) (add-hook 'clojure-mode-hook (lambda nil (setq-local sesman-system 'CIDER))))
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-apropos" "cider-apropos.el" (0 0 0 0))
+;;; Generated autoloads from cider-apropos.el
+
+(autoload 'cider-apropos "cider-apropos" "\
+Show all symbols whose names match QUERY, a regular expression.
+QUERY can also be a list of space-separated words (e.g. take while) which
+will be converted to a regular expression (like take.+while) automatically
+behind the scenes. The search may be limited to the namespace NS, and may
+optionally search doc strings (based on DOCS-P), include private vars
+\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P).
+
+\(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t nil)
+
+(autoload 'cider-apropos-documentation "cider-apropos" "\
+Shortcut for (cider-apropos <query> nil t).
+
+\(fn)" t nil)
+
+(autoload 'cider-apropos-select "cider-apropos" "\
+Similar to `cider-apropos', but presents the results in a completing read.
+Show all symbols whose names match QUERY, a regular expression.
+QUERY can also be a list of space-separated words (e.g. take while) which
+will be converted to a regular expression (like take.+while) automatically
+behind the scenes. The search may be limited to the namespace NS, and may
+optionally search doc strings (based on DOCS-P), include private vars
+\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P).
+
+\(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t nil)
+
+(autoload 'cider-apropos-documentation-select "cider-apropos" "\
+Shortcut for (cider-apropos-select <query> nil t).
+
+\(fn)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-apropos" '("cider-" "apropos-special-form")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-browse-ns" "cider-browse-ns.el" (0 0
+;;;;;; 0 0))
+;;; Generated autoloads from cider-browse-ns.el
+
+(autoload 'cider-browse-ns "cider-browse-ns" "\
+List all NAMESPACE's vars in BUFFER.
+
+\(fn NAMESPACE)" t nil)
+
+(autoload 'cider-browse-ns-all "cider-browse-ns" "\
+List all loaded namespaces in BUFFER.
+
+\(fn)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-browse-ns" '("cider-browse-ns-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-browse-spec" "cider-browse-spec.el"
+;;;;;; (0 0 0 0))
+;;; Generated autoloads from cider-browse-spec.el
+
+(autoload 'cider-browse-spec "cider-browse-spec" "\
+Browse SPEC definition.
+
+\(fn SPEC)" t nil)
+
+(autoload 'cider-browse-spec-all "cider-browse-spec" "\
+Open list of specs in a popup buffer.
+
+With a prefix argument ARG, prompts for a regexp to filter specs.
+No filter applied if the regexp is the empty string.
+
+\(fn &optional ARG)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-browse-spec" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-cheatsheet" "cider-cheatsheet.el" (0
+;;;;;; 0 0 0))
+;;; Generated autoloads from cider-cheatsheet.el
+
+(autoload 'cider-cheatsheet "cider-cheatsheet" "\
+Navigate `cider-cheatsheet-hierarchy' with `completing-read'.
+
+When you make it to a Clojure var its doc buffer gets displayed.
+
+\(fn)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-cheatsheet" '("cider-cheatsheet-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-classpath" "cider-classpath.el" (0 0
+;;;;;; 0 0))
+;;; Generated autoloads from cider-classpath.el
+
+(autoload 'cider-classpath "cider-classpath" "\
+List all classpath entries.
+
+\(fn)" t nil)
+
+(autoload 'cider-open-classpath-entry "cider-classpath" "\
+Open a classpath entry.
+
+\(fn)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-classpath" '("cider-classpath-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-client" "cider-client.el" (0 0 0 0))
+;;; Generated autoloads from cider-client.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-client" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-common" "cider-common.el" (0 0 0 0))
+;;; Generated autoloads from cider-common.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-common" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-completion" "cider-completion.el" (0
+;;;;;; 0 0 0))
+;;; Generated autoloads from cider-completion.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-completion" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-connection" "cider-connection.el" (0
+;;;;;; 0 0 0))
+;;; Generated autoloads from cider-connection.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-connection" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-debug" "cider-debug.el" (0 0 0 0))
+;;; Generated autoloads from cider-debug.el
+
+(autoload 'cider-debug-defun-at-point "cider-debug" "\
+Instrument the \"top-level\" expression at point.
+If it is a defn, dispatch the instrumented definition. Otherwise,
+immediately evaluate the instrumented expression.
+
+While debugged code is being evaluated, the user is taken through the
+source code and displayed the value of various expressions. At each step,
+a number of keys will be prompted to the user.
+
+\(fn)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-debug" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-doc" "cider-doc.el" (0 0 0 0))
+;;; Generated autoloads from cider-doc.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-doc" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-eldoc" "cider-eldoc.el" (0 0 0 0))
+;;; Generated autoloads from cider-eldoc.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-eldoc" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-eval" "cider-eval.el" (0 0 0 0))
+;;; Generated autoloads from cider-eval.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-eval" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-find" "cider-find.el" (0 0 0 0))
+;;; Generated autoloads from cider-find.el
+
+(autoload 'cider-find-var "cider-find" "\
+Find definition for VAR at LINE.
+Prompt according to prefix ARG and `cider-prompt-for-symbol'.
+A single or double prefix argument inverts the meaning of
+`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes
+the results to be displayed in a different window. The default value is
+thing at point.
+
+\(fn &optional ARG VAR LINE)" t nil)
+
+(autoload 'cider-find-dwim-at-mouse "cider-find" "\
+Find and display variable or resource at mouse EVENT.
+
+\(fn EVENT)" t nil)
+
+(autoload 'cider-find-dwim "cider-find" "\
+Find and display the SYMBOL-FILE at point.
+SYMBOL-FILE could be a var or a resource. If thing at point is empty then
+show dired on project. If var is not found, try to jump to resource of the
+same name. When called interactively, a prompt is given according to the
+variable `cider-prompt-for-symbol'. A single or double prefix argument
+inverts the meaning. A prefix of `-' or a double prefix argument causes
+the results to be displayed in a different window. A default value of thing
+at point is given when prompted.
+
+\(fn SYMBOL-FILE)" t nil)
+
+(autoload 'cider-find-resource "cider-find" "\
+Find the resource at PATH.
+Prompt for input as indicated by the variable `cider-prompt-for-symbol'.
+A single or double prefix argument inverts the meaning of
+`cider-prompt-for-symbol'. A prefix argument of `-` or a double prefix
+argument causes the results to be displayed in other window. The default
+value is thing at point.
+
+\(fn PATH)" t nil)
+
+(autoload 'cider-find-ns "cider-find" "\
+Find the file containing NS.
+A prefix ARG of `-` or a double prefix argument causes
+the results to be displayed in a different window.
+
+\(fn &optional ARG NS)" t nil)
+
+(autoload 'cider-find-keyword "cider-find" "\
+Find the namespace of the keyword at point and its first occurrence there.
+
+For instance - if the keyword at point is \":cider.demo/keyword\", this command
+would find the namespace \"cider.demo\" and afterwards find the first mention
+of \"::keyword\" there.
+
+Prompt according to prefix ARG and `cider-prompt-for-symbol'.
+A single or double prefix argument inverts the meaning of
+`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes
+the results to be displayed in a different window. The default value is
+thing at point.
+
+\(fn &optional ARG)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-find" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-format" "cider-format.el" (0 0 0 0))
+;;; Generated autoloads from cider-format.el
+
+(autoload 'cider-format-region "cider-format" "\
+Format the Clojure code in the current region.
+START and END represent the region's boundaries.
+
+\(fn START END)" t nil)
+
+(autoload 'cider-format-defun "cider-format" "\
+Format the code in the current defun.
+
+\(fn)" t nil)
+
+(autoload 'cider-format-buffer "cider-format" "\
+Format the Clojure code in the current buffer.
+
+\(fn)" t nil)
+
+(autoload 'cider-format-edn-buffer "cider-format" "\
+Format the EDN data in the current buffer.
+
+\(fn)" t nil)
+
+(autoload 'cider-format-edn-region "cider-format" "\
+Format the EDN data in the current region.
+START and END represent the region's boundaries.
+
+\(fn START END)" t nil)
+
+(autoload 'cider-format-edn-last-sexp "cider-format" "\
+Format the EDN data of the last sexp.
+
+\(fn)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-format" '("cider--format-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-grimoire" "cider-grimoire.el" (0 0 0
+;;;;;; 0))
+;;; Generated autoloads from cider-grimoire.el
+
+(autoload 'cider-grimoire-web "cider-grimoire" "\
+Open grimoire documentation in the default web browser.
+
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'cider-grimoire "cider-grimoire" "\
+Open grimoire documentation in a popup buffer.
+
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates.
+
+\(fn &optional ARG)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-grimoire" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-inspector" "cider-inspector.el" (0 0
+;;;;;; 0 0))
+;;; Generated autoloads from cider-inspector.el
+
+(autoload 'cider-inspect-last-sexp "cider-inspector" "\
+Inspect the result of the the expression preceding point.
+
+\(fn)" t nil)
+
+(autoload 'cider-inspect-defun-at-point "cider-inspector" "\
+Inspect the result of the \"top-level\" expression at point.
+
+\(fn)" t nil)
+
+(autoload 'cider-inspect-last-result "cider-inspector" "\
+Inspect the most recent eval result.
+
+\(fn)" t nil)
+
+(autoload 'cider-inspect "cider-inspector" "\
+Inspect the result of the preceding sexp.
+
+With a prefix argument ARG it inspects the result of the \"top-level\" form.
+With a second prefix argument it prompts for an expression to eval and inspect.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'cider-inspect-expr "cider-inspector" "\
+Evaluate EXPR in NS and inspect its value.
+Interactively, EXPR is read from the minibuffer, and NS the
+current buffer's namespace.
+
+\(fn EXPR NS)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-inspector" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-macroexpansion" "cider-macroexpansion.el"
+;;;;;; (0 0 0 0))
+;;; Generated autoloads from cider-macroexpansion.el
+
+(autoload 'cider-macroexpand-1 "cider-macroexpansion" "\
+Invoke \\=`macroexpand-1\\=` on the expression preceding point.
+If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of
+\\=`macroexpand-1\\=`.
+
+\(fn &optional PREFIX)" t nil)
+
+(autoload 'cider-macroexpand-all "cider-macroexpansion" "\
+Invoke \\=`macroexpand-all\\=` on the expression preceding point.
+
+\(fn)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-macroexpansion" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-mode" "cider-mode.el" (0 0 0 0))
+;;; Generated autoloads from cider-mode.el
+
+(defvar cider-mode-line '(:eval (format " cider[%s]" (cider--modeline-info))) "\
+Mode line lighter for cider mode.
+
+The value of this variable is a mode line template as in
+`mode-line-format'. See Info Node `(elisp)Mode Line Format' for details
+about mode line templates.
+
+Customize this variable to change how cider mode displays its status in the
+mode line. The default value displays the current connection. Set this
+variable to nil to disable the mode line entirely.")
+
+(custom-autoload 'cider-mode-line "cider-mode" t)
+
+(with-eval-after-load 'clojure-mode (easy-menu-define cider-clojure-mode-menu-open clojure-mode-map "Menu for Clojure mode.\n This is displayed in `clojure-mode' buffers, if `cider-mode' is not active." `("CIDER" :visible (not cider-mode) ["Start a Clojure REPL" cider-jack-in-clj :help "Starts an nREPL server and connects a Clojure REPL to it."] ["Connect to a Clojure REPL" cider-connect-clj :help "Connects to a REPL that's already running."] ["Start a ClojureScript REPL" cider-jack-in-cljs :help "Starts an nREPL server and connects a ClojureScript REPL to it."] ["Connect to a ClojureScript REPL" cider-connect-cljs :help "Connects to a ClojureScript REPL that's already running."] ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clj&cljs :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL."] "--" ["View manual online" cider-view-manual])))
+
+(autoload 'cider-mode "cider-mode" "\
+Minor mode for REPL interaction from a Clojure buffer.
+
+\\{cider-mode-map}
+
+\(fn &optional ARG)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-mode" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-ns" "cider-ns.el" (0 0 0 0))
+;;; Generated autoloads from cider-ns.el
+
+(autoload 'cider-ns-reload "cider-ns" "\
+Send a (require 'ns :reload) to the REPL.
+
+With an argument PROMPT, it prompts for a namespace name. This is the
+Clojure out of the box reloading experience and does not rely on
+org.clojure/tools.namespace. See Commentary of this file for a longer list
+of differences. From the Clojure doc: \":reload forces loading of all the
+identified libs even if they are already loaded\".
+
+\(fn &optional PROMPT)" t nil)
+
+(autoload 'cider-ns-reload-all "cider-ns" "\
+Send a (require 'ns :reload-all) to the REPL.
+
+With an argument PROMPT, it prompts for a namespace name. This is the
+Clojure out of the box reloading experience and does not rely on
+org.clojure/tools.namespace. See Commentary of this file for a longer list
+of differences. From the Clojure doc: \":reload-all implies :reload and
+also forces loading of all libs that the identified libs directly or
+indirectly load via require\".
+
+\(fn &optional PROMPT)" t nil)
+
+(autoload 'cider-ns-refresh "cider-ns" "\
+Reload modified and unloaded namespaces on the classpath.
+
+With a single prefix argument, or if MODE is `refresh-all', reload all
+namespaces on the classpath unconditionally.
+
+With a double prefix argument, or if MODE is `clear', clear the state of
+the namespace tracker before reloading. This is useful for recovering from
+some classes of error (for example, those caused by circular dependencies)
+that a normal reload would not otherwise recover from. The trade-off of
+clearing is that stale code from any deleted files may not be completely
+unloaded.
+
+With a negative prefix argument, or if MODE is `inhibit-fns', prevent any
+refresh functions (defined in `cider-ns-refresh-before-fn' and
+`cider-ns-refresh-after-fn') from being invoked.
+
+\(fn &optional MODE)" t nil)
+
+(define-obsolete-function-alias 'cider-refresh 'cider-ns-refresh "0.18")
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-ns" '("cider-ns-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-overlays" "cider-overlays.el" (0 0 0
+;;;;;; 0))
+;;; Generated autoloads from cider-overlays.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-overlays" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-popup" "cider-popup.el" (0 0 0 0))
+;;; Generated autoloads from cider-popup.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-popup" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-profile" "cider-profile.el" (0 0 0 0))
+;;; Generated autoloads from cider-profile.el
+
+(autoload 'cider-profile-samples "cider-profile" "\
+Displays current max-sample-count.
+If optional QUERY is specified, set max-sample-count and display new value.
+
+\(fn &optional QUERY)" t nil)
+
+(autoload 'cider-profile-var-profiled-p "cider-profile" "\
+Displays the profiling status of var under point.
+Prompts for var if none under point or QUERY is present.
+
+\(fn QUERY)" t nil)
+
+(autoload 'cider-profile-ns-toggle "cider-profile" "\
+Toggle profiling for the ns associated with optional QUERY.
+
+If optional argument QUERY is non-nil, prompt for ns. Otherwise use
+current ns.
+
+\(fn &optional QUERY)" t nil)
+
+(autoload 'cider-profile-toggle "cider-profile" "\
+Toggle profiling for the given QUERY.
+Defaults to the symbol at point.
+With prefix arg or no symbol at point, prompts for a var.
+
+\(fn QUERY)" t nil)
+
+(autoload 'cider-profile-summary "cider-profile" "\
+Display a summary of currently collected profile data.
+
+\(fn)" t nil)
+
+(autoload 'cider-profile-var-summary "cider-profile" "\
+Display profile data for var under point QUERY.
+Defaults to the symbol at point. With prefix arg or no symbol at point,
+prompts for a var.
+
+\(fn QUERY)" t nil)
+
+(autoload 'cider-profile-clear "cider-profile" "\
+Clear any collected profile data.
+
+\(fn)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-profile" '("cider-profile-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-repl" "cider-repl.el" (0 0 0 0))
+;;; Generated autoloads from cider-repl.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-repl" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-repl-history" "cider-repl-history.el"
+;;;;;; (0 0 0 0))
+;;; Generated autoloads from cider-repl-history.el
+
+(autoload 'cider-repl-history "cider-repl-history" "\
+Display items in the CIDER command history in another buffer.
+
+\(fn)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-repl-history" '("cider-repl-history-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-resolve" "cider-resolve.el" (0 0 0 0))
+;;; Generated autoloads from cider-resolve.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-resolve" '("cider-resolve-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-scratch" "cider-scratch.el" (0 0 0 0))
+;;; Generated autoloads from cider-scratch.el
+
+(autoload 'cider-scratch "cider-scratch" "\
+Go to the scratch buffer named `cider-scratch-buffer-name'.
+
+\(fn)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-scratch" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-selector" "cider-selector.el" (0 0 0
+;;;;;; 0))
+;;; Generated autoloads from cider-selector.el
+
+(autoload 'cider-selector "cider-selector" "\
+Select a new buffer by type, indicated by a single character.
+The user is prompted for a single character indicating the method by
+which to choose a new buffer. The `?' character describes then
+available methods. OTHER-WINDOW provides an optional target.
+See `def-cider-selector-method' for defining new methods.
+
+\(fn &optional OTHER-WINDOW)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-selector" '("??" "?c" "?e" "?q" "?r" "?m" "?x" "?p" "?d" "?s" "def-cider-selector-method" "cider-selector-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-stacktrace" "cider-stacktrace.el" (0
+;;;;;; 0 0 0))
+;;; Generated autoloads from cider-stacktrace.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-stacktrace" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-test" "cider-test.el" (0 0 0 0))
+;;; Generated autoloads from cider-test.el
+
+(defvar cider-auto-test-mode nil "\
+Non-nil if Cider-Auto-Test mode is enabled.
+See the `cider-auto-test-mode' command
+for a description of this minor mode.
+Setting this variable directly does not take effect;
+either customize it (see the info node `Easy Customization')
+or call the function `cider-auto-test-mode'.")
+
+(custom-autoload 'cider-auto-test-mode "cider-test" nil)
+
+(autoload 'cider-auto-test-mode "cider-test" "\
+Toggle automatic testing of Clojure files.
+
+When enabled this reruns tests every time a Clojure file is loaded.
+Only runs tests corresponding to the loaded file's namespace and does
+nothing if no tests are defined or if the file failed to load.
+
+\(fn &optional ARG)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-test" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-tracing" "cider-tracing.el" (0 0 0 0))
+;;; Generated autoloads from cider-tracing.el
+
+(autoload 'cider-toggle-trace-var "cider-tracing" "\
+Toggle var tracing.
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates.
+
+\(fn ARG)" t nil)
+
+(autoload 'cider-toggle-trace-ns "cider-tracing" "\
+Toggle ns tracing.
+Defaults to the current ns. With prefix arg QUERY, prompts for a ns.
+
+\(fn QUERY)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-tracing" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-util" "cider-util.el" (0 0 0 0))
+;;; Generated autoloads from cider-util.el
+
+(autoload 'cider-view-manual "cider-util" "\
+View the manual in your default browser.
+
+\(fn)" t nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cider-util" '("cider-")))
+
+;;;***
+\f
+;;;### (autoloads nil "nrepl-client" "nrepl-client.el" (0 0 0 0))
+;;; Generated autoloads from nrepl-client.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nrepl-client" '("nrepl-" "cider-enlighten-mode")))
+
+;;;***
+\f
+;;;### (autoloads nil "nrepl-dict" "nrepl-dict.el" (0 0 0 0))
+;;; Generated autoloads from nrepl-dict.el
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "nrepl-dict" '("nrepl-")))
+
+;;;***
+\f
+;;;### (autoloads nil nil ("cider-compat.el" "cider-pkg.el") (0 0
+;;;;;; 0 0))
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; coding: utf-8
+;; End:
+;;; cider-autoloads.el ends here
--- /dev/null
+;;; cider-browse-ns.el --- CIDER namespace browser
+
+;; Copyright © 2014-2018 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-compat)
+(require 'cider-util)
+(require 'nrepl-dict)
+
+(require 'subr-x)
+(require 'easymenu)
+(require 'thingatpt)
+
+(defconst cider-browse-ns-buffer "*cider-ns-browser*")
+
+(defvar-local cider-browse-ns-current-ns 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)
+ (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-str\" and \"macro\" indicates a macro form.
+Only \"arglists-str\" 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--list (buffer title items &optional ns noerase)
+ "Reset contents of BUFFER.
+Display TITLE at the top and ITEMS are indented underneath.
+If NS is non-nil, it is added to each item as the
+`cider-browse-ns-current-ns' text property. If NOERASE is non-nil, the
+contents of the buffer are not reset before inserting TITLE and ITEMS."
+ (with-current-buffer buffer
+ (cider-browse-ns-mode)
+ (let ((inhibit-read-only t))
+ (unless noerase (erase-buffer))
+ (goto-char (point-max))
+ (insert (cider-propertize title 'ns) "\n")
+ (dolist (item items)
+ (insert (propertize (concat " " item "\n")
+ 'cider-browse-ns-current-ns ns)))
+ (goto-char (point-min)))))
+
+(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--items (namespace)
+ "Return the items to show in the namespace browser of the given NAMESPACE.
+Each item consists of a ns-var and the first line of its docstring."
+ (let* ((ns-vars-with-meta (cider-sync-request:ns-vars-with-meta namespace))
+ (propertized-ns-vars (nrepl-dict-map #'cider-browse-ns--properties ns-vars-with-meta)))
+ (mapcar (lambda (ns-var)
+ (let* ((doc (nrepl-dict-get-in ns-vars-with-meta (list ns-var "doc")))
+ ;; to avoid (read nil)
+ ;; it prompts the user for a Lisp expression
+ (doc (when doc (read doc)))
+ (first-doc-line (cider-browse-ns--first-doc-line doc)))
+ (concat ns-var " " (propertize first-doc-line 'font-lock-face 'font-lock-doc-face))))
+ propertized-ns-vars)))
+
+;; 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--items namespace))
+ (setq-local cider-browse-ns-current-ns 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--list (current-buffer)
+ "All loaded namespaces"
+ (mapcar (lambda (name)
+ (cider-browse-ns--properties name nil))
+ names))
+ (setq-local cider-browse-ns-current-ns nil))))
+
+(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 ((line (car (split-string (string-trim (thing-at-point 'line)) " "))))
+ (if (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-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
+
+;; Copyright © 2017 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-compat)
+(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\\)/" fn-name "$") value))
+
+(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\\)/" "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")))
+ ;; 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)) " "))))))
+ (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))
+ (cider--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")
+ (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 © 2018 Kris Jenkins, Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Kris Jenkins <krisajenkinsNOSPAMgmail.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 quick reference system for Clojure. Fast, searchable & available offline.
+
+;; Mostly taken from Kris Jenkins' `clojure-cheatsheet'
+;; See: https://github.com/clojure-emacs/clojure-cheatsheet
+
+;;; Code:
+
+(require 'cider-doc)
+(require 'seq)
+
+(defconst cider-cheatsheet-hierarchy
+ '(("Primitives"
+ ("Numbers"
+ ("Arithmetic"
+ (clojure.core + - * / quot rem mod dec inc max min))
+ ("Compare"
+ (clojure.core = == not= < > <= >= compare))
+ ("Bitwise"
+ (clojure.core bit-and bit-and-not bit-clear bit-flip bit-not bit-or bit-set bit-shift-left bit-shift-right bit-test bit-xor unsigned-bit-shift-right))
+ ("Cast"
+ (clojure.core byte short long int float double bigdec bigint biginteger num rationalize))
+ ("Test"
+ (clojure.core nil? some? identical? zero? pos? neg? even? odd?))
+ ("Random"
+ (clojure.core rand rand-int))
+ ("BigDecimal"
+ (clojure.core with-precision))
+ ("Ratios"
+ (clojure.core numerator denominator ratio?))
+ ("Arbitrary Precision Arithmetic"
+ (clojure.core +\' -\' *\' inc\' dec\'))
+ ("Unchecked"
+ (clojure.core *unchecked-math*
+ unchecked-add
+ unchecked-add-int
+ unchecked-byte
+ unchecked-char
+ unchecked-dec
+ unchecked-dec-int
+ unchecked-divide-int
+ unchecked-double
+ unchecked-float
+ unchecked-inc
+ unchecked-inc-int
+ unchecked-int
+ unchecked-long
+ unchecked-multiply
+ unchecked-multiply-int
+ unchecked-negate
+ unchecked-negate-int
+ unchecked-remainder-int
+ unchecked-short
+ unchecked-subtract
+ unchecked-subtract-int)))
+
+ ("Strings"
+ ("Create"
+ (clojure.core str format))
+ ("Use"
+ (clojure.core count get subs compare)
+ (clojure.string join escape split split-lines replace replace-first reverse re-quote-replacement index-of last-index-of starts-with? ends-with? includes?))
+ ("Regex"
+ (clojure.core re-find re-seq re-matches re-pattern re-matcher re-groups)
+ (clojure.string replace replace-first re-quote-replacement))
+ ("Letters"
+ (clojure.string capitalize lower-case upper-case))
+ ("Trim"
+ (clojure.string trim trim-newline triml trimr))
+ ("Test"
+ (clojure.core char char? string?)
+ (clojure.string blank?)))
+
+ ("Other"
+ ("Characters"
+ (clojure.core char char-name-string char-escape-string))
+ ("Keywords"
+ (clojure.core keyword keyword? find-keyword))
+ ("Symbols"
+ (clojure.core symbol symbol? gensym))
+ ("Data Readers"
+ (clojure.core *data-readers* default-data-readers *default-data-reader-fn*))))
+
+ ("Collections"
+ ("Generic Ops"
+ (clojure.core count bounded-count empty not-empty into conj))
+ ("Tree Walking"
+ (clojure.walk walk prewalk prewalk-demo prewalk-replace postwalk postwalk-demo postwalk-replace keywordize-keys stringify-keys))
+ ("Content tests"
+ (clojure.core distinct? empty? every? not-every? some not-any?))
+ ("Capabilities"
+ (clojure.core sequential? associative? sorted? counted? reversible?))
+ ("Type tests"
+ (clojure.core type class coll? list? vector? set? map? seq?
+ number? integer? float? decimal? class? rational? ratio?
+ chunked-seq? reduced? special-symbol? record?))
+ ("Lists"
+ ("Create"
+ (clojure.core list list*))
+ ("Examine"
+ (clojure.core first nth peek))
+ ("Change"
+ (clojure.core cons conj rest pop)))
+
+ ("Vectors"
+ ("Create"
+ (clojure.core vec vector vector-of))
+ ("Examine"
+ (clojure.core get peek))
+
+ ("Change"
+ (clojure.core assoc pop subvec replace conj rseq))
+ ("Ops"
+ (clojure.core mapv filterv reduce-kv)))
+
+ ("Sets"
+ ("Create"
+ (clojure.core set hash-set sorted-set sorted-set-by))
+ ("Examine"
+ (clojure.core get contains?))
+ ("Change"
+ (clojure.core conj disj))
+ ("Relational Algebra"
+ (clojure.set join select project union difference intersection))
+ ("Get map"
+ (clojure.set index rename-keys rename map-invert))
+ ("Test"
+ (clojure.set subset? superset?))
+ ("Sorted Sets"
+ (clojure.core rseq subseq rsubseq)))
+
+ ("Maps"
+ ("Create"
+ (clojure.core hash-map array-map zipmap sorted-map sorted-map-by bean frequencies group-by))
+ ("Examine"
+ (clojure.core get get-in contains? find keys vals map-entry?))
+ ("Change"
+ (clojure.core assoc assoc-in dissoc merge merge-with select-keys update update-in))
+ ("Entry"
+ (clojure.core key val))
+ ("Sorted Maps"
+ (clojure.core rseq subseq rsubseq)))
+
+ ("Hashes"
+ (clojure.core hash hash-ordered-coll hash-unordered-coll mix-collection-hash))
+
+ ("Volatiles"
+ (clojure.core volatile! volatile? vreset! vswap!)))
+
+ ("Functions"
+ ("Create"
+ (clojure.core fn defn defn- definline identity constantly comp complement partial juxt memfn memoize fnil every-pred some-fn trampoline))
+ ("Call"
+ (clojure.core -> ->> some-> some->> as-> cond-> cond->>))
+ ("Test"
+ (clojure.core fn? ifn?)))
+
+ ("Transducers"
+ ("Create"
+ (clojure.core cat dedupe distinct drop drop-while filter halt-when interpose keep keep-indexed map map-indexed mapcat partition-all partition-by random-sample remove replace take take-nth take-while))
+ ("Call"
+ (clojure.core ->Eduction eduction into sequence transduce completing run!))
+ ("Early Termination"
+ (clojure.core deref reduced reduced? ensure-reduced unreduced)))
+
+ ("Spec"
+ ("Operations"
+ (clojure.spec.alpha valid? conform unform explain explain-data explain-str explain-out form describe assert check-asserts check-asserts?))
+ ("Generator Ops"
+ (clojure.spec.alpha gen exercise exercise-fn))
+ ("Defn & Registry"
+ (clojure.spec.alpha def fdef registry get-spec spec? spec with-gen))
+ ("Logical"
+ (clojure.spec.alpha and or))
+ ("Collection"
+ (clojure.spec.alpha coll-of map-of every every-kv keys merge))
+ ("Regex "
+ (clojure.spec.alpha cat alt * + \? & keys*))
+ ("Range"
+ (clojure.spec.alpha int-in inst-in double-in int-in-range? inst-in-range?))
+ ("Custom Explain"
+ (clojure.spec.alpha explain-printer *explain-out*))
+ ("Other"
+ (clojure.spec.alpha nilable multi-spec fspec conformer))
+
+ ("Predicates with test.check generators"
+ ("Numbers"
+ (clojure.core number? rational? integer? ratio? decimal? float? zero? double? int? nat-int? neg-int? pos-int?))
+ ("Symbols & Keywords"
+ (clojure.core keyword? symbol? ident? qualified-ident? qualified-keyword? qualified-symbol? simple-ident? simple-keyword? simple-symbol?))
+ ("Scalars"
+ (clojure.core string? true? false? nil? some? boolean? bytes? inst? uri? uuid?))
+ ("Collections"
+ (clojure.core list? map? set? vector? associative? coll? sequential? seq? empty? indexed? seqable?))
+ ("Other"
+ (clojure.core any?))))
+
+ ("Other"
+ ("XML"
+ (clojure.core xml-seq)
+ (clojure.xml parse))
+ ("REPL"
+ (clojure.core *1 *2 *3 *e *print-dup* *print-length* *print-level* *print-meta* *print-readably*))
+ ("EDN"
+ (clojure.edn read read-string))
+ ("Compiling Code & Class Generation"
+ (clojure.core *compile-files* *compile-path* *file* *warn-on-reflection* compile gen-class gen-interface loaded-libs test))
+ ("Misc"
+ (clojure.core eval force name *clojure-version* clojure-version *command-line-args*))
+ ("Pretty Printing"
+ (clojure.pprint pprint print-table pp *print-right-margin*))
+ ("Browser / Shell"
+ (clojure.java.browse browse-url)
+ (clojure.java.shell sh with-sh-dir with-sh-env)))
+
+ ("Vars & Global Environment"
+ ("Def Variants"
+ (:special def)
+ (clojure.core defn defn- definline defmacro defmethod defmulti defonce defrecord))
+ ("Interned Vars"
+ (:special var)
+ (clojure.core declare intern binding find-var))
+ ("Var Objects"
+ (clojure.core with-local-vars var-get var-set alter-var-root var?))
+ ("Var Validators"
+ (clojure.core set-validator! get-validator)))
+
+ ("Reader Conditionals"
+ (clojure.core reader-conditional reader-conditional? tagged-literal tagged-literal?))
+
+ ("Abstractions"
+ ("Protocols"
+ (clojure.core defprotocol extend extend-type extend-protocol reify extends? satisfies? extenders))
+ ("Records & Types"
+ (clojure.core defrecord deftype))
+ ("Multimethods"
+ ("Define"
+ (clojure.core defmulti defmethod))
+ ("Dispatch"
+ (clojure.core get-method methods))
+ ("Remove"
+ (clojure.core remove-method remove-all-methods))
+ ("Prefer"
+ (clojure.core prefer-method prefers))
+ ("Relation"
+ (clojure.core derive isa? parents ancestors descendants make-hierarchy))))
+
+ ("Macros"
+ ("Create"
+ (clojure.core defmacro definline))
+ ("Debug"
+ (clojure.core macroexpand-1 macroexpand)
+ (clojure.walk macroexpand-all))
+ ("Branch"
+ (clojure.core and or when when-not when-let when-first if-not if-let cond condp case))
+ ("Loop"
+ (clojure.core for doseq dotimes while))
+ ("Arrange"
+ (clojure.core .. doto ->))
+ ("Scope"
+ (clojure.core binding locking time)
+ (clojure.core with-in-str with-local-vars with-open with-out-str with-precision with-redefs with-redefs-fn))
+ ("Lazy"
+ (clojure.core lazy-cat lazy-seq delay delay?))
+ ("Doc"
+ (clojure.core assert comment)
+ (clojure.repl doc dir dir-fn source-fn)))
+
+ ("Java Interop"
+ ("General"
+ (:special new set!)
+ (clojure.core .. doto bean comparator enumeration-seq import iterator-seq memfn definterface supers bases))
+ ("Cast"
+ (clojure.core boolean byte short char int long float double bigdec bigint num cast biginteger))
+ ("Exceptions"
+ (:special throw try catch finally)
+ (clojure.core ex-info ex-data Throwable->map StackTraceElement->vec)
+ (clojure.repl pst))
+ ("Arrays"
+ ("Create"
+ (clojure.core boolean-array byte-array double-array char-array float-array int-array long-array make-array object-array short-array to-array))
+ ("Manipulate"
+ (clojure.core aclone aget aset alength amap areduce aset-int aset-long aset-short aset-boolean aset-byte aset-char aset-double aset-float))
+ ("Cast"
+ (clojure.core booleans bytes chars doubles floats ints longs shorts)))
+ ("Proxy"
+ ("Create"
+ (clojure.core proxy get-proxy-class construct-proxy init-proxy))
+ ("Misc"
+ (clojure.core proxy-mappings proxy-super update-proxy))))
+
+ ("Namespaces"
+ ("Current"
+ (clojure.core *ns*))
+ ("Create Switch"
+ (clojure.core ns in-ns create-ns))
+ ("Add"
+ (clojure.core alias import intern refer refer-clojure))
+ ("Find"
+ (clojure.core all-ns find-ns))
+ ("Examine"
+ (clojure.core ns-aliases ns-imports ns-interns ns-map ns-name ns-publics ns-refers))
+ ("From symbol"
+ (clojure.core resolve namespace ns-resolve the-ns))
+ ("Remove"
+ (clojure.core ns-unalias ns-unmap remove-ns)))
+ ("Loading"
+ ("Load libs"
+ (clojure.core require use import refer))
+ ("List Loaded"
+ (clojure.core loaded-libs))
+ ("Load Misc"
+ (clojure.core load load-file load-reader load-string)))
+
+ ("Concurrency"
+ ("Atoms"
+ (clojure.core atom swap! swap-vals! reset! reset-vals! compare-and-set!))
+ ("Futures"
+ (clojure.core future future-call future-cancel future-cancelled? future-done? future?))
+ ("Threads"
+ (clojure.core bound-fn bound-fn* get-thread-bindings pop-thread-bindings push-thread-bindings))
+
+ ("Misc"
+ (clojure.core locking pcalls pvalues pmap seque promise deliver))
+
+ ("Refs & Transactions"
+ ("Create"
+ (clojure.core ref))
+ ("Examine"
+ (clojure.core deref))
+ ("Transaction"
+ (clojure.core sync dosync io!))
+ ("In Transaction"
+ (clojure.core ensure ref-set alter commute))
+ ("Validators"
+ (clojure.core get-validator set-validator!))
+ ("History"
+ (clojure.core ref-history-count ref-max-history ref-min-history)))
+
+ ("Agents & Asynchronous Actions"
+ ("Create"
+ (clojure.core agent))
+ ("Examine"
+ (clojure.core agent-error))
+ ("Change State"
+ (clojure.core send send-off restart-agent send-via set-agent-send-executor! set-agent-send-off-executor!))
+ ("Block Waiting"
+ (clojure.core await await-for))
+ ("Ref Validators"
+ (clojure.core get-validator set-validator!))
+ ("Watchers"
+ (clojure.core add-watch remove-watch))
+ ("Thread Handling"
+ (clojure.core shutdown-agents))
+ ("Error"
+ (clojure.core error-handler set-error-handler! error-mode set-error-mode!))
+ ("Misc"
+ (clojure.core *agent* release-pending-sends))))
+
+ ("Sequences"
+ ("Creating a Lazy Seq"
+ ("From Collection"
+ (clojure.core seq sequence keys vals rseq subseq rsubseq))
+ ("From Producer Fn"
+ (clojure.core lazy-seq repeatedly iterate))
+ ("From Constant"
+ (clojure.core repeat range))
+ ("From Other"
+ (clojure.core file-seq line-seq resultset-seq re-seq tree-seq xml-seq iterator-seq enumeration-seq))
+ ("From Seq"
+ (clojure.core keep keep-indexed)))
+
+ ("Seq in, Seq out"
+ ("Get shorter"
+ (clojure.core distinct dedupe filter remove for))
+ ("Get longer"
+ (clojure.core cons conj concat lazy-cat mapcat cycle interleave interpose)))
+ ("Tail-items"
+ (clojure.core rest nthrest fnext nnext drop drop-while take-last for))
+ ("Head-items"
+ (clojure.core take take-nth take-while butlast drop-last for))
+ ("Change"
+ (clojure.core conj concat distinct flatten group-by partition partition-all partition-by split-at split-with filter remove replace shuffle random-sample))
+ ("Rearrange"
+ (clojure.core reverse sort sort-by compare))
+ ("Process items"
+ (clojure.core map pmap map-indexed mapcat for replace seque))
+
+ ("Using a Seq"
+ ("Extract item"
+ (clojure.core first second last rest next ffirst nfirst fnext nnext nth nthnext rand-nth when-first max-key min-key))
+ ("Construct coll"
+ (clojure.core zipmap into reduce reductions set vec into-array to-array-2d))
+ ("Pass to fn"
+ (clojure.core apply))
+ ("Search"
+ (clojure.core some filter))
+ ("Force evaluation"
+ (clojure.core doseq dorun doall))
+ ("Check for forced"
+ (clojure.core realized?))))
+
+ ("Zippers"
+ ("Create"
+ (clojure.zip zipper seq-zip vector-zip xml-zip))
+ ("Get loc"
+ (clojure.zip up down left right leftmost rightmost))
+ ("Get seq"
+ (clojure.zip lefts rights path children))
+ ("Change"
+ (clojure.zip make-node replace edit insert-child insert-left insert-right append-child remove))
+ ("Move"
+ (clojure.zip next prev))
+ ("XML"
+ (clojure.data.zip.xml attr attr= seq-test tag= text text= xml-> xml1->))
+ ("Misc"
+ (clojure.zip root node branch? end?)))
+
+ ("Documentation"
+ ("REPL"
+ (clojure.repl doc find-doc apropos source pst)
+ (clojure.java.javadoc javadoc)))
+
+ ("Transients"
+ ("Create"
+ (clojure.core transient persistent!))
+ ("Change"
+ (clojure.core conj! pop! assoc! dissoc! disj!)))
+ ("Misc"
+ ("Compare"
+ (clojure.core = == identical? not= not compare)
+ (clojure.data diff))
+ ("Test"
+ (clojure.core true? false? nil? instance?)))
+
+ ("IO"
+ ("To/from ..."
+ (clojure.core spit slurp))
+ ("To *out*"
+ (clojure.core pr prn print printf println newline)
+ (clojure.pprint print-table))
+ ("To writer"
+ (clojure.pprint pprint cl-format))
+ ("To string"
+ (clojure.core format with-out-str pr-str prn-str print-str println-str))
+ ("From *in*"
+ (clojure.core read-line read))
+ ("From reader"
+ (clojure.core line-seq read))
+ ("From string"
+ (clojure.core read-string with-in-str))
+ ("Open"
+ (clojure.core with-open)
+ (clojure.java.io reader writer input-stream output-stream))
+ ("Interop"
+ (clojure.java.io make-writer make-reader make-output-stream make-input-stream))
+ ("Misc"
+ (clojure.core flush file-seq *in* *out* *err*)
+ (clojure.java.io file copy delete-file resource as-file as-url as-relative-path make-parents)))
+
+ ("Metadata"
+ (clojure.core meta with-meta alter-meta! reset-meta! vary-meta))
+
+ ("Special Forms"
+ (:special def if do quote var recur throw try monitor-enter monitor-exit)
+ (clojure.core fn loop)
+ ("Binding / Destructuring"
+ (clojure.core let fn letfn defn defmacro loop for doseq if-let if-some when-let when-some)))
+
+ ("Async"
+ ("Main"
+ (clojure.core.async go go-loop <! <!! >! >!! chan put! take take! close! timeout offer! poll! promise-chan))
+ ("Choice"
+ (clojure.core.async alt! alt!! alts! alts!! do-alts))
+ ("Buffering"
+ (clojure.core.async buffer dropping-buffer sliding-buffer unblocking-buffer?))
+ ("Pipelines"
+ (clojure.core.async pipeline pipeline-async pipeline-blocking))
+ ("Threading"
+ (clojure.core.async thread thread-call))
+ ("Mixing"
+ (clojure.core.async admix solo-mode mix unmix unmix-all toggle merge pipe unique))
+ ("Multiples"
+ (clojure.core.async mult tap untap untap-all))
+ ("Publish/Subscribe"
+ (clojure.core.async pub sub unsub unsub-all))
+ ("Higher Order"
+ (clojure.core.async filter< filter> map map< map> mapcat< mapcat> partition partition-by reduce remove< remove> split))
+ ("Pre-Populate"
+ (clojure.core.async into onto-chan to-chan)))
+ ("Unit Tests"
+ ("Defining"
+ (clojure.test deftest deftest- testing is are))
+ ("Running"
+ (clojure.test run-tests run-all-tests test-vars))
+ ("Fixtures"
+ (clojure.test use-fixtures join-fixtures compose-fixtures))))
+ "A data structure for Clojure cheatsheet information.
+
+It's a tree, where the head of each list determines the context of the rest
+of the list. The head may be:
+
+ - A string, in which case it's a (sub)heading for the rest of the items.
+
+ - A symbol, in which case it's the Clojure namespace of the symbols that
+ follow it.
+
+ - The keyword :special, in which case it's a Clojure special form
+
+ - Any other keyword, in which case it's a typed item that will be passed
+ through.
+
+Note that some Clojure symbols appear in more than once. This is entirely
+intentional. For instance, `map` belongs in the sections on collections
+and transducers.")
+
+(defun cider-cheatsheet--expand-vars (list)
+ "Expand the symbols in LIST to fully-qualified var names.
+
+This list is supposed to have the following format:
+
+ (my-ns var1 var2 var3)"
+ (let ((ns (car list))
+ (vars (cdr list)))
+ (if (eq ns :special)
+ (mapcar #'symbol-name vars)
+ (mapcar (lambda (var) (format "%s/%s" ns var)) vars))))
+
+(defun cider-cheatsheet--select-var (var-list)
+ "Expand the symbols in VAR-LIST to fully-qualified var names.
+
+The list can hold one or more lists inside - one per each namespace."
+ (let ((namespaced-vars (seq-mapcat #'cider-cheatsheet--expand-vars
+ (seq-remove (lambda (list)
+ (eq (car list) :url))
+ var-list))))
+ (cider-doc-lookup (completing-read "Select var: " namespaced-vars))))
+
+;;;###autoload
+(defun cider-cheatsheet ()
+ "Navigate `cider-cheatsheet-hierarchy' with `completing-read'.
+
+When you make it to a Clojure var its doc buffer gets displayed."
+ (interactive)
+ (let ((cheatsheet-data cider-cheatsheet-hierarchy))
+ (while (stringp (caar cheatsheet-data))
+ (let* ((sections (mapcar #'car cheatsheet-data))
+ (sel-section (completing-read "Select cheatsheet section: " sections))
+ (section-data (seq-find (lambda (elem) (equal (car elem) sel-section)) cheatsheet-data)))
+ (setq cheatsheet-data (cdr section-data))))
+ (cider-cheatsheet--select-var cheatsheet-data)))
+
+(provide 'cider-cheatsheet)
+
+;;; cider-cheatsheet.el ends here
--- /dev/null
+;;; cider-classpath.el --- Basic Java classpath browser
+
+;; Copyright © 2014-2018 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)
+(require 'cider-compat)
+
+(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)
+ (cider-ensure-op-supported "classpath")
+ (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-sync-request:classpath)))))
+
+;;;###autoload
+(defun cider-open-classpath-entry ()
+ "Open a classpath entry."
+ (interactive)
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "classpath")
+ (when-let* ((entry (completing-read "Classpath entries: " (cider-sync-request:classpath))))
+ (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-2018 Bozhidar Batsov
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.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 layer of abstraction above the low-level nREPL client code.
+
+;;; Code:
+
+(require 'spinner)
+(require 'nrepl-client)
+(require 'cider-connection)
+(require 'cider-common)
+(require 'cider-util)
+(require 'clojure-mode)
+
+(require 'subr-x)
+(require 'cider-compat)
+(require 'seq)
+
+\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"))
+
+(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-handler (eval-buffer original-callback)
+ "Return a response handler to stop the spinner and call ORIGINAL-CALLBACK.
+EVAL-BUFFER is the buffer where the spinner was started."
+ (lambda (response)
+ ;; 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))))
+ (funcall original-callback response)))
+
+\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)
+ "Return the current ns.
+The ns is extracted from the ns form for Clojure buffers and from
+`cider-buffer-ns' for all other buffers. If it's missing, use the current
+REPL's ns, otherwise fall back to \"user\". When NO-DEFAULT is non-nil, it
+will return nil instead of \"user\"."
+ (or cider-buffer-ns
+ (clojure-find-ns)
+ (when-let* ((repl (cider-current-repl)))
+ (buffer-local-value 'cider-buffer-ns repl))
+ (if no-default nil "user")))
+
+(defun cider-expected-ns (&optional path)
+ "Return the namespace string matching PATH, or nil if not found.
+PATH is expected to be an absolute file path. 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 (or path (file-truename (buffer-file-name))))
+ (relpath (thread-last (cider-sync-request:classpath)
+ (seq-map
+ (lambda (cp)
+ (when (string-prefix-p cp path)
+ (substring path (length cp)))))
+ (seq-filter #'identity)
+ (seq-sort (lambda (a b)
+ (< (length a) (length b))))
+ (car))))
+ (if relpath
+ (thread-last (substring relpath 1) ; remove leading /
+ (file-name-sans-extension)
+ (replace-regexp-in-string "/" ".")
+ (replace-regexp-in-string "_" "-"))
+ (clojure-expected-ns path)))
+ (clojure-expected-ns path)))
+
+(defun cider-nrepl-op-supported-p (op &optional connection)
+ "Check whether the CONNECTION supports the nREPL middleware OP."
+ (nrepl-op-supported-p op (or connection (cider-current-repl))))
+
+(defvar cider-version)
+(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)
+ "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."
+ (nrepl-send-request request callback (or connection (cider-current-repl "any"))))
+
+(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"))
+ 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")))
+ (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))))
+ (nrepl-request:eval input
+ (if cider-show-eval-spinner
+ (cider-eval-spinner-handler connection callback)
+ callback)
+ 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)) ns))
+
+(defcustom cider-pprint-fn 'pprint
+ "Sets the function to use when pretty-printing evaluation results.
+
+The value must be one of the following symbols:
+
+`pprint' - to use \\=`clojure.pprint/pprint\\=`
+
+`fipp' - to use the Fast Idiomatic Pretty Printer, approximately 5-10x
+faster than \\=`clojure.core/pprint\\=` (this is the default)
+
+`puget' - to use Puget, which provides canonical serialization of data on
+top of fipp, but at a slight performance cost
+
+Alternatively, can be the namespace-qualified name of a Clojure function of
+one argument. If the function cannot be resolved, an exception will be
+thrown.
+
+The function is assumed to respect the contract of \\=`clojure.pprint/pprint\\=`
+with respect to the bound values of \\=`*print-length*\\=`, \\=`*print-level*\\=`,
+\\=`*print-meta*\\=`, and \\=`clojure.pprint/*print-right-margin*\\=`."
+ :type '(choice (const pprint)
+ (const fipp)
+ (const puget)
+ string)
+ :group 'cider
+ :package-version '(cider . "0.11.0"))
+
+(defun cider--pprint-fn ()
+ "Return the value to send in the pprint-fn slot of messages."
+ (pcase cider-pprint-fn
+ (`pprint "clojure.pprint/pprint")
+ (`fipp "cider.nrepl.middleware.pprint/fipp-pprint")
+ (`puget "cider.nrepl.middleware.pprint/puget-pprint")
+ (_ cider-pprint-fn)))
+
+(defun cider--nrepl-pprint-request-plist (right-margin &optional pprint-fn)
+ "Plist to be appended to an eval request to make it use pprint.
+PPRINT-FN is the name of the Clojure function to use.
+RIGHT-MARGIN specifies the maximum column-width of the pretty-printed
+result, and is included in the request if non-nil."
+ (nconc `("pprint" "true"
+ "pprint-fn" ,(or pprint-fn (cider--pprint-fn)))
+ (and right-margin `("print-right-margin" ,right-margin))))
+
+(defun cider--nrepl-content-type-plist ()
+ "Plist to be appended to 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))
+ 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))
+ ns
+ 'tooling))
+
+;; TODO: Add some unit tests and pretty those two functions up.
+;; FIXME: Currently that's broken for group-id with multiple segments (e.g. org.clojure/clojure)
+(defun cider-classpath-libs ()
+ "Return a list of all libs on the classpath."
+ (let ((libs (seq-filter (lambda (cp-entry)
+ (string-suffix-p ".jar" cp-entry))
+ (cider-sync-request:classpath)))
+ (dir-sep (if (string-equal system-type "windows-nt") "\\\\" "/")))
+ (thread-last libs
+ (seq-map (lambda (s) (split-string s dir-sep)))
+ (seq-map #'reverse)
+ (seq-map (lambda (l) (reverse (seq-take l 4)))))))
+
+(defun cider-library-present-p (lib)
+ "Check whether LIB is present on the classpath.
+The library is a string of the format \"group-id/artifact-id\"."
+ (let* ((lib (split-string lib "/"))
+ (group-id (car lib))
+ (artifact-id (cadr lib)))
+ (seq-find (lambda (lib)
+ (let ((g (car lib))
+ (a (cadr lib)))
+ (and (equal group-id g) (equal artifact-id a))))
+ (cider-classpath-libs))))
+
+\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)
+ (let ((pending-request-ids (cider-util--hash-keys nrepl-pending-requests)))
+ (dolist (request-id pending-request-ids)
+ (nrepl-request:interrupt
+ request-id
+ (cider-interrupt-handler (current-buffer))
+ (cider-current-repl))))))
+
+(defun cider-nrepl-eval-session ()
+ "Return the eval nREPL session id of the current connection."
+ (with-current-buffer (cider-current-repl)
+ nrepl-session))
+
+(defun cider-nrepl-tooling-session ()
+ "Return the tooling nREPL session id of the current connection."
+ (with-current-buffer (cider-current-repl)
+ nrepl-tooling-session))
+
+(defun cider--var-choice (var-info)
+ "Prompt to choose from among multiple VAR-INFO candidates, if required.
+This is needed only when the symbol queried is an unqualified host platform
+method, and multiple classes have a so-named member. If VAR-INFO does not
+contain a `candidates' key, it is returned as is."
+ (let ((candidates (nrepl-dict-get var-info "candidates")))
+ (if candidates
+ (let* ((classes (nrepl-dict-keys candidates))
+ (choice (completing-read "Member in class: " classes nil t))
+ (info (nrepl-dict-get candidates choice)))
+ info)
+ var-info)))
+
+(defun cider-var-info (var &optional all)
+ "Return VAR's info as an alist with list cdrs.
+When multiple matching vars are returned you'll be prompted to select one,
+unless ALL is truthy."
+ (when (and var (not (string= var "")))
+ (let ((var-info (cider-sync-request:info var)))
+ (if all var-info (cider--var-choice var-info)))))
+
+(defun cider-member-info (class member)
+ "Return the CLASS MEMBER's info as an alist with list cdrs."
+ (when (and class member)
+ (cider-sync-request:info nil class member)))
+
+\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" "^clojure.tools.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"))
+ "filter-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-sync-request:complete (str context)
+ "Return a list of completions for STR using nREPL's \"complete\" op.
+CONTEXT represents a completion context for compliment."
+ (when-let* ((dict (thread-first `("op" "complete"
+ "ns" ,(cider-current-ns)
+ "symbol" ,str
+ "context" ,context)
+ (cider-nrepl-send-sync-request nil '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))
+ 'abort-on-input))
+
+(defun cider-sync-request:info (symbol &optional class member)
+ "Send \"info\" op with parameters SYMBOL or CLASS and MEMBER."
+ (let ((var-info (thread-first `("op" "info"
+ "ns" ,(cider-current-ns)
+ ,@(when symbol `("symbol" ,symbol))
+ ,@(when class `("class" ,class))
+ ,@(when member `("member" ,member)))
+ (cider-nrepl-send-sync-request))))
+ (if (member "no-info" (nrepl-dict-get var-info "status"))
+ nil
+ var-info)))
+
+(defun cider-sync-request:eldoc (symbol &optional class member)
+ "Send \"eldoc\" op with parameters SYMBOL or CLASS and MEMBER."
+ (when-let* ((eldoc (thread-first `("op" "eldoc"
+ "ns" ,(cider-current-ns)
+ ,@(when symbol `("symbol" ,symbol))
+ ,@(when class `("class" ,class))
+ ,@(when member `("member" ,member)))
+ (cider-nrepl-send-sync-request nil '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 `("symbol" ,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)
+ (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)
+ (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"
+ "filter-regexps" ,cider-filtered-namespaces-regexps)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "ns-list")))
+
+(defun cider-sync-request:ns-vars (ns)
+ "Get a list of the vars in NS."
+ (thread-first `("op" "ns-vars"
+ "ns" ,ns)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "ns-vars")))
+
+(defun cider-sync-request:ns-path (ns)
+ "Get the path to the file containing NS."
+ (thread-first `("op" "ns-path"
+ "ns" ,ns)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "path")))
+
+(defun cider-sync-request:ns-vars-with-meta (ns)
+ "Get a map of the vars in NS to its metadata information."
+ (thread-first `("op" "ns-vars-with-meta"
+ "ns" ,ns)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "ns-vars-with-meta")))
+
+(defun cider-sync-request: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:format-code (code)
+ "Perform nREPL \"format-code\" op with CODE."
+ (thread-first `("op" "format-code"
+ "code" ,code)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "formatted-code")))
+
+(defun cider-sync-request:format-edn (edn right-margin)
+ "Perform \"format-edn\" op with EDN and RIGHT-MARGIN."
+ (let* ((response (thread-first `("op" "format-edn"
+ "edn" ,edn)
+ (append (cider--nrepl-pprint-request-plist right-margin))
+ (cider-nrepl-send-sync-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-common.el --- Common use functions -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2018 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 'cider-compat)
+(require 'nrepl-dict)
+(require 'cider-util)
+(require 'etags) ; for find-tags-marker-ring
+(require 'tramp)
+
+(defcustom cider-prompt-for-symbol t
+ "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 is used to invert the semantics of the function `cider--should-prompt-for-symbol'."
+ (if (cider--should-prompt-for-symbol invert)
+ #'cider-read-symbol-name
+ #'cider-try-symbol-at-point))
+
+(defun cider--kw-to-symbol (kw)
+ "Convert the keyword KW to a symbol."
+ (when kw
+ (replace-regexp-in-string "\\`:+" "" kw)))
+
+;;; Minibuffer
+(defvar cider-minibuffer-history '()
+ "History list of expressions read from the minibuffer.")
+
+(defvar cider-minibuffer-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map (kbd "TAB") #'complete-symbol)
+ (define-key map (kbd "M-TAB") #'complete-symbol)
+ map)
+ "Minibuffer keymap used for reading Clojure expressions.")
+
+(declare-function cider-complete-at-point "cider-completion")
+(declare-function cider-eldoc "cider-eldoc")
+(defun cider-read-from-minibuffer (prompt &optional value)
+ "Read a string from the minibuffer, prompting with PROMPT.
+If VALUE is non-nil, it is inserted into the minibuffer as initial-input.
+PROMPT need not end with \": \". If it doesn't, VALUE is displayed on the
+prompt as a default value (used if the user doesn't type anything) and is
+not used as initial input (input is left empty)."
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (set-syntax-table clojure-mode-syntax-table)
+ (add-hook 'completion-at-point-functions
+ #'cider-complete-at-point nil t)
+ (setq-local eldoc-documentation-function #'cider-eldoc)
+ (run-hooks 'eval-expression-minibuffer-setup-hook))
+ (let* ((has-colon (string-match ": \\'" prompt))
+ (input (read-from-minibuffer (cond
+ (has-colon prompt)
+ (value (format "%s (default %s): " prompt value))
+ (t (format "%s: " prompt)))
+ (when has-colon value) ; initial-input
+ cider-minibuffer-map nil
+ 'cider-minibuffer-history
+ (unless has-colon value)))) ; default-value
+ (if (and (equal input "") value (not has-colon))
+ value
+ input))))
+
+(defun cider-read-symbol-name (prompt callback)
+ "Read a symbol name using PROMPT with a default of the one at point.
+Use CALLBACK as the completing read var callback."
+ (funcall callback (cider-read-from-minibuffer
+ prompt
+ ;; if the thing at point is a keyword we treat it as symbol
+ (cider--kw-to-symbol (cider-symbol-at-point 'look-back)))))
+
+(defun cider-try-symbol-at-point (prompt callback)
+ "Call CALLBACK with symbol at point.
+On failure, read a symbol name using PROMPT and call CALLBACK with that."
+ (condition-case nil (funcall callback (cider--kw-to-symbol (cider-symbol-at-point 'look-back)))
+ ('error (funcall callback (cider-read-from-minibuffer prompt)))))
+
+(declare-function cider-mode "cider-mode")
+
+(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
+ (ring-insert find-tag-marker-ring (point-marker)))
+ (if other-window
+ (pop-to-buffer buffer)
+ ;; like switch-to-buffer, but reuse existing window if BUFFER is visible
+ (pop-to-buffer buffer '((display-buffer-reuse-window display-buffer-same-window))))
+ (with-current-buffer buffer
+ (widen)
+ (goto-char (point-min))
+ (cider-mode +1)
+ (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))))
+ (t nil))))
+
+(defun cider--find-buffer-for-file (file)
+ "Return a buffer visiting FILE.
+If FILE is a temp buffer name, return that buffer."
+ (if (string-prefix-p "*" file)
+ file
+ (and file
+ (not (cider--tooling-file-p file))
+ (cider-find-file file))))
+
+(defun cider--jump-to-loc-from-info (info &optional other-window)
+ "Jump to location give by INFO.
+INFO object is returned by `cider-var-info' or `cider-member-info'.
+OTHER-WINDOW is passed to `cider-jump-to'."
+ (let* ((line (nrepl-dict-get info "line"))
+ (file (nrepl-dict-get info "file"))
+ (name (nrepl-dict-get info "name"))
+ ;; the filename might actually be a REPL buffer name
+ (buffer (cider--find-buffer-for-file file)))
+ (if buffer
+ (cider-jump-to buffer (if line (cons line nil) name) other-window)
+ (error "No source location"))))
+
+(declare-function url-filename "url-parse" (cl-x) t)
+
+(defun cider--url-to-file (url)
+ "Return the filename from the resource URL.
+Uses `url-generic-parse-url' to parse the url. The filename is extracted and
+then url decoded. If the decoded filename has a Windows device letter followed
+by a colon immediately after the leading '/' then the leading '/' is dropped to
+create a valid path."
+ (let ((filename (url-unhex-string (url-filename (url-generic-parse-url url)))))
+ (if (string-match "^/\\([a-zA-Z]:/.*\\)" filename)
+ (match-string 1 filename)
+ filename)))
+
+(defun cider-make-tramp-prefix (method user host)
+ "Constructs a Tramp file prefix from METHOD, USER, HOST.
+It originated from Tramp's `tramp-make-tramp-file-name'. The original be
+forced to make full file name with `with-parsed-tramp-file-name', not providing
+prefix only option."
+ (concat tramp-prefix-format
+ (unless (zerop (length method))
+ (concat method tramp-postfix-method-format))
+ (unless (zerop (length user))
+ (concat user tramp-postfix-user-format))
+ (when host
+ (if (string-match tramp-ipv6-regexp host)
+ (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format)
+ host))
+ tramp-postfix-host-format))
+
+(defun cider-tramp-prefix (&optional buffer)
+ "Use the filename for BUFFER to determine a tramp prefix.
+Defaults to the current buffer. Return the tramp prefix, or nil
+if BUFFER is local."
+ (let* ((buffer (or buffer (current-buffer)))
+ (name (or (buffer-file-name buffer)
+ (with-current-buffer buffer
+ default-directory))))
+ (when (tramp-tramp-file-p name)
+ (with-parsed-tramp-file-name name v
+ (with-no-warnings
+ (cider-make-tramp-prefix v-method v-user v-host))))))
+
+(defun cider--client-tramp-filename (name &optional buffer)
+ "Return the tramp filename for path NAME relative to BUFFER.
+If BUFFER has a tramp prefix, it will be added as a prefix to NAME.
+If the resulting path is an existing tramp file, it returns the path,
+otherwise, nil."
+ (let* ((buffer (or buffer (current-buffer)))
+ (name (replace-regexp-in-string "^file:" "" name))
+ (name (concat (cider-tramp-prefix buffer) name)))
+ (if (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))
+
+(defvar cider-from-nrepl-filename-function
+ (with-no-warnings
+ (if (eq system-type 'cygwin)
+ #'cygwin-convert-file-name-from-windows
+ #'identity))
+ "Function to translate nREPL namestrings to Emacs filenames.")
+
+(defcustom cider-prefer-local-resources nil
+ "Prefer local resources to remote (tramp) ones when both are available."
+ :type 'boolean
+ :group 'cider)
+
+(defun cider--file-path (path)
+ "Return PATH's local or tramp path using `cider-prefer-local-resources'.
+If no local or remote file exists, return nil."
+ (let* ((local-path (funcall cider-from-nrepl-filename-function path))
+ (tramp-path (and local-path (cider--client-tramp-filename local-path))))
+ (cond ((equal local-path "") "")
+ ((and cider-prefer-local-resources (file-exists-p local-path))
+ local-path)
+ ((and tramp-path (file-exists-p tramp-path))
+ tramp-path)
+ ((and local-path (file-exists-p local-path))
+ local-path))))
+
+(declare-function archive-extract "arc-mode")
+(declare-function archive-zip-extract "arc-mode")
+
+(defun cider-find-file (url)
+ "Return a buffer visiting the file URL if it exists, or nil otherwise.
+If URL has a scheme prefix, it must represent a fully-qualified file path
+or an entry within a zip/jar archive. If AVFS (archive virtual file
+system; see online docs) is mounted the archive entry is opened inside the
+AVFS directory, otherwise the entry is archived into a temporary read-only
+buffer. If URL doesn't contain a scheme prefix and is an absolute path, it
+is treated as such. Finally, if URL is relative, it is expanded within each
+of the open Clojure buffers till an existing file ending with URL has been
+found."
+ (require 'arc-mode)
+ (cond ((string-match "^file:\\(.+\\)" url)
+ (when-let* ((file (cider--url-to-file (match-string 1 url)))
+ (path (cider--file-path file)))
+ (find-file-noselect path)))
+ ((string-match "^\\(jar\\|zip\\):\\(file:.+\\)!/\\(.+\\)" url)
+ (when-let* ((entry (match-string 3 url))
+ (file (cider--url-to-file (match-string 2 url)))
+ (path (cider--file-path file))
+ (name (format "%s:%s" path entry))
+ (avfs (format "%s%s#uzip/%s"
+ (expand-file-name (or (getenv "AVFSBASE") "~/.avfs/"))
+ path entry)))
+ (cond
+ ;; 1) use avfs
+ ((file-exists-p avfs)
+ (find-file-noselect avfs))
+ ;; 2) already uncompressed
+ ((find-buffer-visiting name))
+ ;; 3) on remotes use Emacs built-in archiving
+ ((tramp-tramp-file-p path)
+ (find-file path)
+ (goto-char (point-min))
+ ;; anchor to eol to prevent eg. clj matching cljs.
+ (re-search-forward (concat entry "$"))
+ (let ((archive-buffer (current-buffer)))
+ (archive-extract)
+ (kill-buffer archive-buffer))
+ (current-buffer))
+ ;; 4) Use external zip program to extract a single file
+ (t
+ (with-current-buffer (generate-new-buffer
+ (file-name-nondirectory entry))
+ (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-compat.el --- Functions from newer Emacs versions for compatibility -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba 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:
+
+;; Everything here was copied from subr-x for compatibility with
+;; Emacs 25.1.
+
+;;; Code:
+
+(eval-and-compile
+
+ (unless (fboundp 'if-let*)
+ (defmacro if-let* (bindings then &rest else)
+ "Process BINDINGS and if all values are non-nil eval THEN, else ELSE.
+Argument BINDINGS is a list of tuples whose car is a symbol to be
+bound and (optionally) used in THEN, and its cadr is a sexp to be
+evalled to set symbol's value."
+ (declare (indent 2)
+ (debug ([&or (&rest (symbolp form)) (symbolp form)] form body)))
+ `(let* ,(internal--build-bindings bindings)
+ (if ,(car (internal--listify (car (last bindings))))
+ ,then
+ ,@else))))
+
+ (unless (fboundp 'when-let*)
+ (defmacro when-let* (bindings &rest body)
+ "Process BINDINGS and if all values are non-nil eval BODY.
+Argument BINDINGS is a list of tuples whose car is a symbol to be
+bound and (optionally) used in BODY, and its cadr is a sexp to be
+evalled to set symbol's value."
+ (declare (indent 1) (debug if-let*))
+ `(if-let* ,bindings ,(macroexp-progn body)))))
+
+(provide 'cider-compat)
+;;; cider-compat.el ends here
--- /dev/null
+;;; cider-completion.el --- Smart REPL-powered code completion -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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-eldoc)
+(require 'nrepl-dict)
+
+(defcustom cider-completion-use-context t
+ "When true, uses context at point to improve completion suggestions."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "0.7.0"))
+
+(defcustom cider-annotate-completion-candidates t
+ "When true, annotate completion candidates with some extra information."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "0.8.0"))
+
+(defcustom cider-annotate-completion-function
+ #'cider-default-annotate-completion-function
+ "Controls how the annotations for completion candidates are formatted.
+Must be a function that takes two arguments: the abbreviation of the
+candidate type according to `cider-completion-annotations-alist' and the
+candidate's namespace."
+ :type 'function
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-completion-annotations-alist
+ '(("class" "c")
+ ("field" "fi")
+ ("function" "f")
+ ("import" "i")
+ ("keyword" "k")
+ ("local" "l")
+ ("macro" "m")
+ ("method" "me")
+ ("namespace" "n")
+ ("protocol" "p")
+ ("protocol-function" "pf")
+ ("record" "r")
+ ("special-form" "s")
+ ("static-field" "sf")
+ ("static-method" "sm")
+ ("type" "t")
+ ("var" "v"))
+ "Controls the abbreviations used when annotating completion candidates.
+
+Must be a list of elements with the form (TYPE . ABBREVIATION), where TYPE
+is a possible value of the candidate's type returned from the completion
+backend, and ABBREVIATION is a short form of that type."
+ :type '(alist :key-type string :value-type string)
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-completion-annotations-include-ns 'unqualified
+ "Controls passing of namespaces to `cider-annotate-completion-function'.
+
+When set to 'always, the candidate's namespace will always be passed if it
+is available. When set to 'unqualified, the namespace will only be passed
+if the candidate is not namespace-qualified."
+ :type '(choice (const always)
+ (const unqualified)
+ (const :tag "never" nil))
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defvar cider-completion-last-context nil)
+
+(defun cider-completion-symbol-start-pos ()
+ "Find the starting position of the symbol at point, unless inside a string."
+ (let ((sap (symbol-at-point)))
+ (when (and sap (not (nth 3 (syntax-ppss))))
+ (car (bounds-of-thing-at-point 'symbol)))))
+
+(defun cider-completion-get-context-at-point ()
+ "Extract the context at point.
+If point is not inside the list, returns nil; otherwise return \"top-level\"
+form, with symbol at point replaced by __prefix__."
+ (when (save-excursion
+ (condition-case _
+ (progn
+ (up-list)
+ (check-parens)
+ t)
+ (scan-error nil)
+ (user-error nil)))
+ (save-excursion
+ (let* ((pref-end (point))
+ (pref-start (cider-completion-symbol-start-pos))
+ (context (cider-defun-at-point))
+ (_ (beginning-of-defun))
+ (expr-start (point)))
+ (concat (when pref-start (substring context 0 (- pref-start expr-start)))
+ "__prefix__"
+ (substring context (- pref-end expr-start)))))))
+
+(defun cider-completion-get-context ()
+ "Extract context depending on `cider-completion-use-context' and major mode."
+ (let ((context (if (and cider-completion-use-context
+ ;; Important because `beginning-of-defun' and
+ ;; `ending-of-defun' work incorrectly in the REPL
+ ;; buffer, so context extraction fails there.
+ (derived-mode-p 'clojure-mode))
+ (or (cider-completion-get-context-at-point)
+ "nil")
+ "nil")))
+ (if (string= cider-completion-last-context context)
+ ":same"
+ (setq cider-completion-last-context context)
+ context)))
+
+(defun cider-completion--parse-candidate-map (candidate-map)
+ "Get \"candidate\" from CANDIDATE-MAP.
+Put type and ns properties on the candidate"
+ (let ((candidate (nrepl-dict-get candidate-map "candidate"))
+ (type (nrepl-dict-get candidate-map "type"))
+ (ns (nrepl-dict-get candidate-map "ns")))
+ (put-text-property 0 1 'type type candidate)
+ (put-text-property 0 1 'ns ns candidate)
+ candidate))
+
+(defun cider-complete (str)
+ "Complete STR with context at point."
+ (let* ((context (cider-completion-get-context))
+ (candidates (cider-sync-request:complete str context)))
+ (mapcar #'cider-completion--parse-candidate-map candidates)))
+
+(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-annotate-symbol (symbol)
+ "Return a string suitable for annotating SYMBOL.
+If SYMBOL has a text property `type` whose value is recognised, its
+abbreviation according to `cider-completion-annotations-alist' will be
+used. If `type` is present but not recognised, its value will be used
+unaltered. If SYMBOL has a text property `ns`, then its value will be used
+according to `cider-completion-annotations-include-ns'. The formatting is
+performed by `cider-annotate-completion-function'."
+ (when cider-annotate-completion-candidates
+ (let* ((type (cider-completion--get-candidate-type symbol))
+ (ns (cider-completion--get-candidate-ns symbol)))
+ (funcall cider-annotate-completion-function type ns))))
+
+(defun cider-complete-at-point ()
+ "Complete the symbol at point."
+ (when-let* ((bounds (bounds-of-thing-at-point 'symbol)))
+ (when (and (cider-connected-p)
+ (not (or (cider-in-string-p) (cider-in-comment-p))))
+ (list (car bounds) (cdr bounds)
+ (completion-table-dynamic #'cider-complete)
+ :annotation-function #'cider-annotate-symbol
+ :company-doc-buffer #'cider-create-doc-buffer
+ :company-location #'cider-company-location
+ :company-docsig #'cider-company-docsig))))
+
+(defun cider-completion-flush-caches ()
+ "Force Compliment to refill its caches.
+This command should be used if Compliment fails to pick up new classnames
+and methods from dependencies that were loaded dynamically after the REPL
+has started."
+ (interactive)
+ (cider-sync-request:complete-flush-caches))
+
+(defun cider-company-location (var)
+ "Open VAR's definition in a buffer.
+Returns the cons of the buffer itself and the location of VAR's definition
+in the buffer."
+ (when-let* ((info (cider-var-info var))
+ (file (nrepl-dict-get info "file"))
+ (line (nrepl-dict-get info "line"))
+ (buffer (cider-find-file file)))
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (cons buffer (point))))))
+
+(defun cider-company-docsig (thing)
+ "Return signature for THING."
+ (let* ((eldoc-info (cider-eldoc-info thing))
+ (ns (lax-plist-get eldoc-info "ns"))
+ (symbol (lax-plist-get eldoc-info "symbol"))
+ (arglists (lax-plist-get eldoc-info "arglists")))
+ (when eldoc-info
+ (format "%s: %s"
+ (cider-eldoc-format-thing ns symbol thing
+ (cider-eldoc-thing-type eldoc-info))
+ (cider-eldoc-format-arglist arglists 0)))))
+
+;; Fuzzy completion for company-mode
+
+(defun cider-company-unfiltered-candidates (string &rest _)
+ "Return CIDER completion candidates for STRING as is, unfiltered."
+ (cider-complete string))
+
+(add-to-list 'completion-styles-alist
+ '(cider
+ cider-company-unfiltered-candidates
+ cider-company-unfiltered-candidates
+ "CIDER backend-driven completion style."))
+
+(defun cider-company-enable-fuzzy-completion ()
+ "Enable backend-driven fuzzy completion in the current buffer."
+ (setq-local completion-styles '(cider)))
+
+(provide 'cider-completion)
+;;; cider-completion.el ends here
--- /dev/null
+;;; cider-connection.el --- Connection and session life-cycle management for CIDER -*- lexical-binding: t -*-
+;;
+;; Copyright © 2018 Artur Malabarba, Bozhidar Batsov, Vitalie Spinu and CIDER contributors
+;;
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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)
+
+(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-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"))
+
+(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 cider mode for all Clojure buffers."
+ :type 'boolean
+ :group 'cider
+ :safe #'booleanp
+ :package-version '(cider . "0.9.0"))
+
+(defconst cider-required-nrepl-version "0.2.12"
+ "The minimum nREPL version that's known to work properly with CIDER.")
+
+\f
+;;; 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)))))
+
+(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)
+ (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 "\n "
+ (cider--manual-button "More information" section-id)
+ "."))))
+
+(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/#warning-saying-you-have-to-use-nrepl-0212"
+ "CIDER requires nREPL %s (or newer) to work properly"
+ cider-required-nrepl-version))
+ (cider-emit-manual-warning "troubleshooting/#warning-saying-you-have-to-use-nrepl-0212"
+ "Can't determine nREPL's version.\nPlease, update nREPL to %s."
+ 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)))
+ (when (version< clojure-version cider-minimum-clojure-version)
+ (cider-emit-manual-warning "installation/#prerequisites"
+ "Clojure version (%s) is not supported (minimum %s). CIDER will not work."
+ clojure-version cider-minimum-clojure-version))
+ (cider-emit-manual-warning "installation/#prerequisites"
+ "Can't determine Clojure's version. CIDER requires Clojure %s (or newer)."
+ cider-minimum-clojure-version)))
+
+(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/#cider-complains-of-the-cider-nrepl-version"
+ "CIDER requires cider-nrepl to be fully functional. Many things will not work without it!"))
+ ((version< middleware-version cider-required-middleware-version)
+ (cider-emit-manual-warning "troubleshooting/#cider-complains-of-the-cider-nrepl-version"
+ "CIDER %s requires cider-nrepl %s+, but you're currently using cider-nrepl %s. Things will break!"
+ cider-version cider-required-middleware-version middleware-version)))))
+
+(declare-function cider-interactive-eval-handler "cider-eval")
+;; 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))))
+
+(declare-function cider-mode "cider-mode")
+(defun cider-enable-on-existing-clojure-buffers ()
+ "Enable CIDER's minor mode on existing Clojure buffers.
+See command `cider-mode'."
+ (interactive)
+ (add-hook 'clojure-mode-hook #'cider-mode)
+ (dolist (buffer (cider-util--clojure-buffers))
+ (with-current-buffer buffer
+ (cider-mode +1))))
+
+(defun cider-disable-on-existing-clojure-buffers ()
+ "Disable command `cider-mode' on existing Clojure buffers."
+ (interactive)
+ (dolist (buffer (cider-util--clojure-buffers))
+ (with-current-buffer buffer
+ (cider-mode -1))))
+
+(defun cider-possibly-disable-on-existing-clojure-buffers ()
+ "If not connected, disable command `cider-mode' on existing Clojure buffers."
+ (unless (cider-connected-p)
+ (cider-disable-on-existing-clojure-buffers)))
+
+(declare-function cider--debug-init-connection "cider-debug")
+(declare-function cider-repl-init "cider-repl")
+(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))
+ (cider--check-required-nrepl-version)
+ (cider--check-clojure-version-supported)
+ (cider--check-middleware-compatibility)
+ (when cider-redirect-server-output-to-repl
+ (cider--subscribe-repl-to-server-out))
+ (when cider-auto-mode
+ (cider-enable-on-existing-clojure-buffers))
+ ;; 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)
+ (when cider-repl-init-function
+ (funcall cider-repl-init-function))
+ (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
+ (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--connection-info (connection-buffer &optional genericp)
+ "Return info about CONNECTION-BUFFER.
+Info contains project name, current REPL namespace, host:port endpoint and
+Clojure version. When GENERICP is non-nil, don't provide specific info
+about this buffer (like variable `cider-repl-type')."
+ (with-current-buffer connection-buffer
+ (format "%s%s@%s:%s (Java %s, Clojure %s, nREPL %s)"
+ (if genericp "" (upcase (concat 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))))
+
+\f
+;;; Cider's Connection Management UI
+
+(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 connections we can kill all ancillary buffers
+ (unless (cider-connected-p)
+ (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))))
+(define-obsolete-function-alias 'cider-display-connection-info 'cider-describe-connection "0.18.0")
+
+(defconst cider-nrepl-session-buffer "*cider-nrepl-session*")
+
+(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))))
+
+\f
+;;; Sesman's Session-Wise Management UI
+
+(cl-defmethod sesman-project ((_system (eql CIDER)))
+ (clojure-project-dir (cider-current-dir)))
+
+(cl-defmethod sesman-more-relevant-p ((_system (eql CIDER)) session1 session2)
+ (sesman-more-recent-p (cdr session1) (cdr session2)))
+
+(cl-defmethod sesman-friendly-session-p ((_system (eql CIDER)) session)
+ (setcdr session (seq-filter #'buffer-live-p (cdr session)))
+ (when-let* ((repl (cadr session))
+ (proc (get-buffer-process repl))
+ (file (file-truename (or (buffer-file-name) default-directory))))
+ ;; With avfs paths look like /path/to/.avfs/path/to/some.jar#uzip/path/to/file.clj
+ (when (string-match-p "#uzip" file)
+ (let ((avfs-path (directory-file-name (expand-file-name (or (getenv "AVFSBASE") "~/.avfs/")))))
+ (setq file (replace-regexp-in-string avfs-path "" file t t))))
+ (when (process-live-p proc)
+ (let* ((classpath (or (process-get proc :cached-classpath)
+ (let ((cp (with-current-buffer repl
+ (cider-sync-request:classpath))))
+ (process-put proc :cached-classpath cp)
+ cp)))
+ (classpath-roots (or (process-get proc :cached-classpath-roots)
+ (let ((cp (thread-last classpath
+ (seq-filter (lambda (path) (not (string-match-p "\\.jar$" path))))
+ (mapcar #'file-name-directory))))
+ (process-put proc :cached-classpath-roots cp)
+ cp))))
+ (or (seq-find (lambda (path) (string-prefix-p path file))
+ classpath)
+ (seq-find (lambda (path) (string-prefix-p path file))
+ classpath-roots))))))
+
+(defvar cider-sesman-browser-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "j q") #'cider-quit)
+ (define-key map (kbd "j k") #'cider-quit)
+ (define-key map (kbd "j r") #'cider-restart)
+ (define-key map (kbd "j d") #'cider-describe-connection)
+ (define-key map (kbd "j i") #'cider-describe-connection)
+ (define-key map (kbd "C-c C-q") #'cider-quit)
+ (define-key map (kbd "C-c C-q") #'cider-quit)
+ (define-key map (kbd "C-c C-r") #'cider-restart)
+ (define-key map (kbd "C-c M-r") #'cider-restart)
+ (define-key map (kbd "C-c C-d") #'cider-describe-connection)
+ (define-key map (kbd "C-c M-d") #'cider-describe-connection)
+ (define-key map (kbd "C-c C-i") #'cider-describe-connection)
+ map)
+ "Map active on REPL objects in sesman browser.")
+
+(cl-defmethod sesman-session-info ((_system (eql CIDER)) session)
+ (interactive "P")
+ (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)
+ (mapc #'cider--close-connection (cdr session))
+ ;; if there are no more connections we can kill all ancillary buffers
+ (unless (cider-connected-p)
+ (cider-close-ancillary-buffers)))
+
+(cl-defmethod sesman-restart-session ((_system (eql CIDER)) session)
+ (let* ((ses-name (car session))
+ (repls (cdr session))
+ (srv-buf (cider--session-server session)))
+ (if srv-buf
+ ;; session with a server
+ (let ((s-params (cider--gather-connect-params nil srv-buf)))
+ ;; 1) kill all connections, but keep the buffers
+ (mapc (lambda (conn)
+ (cider--close-connection conn 'no-kill))
+ repls)
+ ;; 2) kill the server
+ (nrepl-kill-server-buffer srv-buf)
+ ;; 3) start server
+ (nrepl-start-server-process
+ (plist-get s-params :project-dir)
+ (plist-get s-params :server-command)
+ (lambda (server-buf)
+ ;; 4) restart the repls reusing the buffer
+ (dolist (r repls)
+ (cider-nrepl-connect
+ (thread-first ()
+ (cider--gather-connect-params r)
+ ;; server params (:port, :project-dir etc) have precedence
+ (cider--gather-connect-params server-buf)
+ (plist-put :session-name ses-name)
+ (plist-put :repl-buffer r))))
+ (sesman-browser-revert-all 'CIDER)
+ (message "Restarted CIDER %s session" ses-name))))
+ ;; server-less session
+ (dolist (r repls)
+ (cider--close-connection r 'no-kill)
+ (cider-nrepl-connect
+ (thread-first ()
+ (cider--gather-connect-params r)
+ (plist-put :session-name ses-name)
+ (plist-put :repl-buffer r)))))))
+
+(defun cider-format-connection-params (template params)
+ "Format PARAMS with TEMPLATE string.
+The following formats can be used in TEMPLATE string:
+
+ %h - host
+ %H - remote host, empty for local hosts
+ %p - port
+ %j - short project name, or directory name if no project
+ %J - long project name including parent dir name
+ %r - REPL type (clj or cljs)
+ %S - type of the ClojureScript runtime (Nashorn, 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 (equal repl-type "cljs")
+ (plist-get params :cljs-repl-type))
+ ""))
+ (specs `((?h . ,host)
+ (?H . ,remote-host)
+ (?p . ,port)
+ (?j . ,short-proj)
+ (?J . ,long-proj)
+ (?r . ,repl-type)
+ (?S . ,cljs-repl-type)))
+ (ses-name (or (plist-get params :session-name)
+ (format-spec cider-session-name-template specs)))
+ (specs (append `((?s . ,ses-name)) specs)))
+ (thread-last (format-spec template specs)
+ ;; remove extraneous separators
+ (replace-regexp-in-string "\\([:-]\\)[:-]+" "\\1")
+ (replace-regexp-in-string "\\(^[:-]\\)\\|\\([:-]$\\)" "")
+ (replace-regexp-in-string "[:-]\\([])*]\\)" "\\1"))))
+
+(defun cider-make-session-name (params)
+ "Create new session name given plist of connection PARAMS.
+Session name can be customized with `cider-session-name-template'."
+ (let* ((root-name (cider-format-connection-params cider-session-name-template params))
+ (other-names (mapcar #'car (sesman-sessions 'CIDER)))
+ (name root-name)
+ (i 2))
+ (while (member name other-names)
+ (setq name (concat root-name "#" (number-to-string i))
+ i (+ i 1)))
+ name))
+
+\f
+;;; REPL Buffer Init
+
+(defvar-local cider-cljs-repl-type nil
+ "The type of the ClojureScript runtime (Nashorn, Node etc.)")
+
+(defvar-local cider-repl-type nil
+ "The type of this REPL buffer, usually either \"clj\" or \"cljs\".")
+
+(defun cider-repl-type (repl-buffer)
+ "Get REPL-BUFFER's type."
+ (buffer-local-value 'cider-repl-type repl-buffer))
+
+(defun cider-repl-type-for-buffer (&optional buffer)
+ "Return the matching connection type (clj or cljs) for BUFFER.
+BUFFER defaults to the `current-buffer'. In cljc buffers return
+\"multi\". This function infers connection type based on the major mode.
+For the REPL type use the function `cider-repl-type'."
+ (with-current-buffer (or buffer (current-buffer))
+ (cond
+ ((derived-mode-p 'clojurescript-mode) "cljs")
+ ((derived-mode-p 'clojurec-mode) "multi")
+ ((derived-mode-p 'clojure-mode) "clj")
+ (cider-repl-type))))
+
+(defun cider-set-repl-type (&optional type)
+ "Set REPL TYPE to \"clj\" or \"cljs\".
+Assume that the current buffer is a REPL."
+ (interactive)
+ (let ((type (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))
+ (cljsp (string-match-p "cljs" (plist-get params :repl-type)))
+ (scored-repls
+ (delq nil
+ (mapcar (lambda (b)
+ (let ((bparams (cider--gather-connect-params nil b)))
+ (when (eq cljsp (string-match-p "cljs" (plist-get bparams :repl-type)))
+ (cons (buffer-name 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))))
+ (when scored-repls
+ (if (> (length scored-repls) 1)
+ (when (y-or-n-p "Dead REPLs exist. Reuse? ")
+ (let ((sorted-repls (seq-sort (lambda (a b) (> (cdr a) (cdr b))) scored-repls)))
+ (get-buffer (completing-read "REPL to reuse: "
+ (mapcar #'car sorted-repls) nil t nil nil (caar sorted-repls)))))
+ (when (y-or-n-p (format "A dead REPL %s exists. Reuse? " (caar scored-repls)))
+ (get-buffer (caar scored-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)
+(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)
+ (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)
+ ;; REPLs start with clj and then "upgrade" to a different type
+ cider-repl-type (plist-get params :repl-type)
+ ;; ran at the end of cider--connected-handler
+ cider-repl-init-function (plist-get params :repl-init-function))
+ (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
+ ((equal type "multi")
+ "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. \"multi\" or \"any\"
+are synonyms. 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."
+ (if (and (derived-mode-p 'cider-repl-mode)
+ (or (null type)
+ (string= cider-repl-type type)))
+ ;; shortcut when in REPL buffer
+ (current-buffer)
+ (let* ((type (if (equal type "any") "multi" type))
+ (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) (equal type "multi")) t)
+ ((listp type) (member buffer-repl-type type))
+ (t (string= type buffer-repl-type)))))
+
+(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 ((repls (cdr (if ensure
+ (sesman-ensure-session 'CIDER)
+ (sesman-current-session 'CIDER)))))
+ (or (seq-filter (lambda (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 (equal cur-type "cljs")
+ (user-error "Clojure-only operation requested in a ClojureScript buffer")))
+ (:cljs-strict (when (equal 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 (equal cur-type "multi")
+ '("clj" "cljs")
+ cur-type))))
+ (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)
+
+\f
+;; Deprecation after #2324
+
+(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 'cider-display-connection-info 'cider-describe-connection "0.18")
+(define-obsolete-function-alias 'nrepl-connection-buffer-name 'nrepl-repl-buffer-name "0.18")
+(define-obsolete-function-alias 'cider-repl-set-type 'cider-set-repl-type "0.18")
+
+(make-obsolete 'cider-assoc-buffer-with-connection 'sesman-link-with-buffer "0.18")
+(make-obsolete 'cider-assoc-project-with-connection 'sesman-link-with-project "0.18")
+(make-obsolete 'cider-change-buffers-designation nil "0.18")
+(make-obsolete 'cider-clear-buffer-local-connection nil "0.18")
+(make-obsolete 'cider-close-nrepl-session 'cider-quit "0.18")
+(make-obsolete 'cider-create-sibling-cljs-repl 'cider-connect-sibling-cljs "0.18")
+(make-obsolete 'cider-current-messages-buffer nil "0.18")
+(make-obsolete 'cider-default-connection "see sesman." "0.18")
+(make-obsolete 'cider-extract-designation-from-current-repl-buffer nil "0.18")
+(make-obsolete 'cider-find-connection-buffer-for-project-directory 'sesman-current-sessions "0.18")
+(make-obsolete 'cider-find-reusable-repl-buffer nil "0.18")
+(make-obsolete 'cider-make-connection-default "see sesman." "0.18")
+(make-obsolete 'cider-other-connection nil "0.18")
+(make-obsolete 'cider-project-connections 'sesman-current-sessions "0.18")
+(make-obsolete 'cider-project-connections-types nil "0.18")
+(make-obsolete 'cider-prompt-for-project-on-connect nil "0.18")
+(make-obsolete 'cider-read-connection `sesman-ask-for-session "0.18")
+(make-obsolete 'cider-replicate-connection nil "0.18")
+(make-obsolete 'cider-request-dispatch "see sesman." "0.18")
+(make-obsolete 'cider-rotate-default-connection "see sesman." "0.18")
+(make-obsolete 'cider-toggle-buffer-connection nil "0.18")
+(make-obsolete 'cider-toggle-request-dispatch nil "0.18")
+(make-obsolete 'nrepl-connection-buffer-name-template 'nrepl-repl-buffer-name-template "0.18")
+(make-obsolete 'nrepl-create-client-buffer-function nil "0.18")
+(make-obsolete 'nrepl-post-client-callback nil "0.18")
+(make-obsolete 'nrepl-prompt-to-kill-server-buffer-on-quit nil "0.18")
+(make-obsolete 'nrepl-use-this-as-repl-buffer nil "0.18")
+
+;; connection manager
+(make-obsolete 'cider-client-name-repl-type "see sesman." "0.18")
+(make-obsolete 'cider-connection-browser "see sesman." "0.18")
+(make-obsolete 'cider-connections-buffer-mode "see sesman." "0.18")
+(make-obsolete 'cider-connections-buffer-mode-map "see sesman." "0.18")
+(make-obsolete 'cider-connections-close-connection "see sesman." "0.18")
+(make-obsolete 'cider-connections-goto-connection "see sesman." "0.18")
+(make-obsolete 'cider-connections-make-default "see sesman." "0.18")
+(make-obsolete 'cider-display-connected-message "see sesman." "0.18")
+(make-obsolete 'cider-project-name "see sesman." "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-2018 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 'nrepl-dict)
+(require 'nrepl-client) ; `nrepl--mark-id-completed'
+(require 'cider-eval)
+(require 'cider-client)
+(require 'cider-util)
+(require 'cider-inspector)
+(require 'cider-browse-ns)
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'seq)
+(require 'spinner)
+
+\f
+;;; Customization
+(defgroup cider-debug nil
+ "Presentation and behaviour 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."
+ :group 'cider-debug
+ :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."
+ :group 'cider-debug
+ :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."
+ :group 'cider-debug
+ :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)."
+ :group 'cider-debug
+ :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))
+ :group 'cider-debug
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-debug-use-overlays t
+ "Whether to higlight 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))
+ :group 'cider-debug
+ :package-version '(cider . "0.9.1"))
+
+(defcustom cider-debug-print-level 10
+ "The print level for values displayed by the debugger.
+This variable must be set before starting the repl connection."
+ :type '(choice (const :tag "No limit" nil)
+ (integer :tag "Max depth" 10))
+ :group 'cider-debug
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-debug-print-length 10
+ "The print length for values displayed by the debugger.
+This variable must be set before starting the repl connection."
+ :type '(choice (const :tag "No limit" nil)
+ (integer :tag "Max depth" 10))
+ :group 'cider-debug
+ :package-version '(cider . "0.10.0"))
+
+\f
+;;; Implementation
+(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))
+ (erase-buffer)
+ (dolist (list all)
+ (let* ((ns (car list))
+ (ns-vars-with-meta (cider-sync-request:ns-vars-with-meta ns))
+ ;; seq of metadata maps of the instrumented vars
+ (instrumented-meta (mapcar (apply-partially #'nrepl-dict-get ns-vars-with-meta)
+ (cdr list))))
+ (cider-browse-ns--list (current-buffer) ns
+ (seq-mapn #'cider-browse-ns--properties
+ (cdr list)
+ instrumented-meta)
+
+ ns 'noerase)
+ (goto-char (point-max))
+ (insert "\n"))))
+ (goto-char (point-min)))
+ (message "No currently instrumented definitions")))
+
+(defun cider--debug-response-handler (response)
+ "Handles RESPONSE from the cider.debug middleware."
+ (nrepl-dbind-response response (status id causes)
+ (when (member "enlighten" status)
+ (cider--handle-enlighten response))
+ (when (or (member "eval-error" status)
+ (member "stack" status))
+ ;; TODO: Make the error buffer a bit friendlier when we're just printing
+ ;; the stack.
+ (cider--render-stacktrace-causes causes))
+ (when (member "need-debug-input" status)
+ (cider--handle-debug response))
+ (when (member "done" status)
+ (nrepl--mark-id-completed id))))
+
+(defun cider--debug-init-connection ()
+ "Initialize a connection with the cider.debug middleware."
+ (cider-nrepl-send-request
+ (nconc '("op" "init-debugger")
+ (when cider-debug-print-level
+ `("print-level" ,cider-debug-print-level))
+ (when cider-debug-print-length
+ `("print-length" ,cider-debug-print-length)))
+ #'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)
+ "Place an overlay at point displaying VALUE."
+ (when cider-debug-use-overlays
+ ;; This is cosmetic, let's ensure it doesn't break the session no matter what.
+ (ignore-errors
+ ;; Result
+ (cider--make-result-overlay (cider-font-lock-as-clojure value)
+ :where (point-marker)
+ :type 'debug-result
+ 'before-string cider--fringe-arrow-string)
+ ;; Code
+ (cider--make-overlay (save-excursion (clojure-backward-logical-sexp 1) (point))
+ (point) 'debug-code
+ 'face 'cider-debug-code-overlay-face
+ ;; Higher priority than `show-paren'.
+ 'priority 2000))))
+
+\f
+;;; Minor mode
+(defvar-local cider--debug-mode-commands-dict nil
+ "An nrepl-dict from keys to debug commands.
+Autogenerated by `cider--turn-on-debug-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
+ :group 'cider-debug
+ :package-version '(cider . "0.10.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-prompt (command-dict)
+ "Return prompt to display for COMMAND-DICT."
+ ;; Force `default' face, otherwise the overlay "inherits" the face of the text
+ ;; after it.
+ (format (propertize "%s\n" 'face 'default)
+ (string-join
+ (nrepl-dict-map (lambda (char cmd)
+ (when-let* ((pos (cl-search char cmd)))
+ (put-text-property pos (1+ pos) 'face 'cider-debug-prompt-face cmd))
+ cmd)
+ command-dict)
+ " ")))
+
+(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)
+ (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)
+
+(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'."
+ nil " DEBUG" '()
+ (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")))
+ ;; Set the keymap.
+ (nrepl-dict-map (lambda (char _cmd)
+ (unless (string= char "h") ; `here' needs a special command.
+ (define-key cider--debug-mode-map char #'cider-debug-mode-send-reply))
+ (when (string= char "o")
+ (define-key cider--debug-mode-map (upcase char) #'cider-debug-mode-send-reply)))
+ input-type)
+ (setq cider--debug-mode-commands-dict input-type)
+ ;; 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-commands-dict 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)))))
+
+;;; Bind the `:here` command to both h and H, because it behaves differently if
+;;; invoked with an uppercase letter.
+(define-key cider--debug-mode-map "h" #'cider-debug-move-here)
+(define-key cider--debug-mode-map "H" #'cider-debug-move-here)
+
+(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") :keys "C"]
+ ["Move out of sexp" (cider-debug-mode-send-reply ":out") :keys "o"]
+ ["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 value" (cider-debug-mode-send-reply ":inspect")]
+ ["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 ":" (nrepl-dict-get cider--debug-mode-commands-dict
+ (string last-command-event)))))
+ 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))
+ (cider--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-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))))
+ ;; 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)))
+ (move-to-column column)
+ ;; Check if it worked
+ (when (cider--debug-position-for-code code)
+ ;; Find the desired sexp.
+ (cider--debug-move-point coor)
+ (setq out (point-marker))))))
+ ;; But we can create a temp buffer if that fails.
+ (or out
+ (when create-if-needed
+ (cider--initialize-debug-buffer
+ code ns original-id
+ (if (and line column)
+ "you edited the code"
+ "your nREPL version is older than 0.2.11"))
+ (save-excursion
+ (cider--debug-move-point coor)
+ (point-marker)))))))))
+
+(defun cider--handle-debug (response)
+ "Handle debugging notification.
+RESPONSE is a message received from the nrepl describing the input
+needed. It is expected to contain at least \"key\", \"input-type\", and
+\"prompt\", and possibly other entries depending on the input-type."
+ (nrepl-dbind-response response (debug-value key input-type prompt inspect)
+ (condition-case-unless-debug e
+ (progn
+ (pcase input-type
+ ("expression" (cider-debug-mode-send-reply
+ (condition-case nil
+ (cider-read-from-minibuffer
+ (or prompt "Expression: "))
+ (quit "nil"))
+ key))
+ ((pred sequencep)
+ (let* ((marker (cider--debug-find-source-position response 'create-if-needed)))
+ (pop-to-buffer (marker-buffer marker))
+ (goto-char marker))
+ ;; The overlay code relies on window boundaries, but point could have been
+ ;; moved outside the window by some other code. Redisplay here to ensure the
+ ;; visible window includes point.
+ (redisplay)
+ ;; Remove overlays AFTER redisplaying! Otherwise there's a visible
+ ;; flicker even if we immediately recreate the overlays.
+ (cider--debug-remove-overlays)
+ (when cider-debug-use-overlays
+ (cider--debug-display-result-overlay debug-value))
+ (setq cider--debug-mode-response response)
+ (cider--debug-mode 1)))
+ (when inspect
+ (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))
+ ;; Is HERE inside the sexp being debugged?
+ (when (or (< here (point))
+ (save-excursion
+ (forward-sexp 1)
+ (> here (point))))
+ (user-error "Point is outside the sexp being debugged"))
+ ;; Move forward untill start of sexp.
+ (comment-normalize-vars)
+ (comment-forward (point-max))
+ ;; Find the coordinate and send it.
+ (cider-debug-mode-send-reply
+ (format "{:response :here, :coord %s :force? %s}"
+ (cider--debug-find-coordinates-for-point here)
+ (if force "true" "false"))))))
+
+\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-2018 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 'subr-x)
+(require 'cider-compat)
+(require 'cider-util)
+(require 'cider-popup)
+(require 'cider-client)
+(require 'cider-grimoire)
+(require 'nrepl-dict)
+(require 'org-table)
+(require 'button)
+(require 'easymenu)
+(require 'cider-browse-spec)
+
+\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 "r") #'cider-grimoire)
+ (define-key cider-doc-map (kbd "C-r") #'cider-grimoire)
+ (define-key cider-doc-map (kbd "w") #'cider-grimoire-web)
+ (define-key cider-doc-map (kbd "C-w") #'cider-grimoire-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]
+ ["Grimoire" cider-grimoire]
+ ["Grimoire in browser" cider-grimoire-web]
+ ["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.")
+
+(defadvice enable-theme (after cider-docview-adapt-to-theme activate)
+ "When theme is changed, update `cider-docview-code-background-color'."
+ (setq cider-docview-code-background-color (cider-scale-background-color)))
+
+
+(defadvice disable-theme (after cider-docview-adapt-to-theme activate)
+ "When theme is disabled, 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-grimoire)
+ (define-key map "G" #'cider-docview-grimoire-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 Grimoire" cider-docview-grimoire]
+ ["Look up in Grimoire (browser)" cider-docview-grimoire-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-grimoire-lookup "cider-grimoire")
+
+(defun cider-docview-grimoire ()
+ "Return the grimoire documentation for `cider-docview-symbol'."
+ (interactive)
+ (if cider-buffer-ns
+ (cider-grimoire-lookup cider-docview-symbol)
+ (error "%s cannot be looked up on Grimoire" cider-docview-symbol)))
+
+(declare-function cider-grimoire-web-lookup "cider-grimoire")
+
+(defun cider-docview-grimoire-web ()
+ "Open the grimoire documentation for `cider-docview-symbol' in a web browser."
+ (interactive)
+ (if cider-buffer-ns
+ (cider-grimoire-web-lookup cider-docview-symbol)
+ (error "%s cannot be looked up on Grimoire" cider-docview-symbol)))
+
+(defconst cider-doc-buffer "*cider-doc*")
+
+(defun cider-create-doc-buffer (symbol)
+ "Populates *cider-doc* with the documentation for SYMBOL."
+ (when-let* ((info (cider-var-info symbol)))
+ (cider-docview-render (cider-make-popup-buffer cider-doc-buffer nil 'ancillary) symbol info)))
+
+(defun cider-doc-lookup (symbol)
+ "Look up documentation for SYMBOL."
+ (if-let* ((buffer (cider-create-doc-buffer symbol)))
+ (cider-popup-buffer-display buffer cider-doc-auto-select-buffer)
+ (user-error "Symbol %s not resolved" symbol)))
+
+(defun cider-doc (&optional arg)
+ "Open Clojure documentation in a popup buffer.
+
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates."
+ (interactive "P")
+ (cider-ensure-connected)
+ (funcall (cider-prompt-for-symbol-function arg)
+ "Doc for"
+ #'cider-doc-lookup))
+
+\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."
+ (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."
+ (if (string-match "\\`file:\\(.*\\)" file-with-protocol)
+ (let ((file (match-string 1 file-with-protocol))
+ (proj-dir (clojure-project-dir)))
+ (if (and proj-dir
+ (file-in-directory-p file proj-dir))
+ (file-relative-name file proj-dir)
+ file))
+ file-with-protocol))
+
+(defun cider-docview-render-info (buffer info)
+ "Emit into BUFFER formatted INFO for the Clojure or Java symbol."
+ (let* ((ns (nrepl-dict-get info "ns"))
+ (name (nrepl-dict-get info "name"))
+ (added (nrepl-dict-get info "added"))
+ (depr (nrepl-dict-get info "deprecated"))
+ (macro (nrepl-dict-get info "macro"))
+ (special (nrepl-dict-get info "special-form"))
+ (forms (when-let* ((str (nrepl-dict-get info "forms-str")))
+ (split-string str "\n")))
+ (args (when-let* ((str (nrepl-dict-get info "arglists-str")))
+ (split-string str "\n")))
+ (doc (or (nrepl-dict-get info "doc")
+ "Not documented."))
+ (url (nrepl-dict-get info "url"))
+ (class (nrepl-dict-get info "class"))
+ (member (nrepl-dict-get info "member"))
+ (javadoc (nrepl-dict-get info "javadoc"))
+ (super (nrepl-dict-get info "super"))
+ (ifaces (nrepl-dict-get info "interfaces"))
+ (spec (nrepl-dict-get info "spec"))
+ (clj-name (if ns (concat ns "/" name) name))
+ (java-name (if member (concat class "/" member) class))
+ (see-also (nrepl-dict-get info "see-also")))
+ (cider--help-setup-xref (list #'cider-doc-lookup (format "%s/%s" ns name)) nil buffer)
+ (with-current-buffer buffer
+ (cl-flet ((emit (text &optional face)
+ (insert (if face
+ (propertize text 'font-lock-face face)
+ text)
+ "\n")))
+ (emit (if class java-name clj-name) 'font-lock-function-name-face)
+ (when super
+ (emit (concat " Extends: " (cider-font-lock-as 'java-mode super))))
+ (when ifaces
+ (emit (concat "Implements: " (cider-font-lock-as 'java-mode (car ifaces))))
+ (dolist (iface (cdr ifaces))
+ (emit (concat " "(cider-font-lock-as 'java-mode iface)))))
+ (when (or super ifaces)
+ (insert "\n"))
+ (when-let* ((forms (or forms args)))
+ (dolist (form forms)
+ (insert " ")
+ (emit (cider-font-lock-as-clojure form))))
+ (when special
+ (emit "Special Form" 'font-lock-keyword-face))
+ (when macro
+ (emit "Macro" 'font-lock-variable-name-face))
+ (when added
+ (emit (concat "Added in " added) 'font-lock-comment-face))
+ (when depr
+ (emit (concat "Deprecated in " depr) 'font-lock-keyword-face))
+ (if class
+ (cider-docview-render-java-doc (current-buffer) doc)
+ (emit (concat " " doc)))
+ (when url
+ (insert "\n Please see ")
+ (insert-text-button url
+ 'url url
+ 'follow-link t
+ 'action (lambda (x)
+ (browse-url (button-get x 'url))))
+ (insert "\n"))
+ (when javadoc
+ (insert "\n\nFor additional documentation, see the ")
+ (insert-text-button "Javadoc"
+ 'url javadoc
+ 'follow-link t
+ 'action (lambda (x)
+ (browse-url (button-get x 'url))))
+ (insert ".\n"))
+ (insert "\n")
+ (when spec
+ (emit "Spec:" 'font-lock-function-name-face)
+ (insert (cider-browse-spec--pprint-indented spec))
+ (insert "\n\n")
+ (insert-text-button "Browse spec"
+ 'follow-link t
+ 'action (lambda (_)
+ (cider-browse-spec (format "%s/%s" ns name))))
+ (insert "\n\n"))
+ (if cider-docview-file
+ (progn
+ (insert (propertize (if class java-name clj-name)
+ 'font-lock-face 'font-lock-function-name-face)
+ " is defined in ")
+ (insert-text-button (cider--abbreviate-file-protocol cider-docview-file)
+ 'follow-link t
+ 'action (lambda (_x)
+ (cider-docview-source)))
+ (insert "."))
+ (insert "Definition location unavailable."))
+ (when see-also
+ (insert "\n\n Also see: ")
+ (mapc (lambda (ns-sym)
+ (let* ((ns-sym-split (split-string ns-sym "/"))
+ (see-also-ns (car ns-sym-split))
+ (see-also-sym (cadr ns-sym-split))
+ ;; if the var belongs to the same namespace,
+ ;; we omit the namespace to save some screen space
+ (symbol (if (equal ns see-also-ns) see-also-sym ns-sym)))
+ (insert-text-button symbol
+ 'type 'help-xref
+ 'help-function (apply-partially #'cider-doc-lookup symbol)))
+ (insert " "))
+ see-also))
+ (cider--doc-make-xrefs)
+ (let ((beg (point-min))
+ (end (point-max)))
+ (nrepl-dict-map (lambda (k v)
+ (put-text-property beg end k v))
+ info)))
+ (current-buffer))))
+
+(declare-function cider-set-buffer-ns "cider-mode")
+(defun cider-docview-render (buffer symbol info)
+ "Emit into BUFFER formatted documentation for SYMBOL's INFO."
+ (with-current-buffer buffer
+ (let ((javadoc (nrepl-dict-get info "javadoc"))
+ (file (nrepl-dict-get info "file"))
+ (line (nrepl-dict-get info "line"))
+ (ns (nrepl-dict-get info "ns"))
+ (inhibit-read-only t))
+ (cider-docview-mode)
+
+ (cider-set-buffer-ns ns)
+ (setq-local cider-docview-symbol symbol)
+ (setq-local cider-docview-javadoc-url javadoc)
+ (setq-local cider-docview-file file)
+ (setq-local cider-docview-line line)
+
+ (remove-overlays)
+ (cider-docview-render-info buffer info)
+
+ (goto-char (point-min))
+ (current-buffer))))
+
+
+(provide 'cider-doc)
+
+;;; cider-doc.el ends here
--- /dev/null
+;;; cider-eldoc.el --- eldoc support for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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 'subr-x)
+(require 'cider-compat)
+(require 'cider-util)
+(require 'nrepl-dict)
+
+(require 'seq)
+
+(require 'eldoc)
+
+(defvar cider-extra-eldoc-commands '("yas-expand")
+ "Extra commands to be added to eldoc's safe commands list.")
+
+(defcustom cider-eldoc-max-num-sexps-to-skip 30
+ "The maximum number of sexps to skip while searching the beginning of current sexp."
+ :type 'integer
+ :group 'cider
+ :package-version '(cider . "0.10.1"))
+
+(defvar-local cider-eldoc-last-symbol nil
+ "The eldoc information for the last symbol we checked.")
+
+(defcustom cider-eldoc-ns-function #'identity
+ "A function that returns a ns string to be used by eldoc.
+Takes one argument, a namespace name.
+For convenience, some functions are already provided for this purpose:
+`cider-abbreviate-ns', and `cider-last-ns-segment'."
+ :type '(choice (const :tag "Full namespace" identity)
+ (const :tag "Abbreviated namespace" cider-abbreviate-ns)
+ (const :tag "Last name in namespace" cider-last-ns-segment)
+ (function :tag "Custom function"))
+ :group 'cider
+ :package-version '(cider . "0.13.0"))
+
+(defcustom cider-eldoc-max-class-names-to-display 3
+ "The maximum number of classes to display in an eldoc string.
+An eldoc string for Java interop forms can have a number of classes prefixed to
+it, when the form belongs to more than 1 class. When, not nil we only display
+the names of first `cider-eldoc-max-class-names-to-display' classes and add
+a \"& x more\" suffix. Otherwise, all the classes are displayed."
+ :type 'integer
+ :safe #'integerp
+ :group 'cider
+ :package-version '(cider . "0.13.0"))
+
+(defcustom cider-eldoc-display-for-symbol-at-point t
+ "When non-nil, display eldoc for symbol at point if available.
+So in (map inc ...) when the cursor is over inc its eldoc would be
+displayed. When nil, always display eldoc for first symbol of the sexp."
+ :type 'boolean
+ :safe #'booleanp
+ :group 'cider
+ :package-version '(cider . "0.13.0"))
+
+(defcustom cider-eldoc-display-context-dependent-info nil
+ "When non-nil, display context dependent info in the eldoc where possible.
+CIDER will try to add expected function arguments based on the current context,
+for example for the datomic.api/q function where it will show the expected
+inputs of the query at point."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "0.15.0"))
+
+(defun cider--eldoc-format-class-names (class-names)
+ "Return a formatted CLASS-NAMES prefix string.
+CLASS-NAMES is a list of classes to which a Java interop form belongs.
+Only keep the first `cider-eldoc-max-class-names-to-display' names, and
+add a \"& x more\" suffix. Return nil if the CLASS-NAMES list is empty or
+mapping `cider-eldoc-ns-function' on it returns an empty list."
+ (when-let* ((eldoc-class-names (seq-remove #'null (mapcar (apply-partially cider-eldoc-ns-function) class-names)))
+ (eldoc-class-names-length (length eldoc-class-names)))
+ (cond
+ ;; truncate class-names list and then format it
+ ((and cider-eldoc-max-class-names-to-display
+ (> eldoc-class-names-length cider-eldoc-max-class-names-to-display))
+ (format "(%s & %s more)"
+ (thread-first eldoc-class-names
+ (seq-take cider-eldoc-max-class-names-to-display)
+ (string-join " ")
+ (cider-propertize 'ns))
+ (- eldoc-class-names-length cider-eldoc-max-class-names-to-display)))
+
+ ;; format the whole list but add surrounding parentheses
+ ((> eldoc-class-names-length 1)
+ (format "(%s)"
+ (thread-first eldoc-class-names
+ (string-join " ")
+ (cider-propertize 'ns))))
+
+ ;; don't add the parentheses
+ (t (format "%s" (car eldoc-class-names))))))
+
+(defun cider-eldoc-format-thing (ns symbol thing type)
+ "Format the eldoc subject defined by NS, SYMBOL, THING and TYPE.
+THING represents the thing at point which triggered eldoc. Normally NS and
+SYMBOL are used (they are derived from THING), but when empty we fallback to
+THING (e.g. for Java methods). Format it as a function, if FUNCTION-P
+is non-nil. Else format it as a variable."
+ (if-let* ((method-name (if (and symbol (not (string= symbol "")))
+ symbol
+ thing))
+ (propertized-method-name (cider-propertize method-name type))
+ (ns-or-class (if (and ns (stringp ns))
+ (funcall cider-eldoc-ns-function ns)
+ (cider--eldoc-format-class-names ns))))
+ (format "%s/%s"
+ ;; we set font-lock properties of classes in `cider--eldoc-format-class-names'
+ ;; to avoid font locking the parentheses and "& x more"
+ ;; so we only propertize ns-or-class if not already done
+ (if (get-text-property 1 'face ns-or-class)
+ ;; it is already propertized
+ ns-or-class
+ (cider-propertize ns-or-class 'ns))
+ propertized-method-name)
+ ;; in case ns-or-class is nil
+ propertized-method-name))
+
+(defun cider-eldoc-format-sym-doc (var ns docstring)
+ "Return the formatted eldoc string for VAR and DOCSTRING.
+
+Consider the value of `eldoc-echo-area-use-multiline-p' while formatting.
+If the entire line cannot fit in the echo area, the var name may be
+truncated or eliminated entirely from the output to make room for the
+description.
+
+Try to truncate the var with various strategies, so that the var and
+the docstring can be displayed in the minibuffer without resizing the window.
+We start with `cider-abbreviate-ns' and `cider-last-ns-segment'.
+Next, if the var is in current namespace, we remove NS from the eldoc string.
+Otherwise, only the docstring is returned."
+ (let* ((ea-multi eldoc-echo-area-use-multiline-p)
+ ;; Subtract 1 from window width since emacs will not write
+ ;; any chars to the last column, or in later versions, will
+ ;; cause a wraparound and resize of the echo area.
+ (ea-width (1- (window-width (minibuffer-window))))
+ (strip (- (+ (length var) (length docstring)) ea-width))
+ (newline (string-match-p "\n" docstring))
+ ;; Truncated var can be ea-var long
+ ;; Subtract 2 to account for the : and / added when including
+ ;; the namespace prefixed form in eldoc string
+ (ea-var (- (- ea-width (length docstring)) 2)))
+ (cond
+ ((or (eq ea-multi t)
+ (and (<= strip 0) (null newline))
+ (and ea-multi (or (> (length docstring) ea-width) newline)))
+ (format "%s: %s" var docstring))
+
+ ;; Now we have to truncate either the docstring or the var
+ (newline (cider-eldoc-format-sym-doc var ns (substring docstring 0 newline)))
+
+ ;; Only return the truncated docstring
+ ((> (length docstring) ea-width)
+ (substring docstring 0 ea-width))
+
+ ;; Try to truncate the var with cider-abbreviate-ns
+ ((<= (length (cider-abbreviate-ns var)) ea-var)
+ (format "%s: %s" (cider-abbreviate-ns var) docstring))
+
+ ;; Try to truncate var with cider-last-ns-segment
+ ((<= (length (cider-last-ns-segment var)) ea-var)
+ (format "%s: %s" (cider-last-ns-segment var) docstring))
+
+ ;; If the var is in current namespace, we try to truncate the var by
+ ;; skipping the namespace from the returned eldoc string
+ ((and (string-equal ns (cider-current-ns))
+ (<= (- (length var) (length ns)) ea-var))
+ (format "%s: %s"
+ (replace-regexp-in-string (format "%s/" ns) "" var)
+ docstring))
+
+ ;; We couldn't fit the var and docstring in the available space,
+ ;; so we just display the docstring
+ (t docstring))))
+
+(defun cider-eldoc-format-variable (thing eldoc-info)
+ "Return the formatted eldoc string for a variable.
+
+THING is the variable name. ELDOC-INFO is a p-list containing the eldoc
+information."
+ (let* ((ns (lax-plist-get eldoc-info "ns"))
+ (symbol (lax-plist-get eldoc-info "symbol"))
+ (docstring (lax-plist-get eldoc-info "docstring"))
+ (formatted-var (cider-eldoc-format-thing ns symbol thing 'var)))
+ (when docstring
+ (cider-eldoc-format-sym-doc formatted-var ns docstring))))
+
+(defun cider-eldoc-format-function (thing pos eldoc-info)
+ "Return the formatted eldoc string for a function.
+THING is the function name. POS is the argument-index of the functions
+arglists. ELDOC-INFO is a p-list containing the eldoc information."
+ (let ((ns (lax-plist-get eldoc-info "ns"))
+ (symbol (lax-plist-get eldoc-info "symbol"))
+ (arglists (lax-plist-get eldoc-info "arglists")))
+ (format "%s: %s"
+ (cider-eldoc-format-thing ns symbol thing 'fn)
+ (cider-eldoc-format-arglist arglists pos))))
+
+(defun cider-highlight-args (arglist pos)
+ "Format the the function ARGLIST for eldoc.
+POS is the index of the currently highlighted argument."
+ (let* ((rest-pos (cider--find-rest-args-position arglist))
+ (i 0))
+ (mapconcat
+ (lambda (arg)
+ (let ((argstr (format "%s" arg)))
+ (if (string= arg "&")
+ argstr
+ (prog1
+ (if (or (= (1+ i) pos)
+ (and rest-pos
+ (> (1+ i) rest-pos)
+ (> pos rest-pos)))
+ (propertize argstr 'face
+ 'eldoc-highlight-function-argument)
+ argstr)
+ (setq i (1+ i)))))) arglist " ")))
+
+(defun cider--find-rest-args-position (arglist)
+ "Find the position of & in the ARGLIST vector."
+ (seq-position arglist "&"))
+
+(defun cider-highlight-arglist (arglist pos)
+ "Format the ARGLIST for eldoc.
+POS is the index of the argument to highlight."
+ (concat "[" (cider-highlight-args arglist pos) "]"))
+
+(defun cider-eldoc-format-arglist (arglist pos)
+ "Format all the ARGLIST for eldoc.
+POS is the index of current argument."
+ (concat "("
+ (mapconcat (lambda (args) (cider-highlight-arglist args pos))
+ arglist
+ " ")
+ ")"))
+
+(defun cider-eldoc-beginning-of-sexp ()
+ "Move to the beginning of current sexp.
+
+Return the number of nested sexp the point was over or after. Return nil
+if the maximum number of sexps to skip is exceeded."
+ (let ((parse-sexp-ignore-comments t)
+ (num-skipped-sexps 0))
+ (condition-case _
+ (progn
+ ;; First account for the case the point is directly over a
+ ;; beginning of a nested sexp.
+ (condition-case _
+ (let ((p (point)))
+ (forward-sexp -1)
+ (forward-sexp 1)
+ (when (< (point) p)
+ (setq num-skipped-sexps 1)))
+ (error))
+ (while
+ (let ((p (point)))
+ (forward-sexp -1)
+ (when (< (point) p)
+ (setq num-skipped-sexps
+ (unless (and cider-eldoc-max-num-sexps-to-skip
+ (>= num-skipped-sexps
+ cider-eldoc-max-num-sexps-to-skip))
+ ;; Without the above guard,
+ ;; `cider-eldoc-beginning-of-sexp' could traverse the
+ ;; whole buffer when the point is not within a
+ ;; list. This behavior is problematic especially with
+ ;; a buffer containing a large number of
+ ;; non-expressions like a REPL buffer.
+ (1+ num-skipped-sexps)))))))
+ (error))
+ num-skipped-sexps))
+
+(defun cider-eldoc-thing-type (eldoc-info)
+ "Return the type of the ELDOC-INFO being displayed by eldoc.
+It can be a function or var now."
+ (pcase (lax-plist-get eldoc-info "type")
+ ("function" 'fn)
+ ("variable" 'var)))
+
+(defun cider-eldoc-info-at-point ()
+ "Return eldoc info at point.
+First go to the beginning of the sexp and check if the eldoc is to be
+considered (i.e sexp is a method call) and not a map or vector literal.
+Then go back to the point and return its eldoc."
+ (save-excursion
+ (unless (cider-in-comment-p)
+ (let* ((current-point (point)))
+ (cider-eldoc-beginning-of-sexp)
+ (unless (member (or (char-before (point)) 0) '(?\" ?\{ ?\[))
+ (goto-char current-point)
+ (when-let* ((eldoc-info (cider-eldoc-info
+ (cider--eldoc-remove-dot (cider-symbol-at-point)))))
+ `("eldoc-info" ,eldoc-info
+ "thing" ,(cider-symbol-at-point)
+ "pos" 0)))))))
+
+(defun cider-eldoc-info-at-sexp-beginning ()
+ "Return eldoc info for first symbol in the sexp."
+ (save-excursion
+ (when-let* ((beginning-of-sexp (cider-eldoc-beginning-of-sexp))
+ ;; If we are at the beginning of function name, this will be -1
+ (argument-index (max 0 (1- beginning-of-sexp))))
+ (unless (or (memq (or (char-before (point)) 0)
+ '(?\" ?\{ ?\[))
+ (cider-in-comment-p))
+ (when-let* ((eldoc-info (cider-eldoc-info
+ (cider--eldoc-remove-dot (cider-symbol-at-point)))))
+ `("eldoc-info" ,eldoc-info
+ "thing" ,(cider-symbol-at-point)
+ "pos" ,argument-index))))))
+
+(defun cider-eldoc-info-in-current-sexp ()
+ "Return eldoc information from the sexp.
+If `cider-eldoc-display-for-symbol-at-poin' is non-nil and
+the symbol at point has a valid eldoc available, return that.
+Otherwise return the eldoc of the first symbol of the sexp."
+ (or (when cider-eldoc-display-for-symbol-at-point
+ (cider-eldoc-info-at-point))
+ (cider-eldoc-info-at-sexp-beginning)))
+
+(defun cider-eldoc--convert-ns-keywords (thing)
+ "Convert THING values that match ns macro keywords to function names."
+ (pcase thing
+ (":import" "clojure.core/import")
+ (":refer-clojure" "clojure.core/refer-clojure")
+ (":use" "clojure.core/use")
+ (":refer" "clojure.core/refer")
+ (_ thing)))
+
+(defun cider-eldoc-info (thing)
+ "Return the info for THING.
+This includes the arglist and ns and symbol name (if available)."
+ (let ((thing (cider-eldoc--convert-ns-keywords thing)))
+ (when (and (cider-nrepl-op-supported-p "eldoc")
+ thing
+ ;; ignore empty strings
+ (not (string= thing ""))
+ ;; ignore strings
+ (not (string-prefix-p "\"" thing))
+ ;; ignore regular expressions
+ (not (string-prefix-p "#" thing))
+ ;; ignore chars
+ (not (string-prefix-p "\\" thing))
+ ;; ignore numbers
+ (not (string-match-p "^[0-9]" thing)))
+ ;; check if we can used the cached eldoc info
+ (cond
+ ;; handle keywords for map access
+ ((string-prefix-p ":" thing) (list "symbol" thing
+ "type" "function"
+ "arglists" '(("map") ("map" "not-found"))))
+ ;; handle Classname. by displaying the eldoc for new
+ ((string-match-p "^[A-Z].+\\.$" thing) (list "symbol" thing
+ "type" "function"
+ "arglists" '(("args*"))))
+ ;; generic case
+ (t (if (equal thing (car cider-eldoc-last-symbol))
+ (cadr cider-eldoc-last-symbol)
+ (when-let* ((eldoc-info (cider-sync-request:eldoc thing)))
+ (let* ((arglists (nrepl-dict-get eldoc-info "eldoc"))
+ (docstring (nrepl-dict-get eldoc-info "docstring"))
+ (type (nrepl-dict-get eldoc-info "type"))
+ (ns (nrepl-dict-get eldoc-info "ns"))
+ (class (nrepl-dict-get eldoc-info "class"))
+ (name (nrepl-dict-get eldoc-info "name"))
+ (member (nrepl-dict-get eldoc-info "member"))
+ (ns-or-class (if (and ns (not (string= ns "")))
+ ns
+ class))
+ (name-or-member (if (and name (not (string= name "")))
+ name
+ (format ".%s" member)))
+ (eldoc-plist (list "ns" ns-or-class
+ "symbol" name-or-member
+ "arglists" arglists
+ "docstring" docstring
+ "type" type)))
+ ;; add context dependent args if requested by defcustom
+ ;; do not cache this eldoc info to avoid showing info
+ ;: of the previous context
+ (if cider-eldoc-display-context-dependent-info
+ (cond
+ ;; add inputs of datomic query
+ ((and (equal ns-or-class "datomic.api")
+ (equal name-or-member "q"))
+ (let ((arglists (lax-plist-get eldoc-plist "arglists")))
+ (lax-plist-put eldoc-plist "arglists"
+ (cider--eldoc-add-datomic-query-inputs-to-arglists arglists))))
+ ;; if none of the clauses is successful, do cache the eldoc
+ (t (setq cider-eldoc-last-symbol (list thing eldoc-plist))))
+ ;; middleware eldoc lookups are expensive, so we
+ ;; cache the last lookup. This eliminates the need
+ ;; for extra middleware requests within the same sexp.
+ (setq cider-eldoc-last-symbol (list thing eldoc-plist)))
+ eldoc-plist))))))))
+
+(defun cider--eldoc-remove-dot (sym)
+ "Remove the preceding \".\" from a namespace qualified SYM and return sym.
+Only useful for interop forms. Clojure forms would be returned unchanged."
+ (when sym (replace-regexp-in-string "/\\." "/" sym)))
+
+(defun cider--eldoc-edn-file-p (file-name)
+ "Check whether FILE-NAME is representing an EDN file."
+ (and file-name (equal (file-name-extension file-name) "edn")))
+
+(defun cider--eldoc-add-datomic-query-inputs-to-arglists (arglists)
+ "Add the expected inputs of the datomic query to the ARGLISTS."
+ (if (cider-second-sexp-in-list)
+ (let* ((query (cider-second-sexp-in-list))
+ (query-inputs (nrepl-dict-get
+ (cider-sync-request:eldoc-datomic-query query)
+ "inputs")))
+ (if query-inputs
+ (thread-first
+ (thread-last arglists
+ (car)
+ (remove "&")
+ (remove "inputs"))
+ (append (car query-inputs))
+ (list))
+ arglists))
+ arglists))
+
+(defun cider-eldoc ()
+ "Backend function for eldoc to show argument list in the echo area."
+ (when (and (cider-connected-p)
+ ;; don't clobber an error message in the minibuffer
+ (not (member last-command '(next-error previous-error)))
+ ;; don't try to provide eldoc in EDN buffers
+ (not (cider--eldoc-edn-file-p buffer-file-name)))
+ (let* ((sexp-eldoc-info (cider-eldoc-info-in-current-sexp))
+ (eldoc-info (lax-plist-get sexp-eldoc-info "eldoc-info"))
+ (pos (lax-plist-get sexp-eldoc-info "pos"))
+ (thing (lax-plist-get sexp-eldoc-info "thing")))
+ (when eldoc-info
+ (if (equal (cider-eldoc-thing-type eldoc-info) 'fn)
+ (cider-eldoc-format-function thing pos eldoc-info)
+ (cider-eldoc-format-variable thing eldoc-info))))))
+
+(defun cider-eldoc-setup ()
+ "Setup eldoc in the current buffer.
+eldoc mode has to be enabled for this to have any effect."
+ (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-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancy@gmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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:
+
+;; 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 'cider-client)
+(require 'cider-repl)
+(require 'cider-popup)
+(require 'cider-common)
+(require 'cider-util)
+(require 'cider-stacktrace)
+(require 'cider-overlays)
+(require 'cider-compat)
+
+(require 'clojure-mode)
+(require 'ansi-color)
+(require 'cl-lib)
+(require 'subr-x)
+(require 'compile)
+
+(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.
+
+Irespective of the value of this variable, the `cider-error-buffer' is
+always generated in the background. Use `cider-selector' to
+navigate to this buffer."
+ :type '(choice (const :tag "always" t)
+ (const except-in-repl)
+ (const only-in-repl)
+ (const :tag "never" nil))
+ :group 'cider)
+
+(defcustom cider-auto-jump-to-error t
+ "Control the cursor jump behaviour 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-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"))
+
+
+(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"))
+
+\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)))
+ (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--render-stacktrace-causes (causes &optional error-types)
+ "If CAUSES is non-nil, render its contents into a new error buffer.
+Optional argument ERROR-TYPES contains a list which should determine the
+op/situation that originated this error."
+ (when causes
+ (let ((error-buffer (cider-new-error-buffer #'cider-stacktrace-mode error-types)))
+ (cider-stacktrace-render error-buffer (reverse causes) error-types))))
+
+(defun cider--handle-stacktrace-response (response causes)
+ "Handle stacktrace op RESPONSE, aggregating the result into CAUSES.
+If RESPONSE contains a cause, cons it onto CAUSES and return that. If
+RESPONSE is the final message (i.e. it contains a status), render CAUSES
+into a new error buffer."
+ (nrepl-dbind-response response (class status)
+ (cond (class (cons response causes))
+ (status (cider--render-stacktrace-causes causes)))))
+
+(defun cider-default-err-op-handler ()
+ "Display the last exception, with middleware support."
+ ;; Causes are returned as a series of messages, which we aggregate in `causes'
+ (let (causes)
+ (cider-nrepl-send-request
+ (nconc '("op" "stacktrace")
+ (when (cider--pprint-fn)
+ `("pprint-fn" ,(cider--pprint-fn)))
+ (when cider-stacktrace-print-length
+ `("print-length" ,cider-stacktrace-print-length))
+ (when cider-stacktrace-print-level
+ `("print-level" ,cider-stacktrace-print-level)))
+ (lambda (response)
+ ;; While the return value of `cider--handle-stacktrace-response' is not
+ ;; meaningful for the last message, we do not need the value of `causes'
+ ;; after it has been handled, so it's fine to set it unconditionally here
+ (setq causes (cider--handle-stacktrace-response response causes))))))
+
+(defun cider-default-err-handler ()
+ "This function determines how the error buffer is shown.
+It delegates the actual error content to the eval or op handler."
+ (if (cider-nrepl-op-supported-p "stacktrace")
+ (cider-default-err-op-handler)
+ (cider-default-err-eval-handler)))
+
+(defvar cider-compilation-regexp
+ '("\\(?:.*\\(warning, \\)\\|.*?\\(, compiling\\):(\\)\\(.*?\\):\\([[:digit:]]+\\)\\(?::\\([[:digit:]]+\\)\\)?\\(\\(?: - \\(.*\\)\\)\\|)\\)" 3 4 5 (1))
+ "Specifications for matching errors and warnings in Clojure stacktraces.
+See `compilation-error-regexp-alist' for help on their format.")
+
+(add-to-list 'compilation-error-regexp-alist-alist
+ (cons 'cider cider-compilation-regexp))
+(add-to-list 'compilation-error-regexp-alist 'cider)
+
+(defun cider-extract-error-info (regexp message)
+ "Extract error information with REGEXP against MESSAGE."
+ (let ((file (nth 1 regexp))
+ (line (nth 2 regexp))
+ (col (nth 3 regexp))
+ (type (nth 4 regexp))
+ (pat (car regexp)))
+ (when (string-match pat message)
+ ;; special processing for type (1.2) style
+ (setq type (if (consp type)
+ (or (and (car type) (match-end (car type)) 1)
+ (and (cdr type) (match-end (cdr type)) 0)
+ 2)))
+ (list
+ (when file
+ (let ((val (match-string-no-properties file message)))
+ (unless (string= val "NO_SOURCE_PATH") val)))
+ (when line (string-to-number (match-string-no-properties line message)))
+ (when col
+ (let ((val (match-string-no-properties col message)))
+ (when val (string-to-number val))))
+ (aref [cider-warning-highlight-face
+ cider-warning-highlight-face
+ cider-error-highlight-face]
+ (or type 2))
+ message))))
+
+(defun cider--goto-expression-start ()
+ "Go to the beginning a list, vector, map or set outside of a string.
+We do so by starting and the current position and proceeding backwards
+until we find a delimiters that's not inside a string."
+ (if (and (looking-back "[])}]" (line-beginning-position))
+ (null (nth 3 (syntax-ppss))))
+ (backward-sexp)
+ (while (or (not (looking-at-p "[({[]"))
+ (nth 3 (syntax-ppss)))
+ (backward-char))))
+
+(defun cider--find-last-error-location (message)
+ "Return the location (begin end buffer) from the Clojure error MESSAGE.
+If location could not be found, return nil."
+ (save-excursion
+ (let ((info (cider-extract-error-info cider-compilation-regexp message)))
+ (when info
+ (let ((file (nth 0 info))
+ (line (nth 1 info))
+ (col (nth 2 info)))
+ (unless (or (not (stringp file))
+ (cider--tooling-file-p file))
+ (when-let* ((buffer (cider-find-file file)))
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (move-to-column (or col 0))
+ (let ((begin (progn (if col (cider--goto-expression-start) (back-to-indentation))
+ (point)))
+ (end (progn (if col (forward-list) (move-end-of-line nil))
+ (point))))
+ (list begin end buffer))))))))))))
+
+(defun cider-handle-compilation-errors (message eval-buffer)
+ "Highlight and jump to compilation error extracted from MESSAGE.
+EVAL-BUFFER is the buffer that was current during user's interactive
+evaluation command. Honor `cider-auto-jump-to-error'."
+ (when-let* ((loc (cider--find-last-error-location message))
+ (overlay (make-overlay (nth 0 loc) (nth 1 loc) (nth 2 loc)))
+ (info (cider-extract-error-info cider-compilation-regexp message)))
+ (let* ((face (nth 3 info))
+ (note (nth 4 info))
+ (auto-jump (if (eq cider-auto-jump-to-error 'errors-only)
+ (not (or (eq face 'cider-warning-highlight-face)
+ (string-match-p "warning" note)))
+ cider-auto-jump-to-error)))
+ (overlay-put overlay 'cider-note-p t)
+ (overlay-put overlay 'font-lock-face face)
+ (overlay-put overlay 'cider-note note)
+ (overlay-put overlay 'help-echo note)
+ (overlay-put overlay 'modification-hooks
+ (list (lambda (o &rest _args) (delete-overlay o))))
+ (when auto-jump
+ (with-current-buffer eval-buffer
+ (push-mark)
+ ;; At this stage selected window commonly is *cider-error* and we need to
+ ;; re-select the original user window. If eval-buffer is not
+ ;; visible it was probably covered as a result of a small screen or user
+ ;; configuration (https://github.com/clojure-emacs/cider/issues/847). In
+ ;; that case we don't jump at all in order to avoid covering *cider-error*
+ ;; buffer.
+ (when-let* ((win (get-buffer-window eval-buffer)))
+ (with-selected-window win
+ (cider-jump-to (nth 2 loc) (car loc)))))))))
+
+\f
+;;; Interactive evaluation handlers
+(defun cider-insert-eval-handler (&optional buffer)
+ "Make an nREPL evaluation handler for the BUFFER.
+The handler simply inserts the result value in BUFFER."
+ (let ((eval-buffer (current-buffer)))
+ (nrepl-make-response-handler (or buffer eval-buffer)
+ (lambda (_buffer value)
+ (with-current-buffer buffer
+ (insert value)))
+ (lambda (_buffer out)
+ (cider-repl-emit-interactive-stdout out))
+ (lambda (_buffer err)
+ (cider-handle-compilation-errors err eval-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)))))
+
+(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."
+ (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))
+ (nrepl-make-response-handler (or buffer eval-buffer)
+ (lambda (_buffer value)
+ (if beg
+ (unless fringed
+ (cider--make-fringe-overlays-for-region beg end)
+ (setq fringed t))
+ (cider--make-fringe-overlay end))
+ (cider--display-interactive-eval-result value end))
+ (lambda (_buffer out)
+ (cider-emit-interactive-eval-output out))
+ (lambda (_buffer err)
+ (cider-emit-interactive-eval-err-output err)
+ (cider-handle-compilation-errors err eval-buffer))
+ '())))
+
+(defun cider-load-file-handler (&optional buffer)
+ "Make a load file handler for BUFFER."
+ (let ((eval-buffer (current-buffer)))
+ (nrepl-make-response-handler (or buffer eval-buffer)
+ (lambda (buffer value)
+ (cider--display-interactive-eval-result value)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (cider--make-fringe-overlays-for-region (point-min) (point-max))
+ (run-hooks 'cider-file-loaded-hook))))
+ (lambda (_buffer value)
+ (cider-emit-interactive-eval-output value))
+ (lambda (_buffer err)
+ (cider-emit-interactive-eval-err-output err)
+ (cider-handle-compilation-errors err eval-buffer))
+ '()
+ (lambda ()
+ (funcall nrepl-err-handler)))))
+
+(defun cider-eval-print-handler (&optional buffer)
+ "Make a handler for evaluating and printing result in BUFFER."
+ (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 at which to insert. COMMENT-PREFIX is the comment
+prefix to use."
+ (nrepl-make-response-handler buffer
+ (lambda (buffer value)
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char location)
+ (insert (concat comment-prefix
+ value "\n")))))
+ (lambda (_buffer out)
+ (cider-emit-interactive-eval-output out))
+ (lambda (_buffer err)
+ (cider-emit-interactive-eval-err-output err))
+ '()))
+
+(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 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."
+ (cl-flet ((multiline-comment-handler (buffer value)
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char location)
+ (let ((lines (split-string value "[\n]+" t)))
+ ;; only the first line gets the normal comment-prefix
+ (insert (concat comment-prefix (pop lines)))
+ (dolist (elem lines)
+ (insert (concat "\n" continued-prefix elem)))
+ (unless (string= comment-postfix "")
+ (insert comment-postfix)))))))
+ (nrepl-make-response-handler buffer
+ '()
+ #'multiline-comment-handler
+ #'multiline-comment-handler
+ '())))
+
+(defun cider-popup-eval-out-handler (&optional buffer)
+ "Make a handler for evaluating and printing stdout/stderr in popup BUFFER.
+This is used by pretty-printing commands and intentionally discards their results."
+ (cl-flet ((popup-output-handler (buffer str)
+ (cider-emit-into-popup-buffer buffer
+ (ansi-color-apply str)
+ nil
+ t)))
+ (nrepl-make-response-handler (or buffer (current-buffer))
+ '()
+ ;; stdout handler
+ #'popup-output-handler
+ ;; stderr handler
+ #'popup-output-handler
+ '())))
+
+\f
+;;; Interactive valuation commands
+
+(defvar cider-to-nrepl-filename-function
+ (with-no-warnings
+ (if (eq system-type 'cygwin)
+ #'cygwin-convert-file-name-to-windows
+ #'identity))
+ "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 appended to 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)
+ (remove-overlays start end 'cider-temporary t))
+ (unless (and cider-interactive-eval-override
+ (functionp cider-interactive-eval-override)
+ (funcall cider-interactive-eval-override form callback bounds))
+ (cider-map-repls :auto
+ (lambda (connection)
+ (cider--prep-interactive-eval form connection)
+ (cider-nrepl-request:eval
+ form
+ (or callback (cider-interactive-eval-handler nil bounds))
+ ;; always eval ns forms in the user namespace
+ ;; otherwise trying to eval ns form for the first time will produce an error
+ (if (cider-ns-form-p form) "user" (cider-current-ns))
+ (when start (line-number-at-pos start))
+ (when start (cider-column-number-at-pos start))
+ 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)))
+
+(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)))
+
+(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
+ (backward-kill-sexp)
+ (cider-interactive-eval last-sexp (cider-eval-print-handler))))
+
+(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)))
+
+(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--eval-in-context (code)
+ "Evaluate CODE in user-provided evaluation context."
+ (let* ((code (string-trim-right code))
+ (eval-context (read-string
+ (format "Evaluation context (let-style) for `%s': " code)
+ cider-previous-eval-context))
+ (code (concat "(let [" eval-context "]\n " code ")")))
+ (cider-interactive-eval code)
+ (setq-local cider-previous-eval-context eval-context)))
+
+(defun cider-eval-last-sexp-in-context ()
+ "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."
+ (interactive)
+ (cider--eval-in-context (cider-last-sexp)))
+
+(defun cider-eval-sexp-at-point-in-context ()
+ "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."
+ (interactive)
+ (cider--eval-in-context (cider-sexp-at-point)))
+
+(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)
+ insertion-point
+ cider-comment-prefix)
+ bounds)))
+
+(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)
+ insertion-point
+ cider-comment-prefix
+ cider-comment-continued-prefix
+ comment-postfix)
+ bounds
+ (cider--nrepl-pprint-request-plist (cider--pretty-print-width)))))
+
+(defun cider-pprint-eval-last-sexp-to-comment (&optional insert-before)
+ "Evaluate the last sexp and insert result as comment.
+
+The formatting of the comment is controlled via three options:
+ `cider-comment-prefix' \";; => \"
+ `cider-comment-continued-prefix' \";; \"
+ `cider-comment-postfix' \"\"
+
+so that with customization you can optionally wrap the output
+in the reader macro \"#_( .. )\", or \"(comment ... )\", or any
+other desired formatting.
+
+If INSERT-BEFORE is non-nil, insert before the form, otherwise afterwards."
+ (interactive "P")
+ (cider-pprint-form-to-comment 'cider-last-sexp insert-before))
+
+(defun cider-pprint-eval-defun-to-comment (&optional insert-before)
+ "Evaluate the \"top-level\" form and insert result as comment.
+
+The formatting of the comment is controlled via three options:
+ `cider-comment-prefix' \";; => \"
+ `cider-comment-continued-prefix' \";; \"
+ `cider-comment-postfix' \"\"
+
+so that with customization you can optionally wrap the output
+in the reader macro \"#_( .. )\", or \"(comment ... )\", or any
+other desired formatting.
+
+If INSERT-BEFORE is non-nil, insert before the form, otherwise afterwards."
+ (interactive "P")
+ (cider-pprint-form-to-comment 'cider-defun-at-point insert-before))
+
+(declare-function cider-switch-to-repl-buffer "cider-mode")
+
+(defun cider-eval-last-sexp-to-repl (&optional prefix)
+ "Evaluate the expression preceding point and insert its result in the REPL.
+If invoked with a PREFIX argument, switch to the REPL buffer."
+ (interactive "P")
+ (cider-interactive-eval nil
+ (cider-insert-eval-handler (cider-current-repl))
+ (cider-last-sexp 'bounds))
+ (when prefix
+ (cider-switch-to-repl-buffer)))
+
+(defun cider-pprint-eval-last-sexp-to-repl (&optional prefix)
+ "Evaluate expr before point and insert its pretty-printed result in the REPL.
+If invoked with a PREFIX argument, switch to the REPL buffer."
+ (interactive "P")
+ (cider-interactive-eval nil
+ (cider-insert-eval-handler (cider-current-repl))
+ (cider-last-sexp 'bounds)
+ (cider--nrepl-pprint-request-plist (cider--pretty-print-width)))
+ (when prefix
+ (cider-switch-to-repl-buffer)))
+
+(defun cider-eval-print-last-sexp ()
+ "Evaluate the expression preceding point.
+Print its value into the current buffer."
+ (interactive)
+ (cider-interactive-eval nil
+ (cider-eval-print-handler)
+ (cider-last-sexp 'bounds)))
+
+(defun cider--pprint-eval-form (form)
+ "Pretty print FORM in popup buffer."
+ (let* ((result-buffer (cider-popup-buffer cider-result-buffer nil 'clojure-mode 'ancillary))
+ (handler (cider-popup-eval-out-handler result-buffer)))
+ (cider-interactive-eval (when (stringp form) form)
+ handler
+ (when (consp form) form)
+ (cider--nrepl-pprint-request-plist (cider--pretty-print-width)))))
+
+(defun cider-pprint-eval-last-sexp (&optional output-to-current-buffer)
+ "Evaluate the sexp preceding point and pprint its value.
+If invoked with OUTPUT-TO-CURRENT-BUFFER, insert as comment in the current
+buffer, else display in a popup buffer."
+ (interactive "P")
+ (if output-to-current-buffer
+ (cider-pprint-eval-last-sexp-to-comment)
+ (cider--pprint-eval-form (cider-last-sexp 'bounds))))
+
+(defun cider--prompt-and-insert-inline-dbg ()
+ "Insert a #dbg button at the current sexp."
+ (save-excursion
+ (let ((beg))
+ (skip-chars-forward "\r\n[:blank:]")
+ (unless (looking-at-p "(")
+ (ignore-errors (backward-up-list)))
+ (setq beg (point))
+ (let* ((cond (cider-read-from-minibuffer "Condition for debugging (leave empty for \"always\"): "))
+ (button (propertize (concat "#dbg"
+ (unless (equal cond "")
+ (format " ^{:break/when %s}" cond)))
+ 'font-lock-face 'cider-fragile-button-face)))
+ (when (> (current-column) 30)
+ (insert "\n")
+ (indent-according-to-mode))
+ (insert button)
+ (when (> (current-column) 40)
+ (insert "\n")
+ (indent-according-to-mode)))
+ (make-button beg (point)
+ 'help-echo "Breakpoint. Reevaluate this form to remove it."
+ :type 'cider-fragile))))
+
+(defun cider-eval-defun-at-point (&optional debug-it)
+ "Evaluate the current toplevel form, and print result in the minibuffer.
+With DEBUG-IT prefix argument, also debug the entire form as with the
+command `cider-debug-defun-at-point'."
+ (interactive "P")
+ (let ((inline-debug (eq 16 (car-safe debug-it))))
+ (when debug-it
+ (when (derived-mode-p 'clojurescript-mode)
+ (when (y-or-n-p (concat "The debugger doesn't support ClojureScript yet, and we need help with that."
+ " \nWould you like to read the Feature Request?"))
+ (browse-url "https://github.com/clojure-emacs/cider/issues/1416"))
+ (user-error "The debugger does not support ClojureScript"))
+ (when inline-debug
+ (cider--prompt-and-insert-inline-dbg)))
+ (cider-interactive-eval (when (and debug-it (not inline-debug))
+ (concat "#dbg\n" (cider-defun-at-point)))
+ nil (cider-defun-at-point 'bounds))))
+
+(defun cider--calculate-opening-delimiters ()
+ "Walks up the list of expressions to collect all sexp opening delimiters.
+The result is a list of the delimiters.
+
+That function is used in `cider-eval-defun-up-to-point' so it can make an
+incomplete expression complete."
+ (interactive)
+ (let ((result nil))
+ (save-excursion
+ (condition-case nil
+ (while t
+ (backward-up-list)
+ (push (char-after) result))
+ (error result)))))
+
+(defun cider--matching-delimiter (delimiter)
+ "Get the matching (opening/closing) delimiter for DELIMITER."
+ (pcase delimiter
+ (?\( ?\))
+ (?\[ ?\])
+ (?\{ ?\})
+ (?\) ?\()
+ (?\] ?\[)
+ (?\} ?\{)))
+
+(defun cider--calculate-closing-delimiters ()
+ "Compute the list of closing delimiters to make the defun before point valid."
+ (mapcar #'cider--matching-delimiter (cider--calculate-opening-delimiters)))
+
+(defun cider-eval-defun-up-to-point (&optional output-to-current-buffer)
+ "Evaluate the current toplevel form up to point.
+If invoked with OUTPUT-TO-CURRENT-BUFFER, print the result in the current
+buffer. It constructs an expression to eval in the following manner:
+
+- It find the code between the point and the start of the toplevel expression;
+- It balances this bit of code by closing all open expressions;
+- It evaluates the resulting code using `cider-interactive-eval'."
+ (interactive "P")
+ (let* ((beg-of-defun (save-excursion (beginning-of-defun) (point)))
+ (code (buffer-substring-no-properties beg-of-defun (point)))
+ (code (concat code (cider--calculate-closing-delimiters))))
+ (cider-interactive-eval
+ code
+ (when output-to-current-buffer (cider-eval-print-handler)))))
+
+(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)))))
+
+(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 ()
+ "Evaluate the current buffer's namespace form."
+ (interactive)
+ (when (clojure-find-ns)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (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)))))
+
+(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)))))
+
+;; 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)))
+
+(defvar cider-eval-commands-map
+ (let ((map (define-prefix-command 'cider-eval-commands-map)))
+ ;; single key bindings defined last for display in menu
+ (define-key map (kbd "w") #'cider-eval-last-sexp-and-replace)
+ (define-key map (kbd "r") #'cider-eval-region)
+ (define-key map (kbd "n") #'cider-eval-ns-form)
+ (define-key map (kbd "d") #'cider-eval-defun-at-point)
+ (define-key map (kbd "e") #'cider-eval-last-sexp)
+ (define-key map (kbd "v") #'cider-eval-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 "f") 'cider-eval-pprint-commands-map)
+
+ ;; duplicates with C- for convenience
+ (define-key map (kbd "C-w") #'cider-eval-last-sexp-and-replace)
+ (define-key map (kbd "C-r") #'cider-eval-region)
+ (define-key map (kbd "C-n") #'cider-eval-ns-form)
+ (define-key map (kbd "C-d") #'cider-eval-defun-at-point)
+ (define-key map (kbd "C-f") #'cider-eval-last-sexp)
+ (define-key map (kbd "C-v") #'cider-eval-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-f") 'cider-eval-pprint-commands-map)))
+
+(defun cider--file-string (file)
+ "Read the contents of a FILE and return as a string."
+ (with-current-buffer (find-file-noselect file)
+ (substring-no-properties (buffer-string))))
+
+(defun cider-load-buffer (&optional buffer)
+ "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."
+ (interactive)
+ (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)
+ (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)))
+ (message "Loading %s..." filename))))))
+
+(defun cider-load-file (filename)
+ "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'."
+ (interactive (list
+ (read-file-name "Load file: " nil nil nil
+ (when (buffer-file-name)
+ (file-name-nondirectory
+ (buffer-file-name))))))
+ (if-let* ((buffer (find-buffer-visiting filename)))
+ (cider-load-buffer buffer)
+ (cider-load-buffer (find-file-noselect filename))))
+
+(defun cider-load-all-files (directory)
+ "Load all files in DIRECTORY (recursively).
+Useful when the running nREPL on remote host."
+ (interactive "DLoad files beneath directory: ")
+ (mapcar #'cider-load-file
+ (directory-files-recursively directory ".clj$")))
+
+(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-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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 '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")
+ (cider-ensure-op-supported "info")
+ (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")
+ (cider-ensure-op-supported "info")
+ (if-let* ((symbol-file (save-excursion
+ (mouse-set-point event)
+ (cider-symbol-at-point 'look-back))))
+ (cider-find-dwim symbol-file)
+ (user-error "No variable or resource here")))
+
+(defun cider--find-dwim (symbol-file callback &optional other-window)
+ "Find the SYMBOL-FILE at point.
+CALLBACK upon failure to invoke prompt if not prompted previously.
+Show results in a different window if OTHER-WINDOW is true."
+ (if-let* ((info (cider-var-info symbol-file)))
+ (cider--jump-to-loc-from-info info other-window)
+ (progn
+ (cider-ensure-op-supported "resource")
+ (if-let* ((resource (cider-sync-request:resource symbol-file))
+ (buffer (cider-find-file resource)))
+ (cider-jump-to buffer 0 other-window)
+ (if (cider--prompt-for-symbol-p current-prefix-arg)
+ (error "Resource or var %s not resolved" symbol-file)
+ (let ((current-prefix-arg (if current-prefix-arg nil '(4))))
+ (call-interactively callback)))))))
+
+(defun cider--find-dwim-interactive (prompt)
+ "Get interactive arguments for jump-to functions using PROMPT as needed."
+ (if (cider--prompt-for-symbol-p current-prefix-arg)
+ (list
+ (cider-read-from-minibuffer prompt (thing-at-point 'filename)))
+ (list (or (thing-at-point 'filename) "")))) ; No prompt.
+
+(defun cider-find-dwim-other-window (symbol-file)
+ "Jump to SYMBOL-FILE at point, place results in other window."
+ (interactive (cider--find-dwim-interactive "Jump to: "))
+ (cider--find-dwim symbol-file 'cider-find-dwim-other-window t))
+
+;;;###autoload
+(defun cider-find-dwim (symbol-file)
+ "Find and display the SYMBOL-FILE at point.
+SYMBOL-FILE could be a var or a resource. If thing at point is empty then
+show dired on project. If var is not found, try to jump to resource of the
+same name. When called interactively, a prompt is given according to the
+variable `cider-prompt-for-symbol'. A single or double prefix argument
+inverts the meaning. A prefix of `-' or a double prefix argument causes
+the results to be displayed in a different window. A default value of thing
+at point is given when prompted."
+ (interactive (cider--find-dwim-interactive "Jump to: "))
+ (cider--find-dwim symbol-file `cider-find-dwim
+ (cider--open-other-window-p current-prefix-arg)))
+
+;;;###autoload
+(defun cider-find-resource (path)
+ "Find the resource at PATH.
+Prompt for input as indicated by the variable `cider-prompt-for-symbol'.
+A single or double prefix argument inverts the meaning of
+`cider-prompt-for-symbol'. A prefix argument of `-` or a double prefix
+argument causes the results to be displayed in other window. The default
+value is thing at point."
+ (interactive
+ (list
+ (if (cider--prompt-for-symbol-p current-prefix-arg)
+ (completing-read "Resource: "
+ (cider-sync-request:resources-list)
+ nil nil
+ (thing-at-point 'filename))
+ (or (thing-at-point 'filename) ""))))
+ (cider-ensure-op-supported "resource")
+ (when (= (length path) 0)
+ (error "Cannot find resource for empty path"))
+ (if-let* ((resource (cider-sync-request:resource path))
+ (buffer (cider-find-file resource)))
+ (cider-jump-to buffer nil (cider--open-other-window-p current-prefix-arg))
+ (if (cider--prompt-for-symbol-p current-prefix-arg)
+ (error "Cannot find resource %s" path)
+ (let ((current-prefix-arg (cider--invert-prefix-arg current-prefix-arg)))
+ (call-interactively 'cider-find-resource)))))
+
+(defun cider--invert-prefix-arg (arg)
+ "Invert the effect of prefix value ARG on `cider-prompt-for-symbol'.
+This function preserves the `other-window' meaning of ARG."
+ (let ((narg (prefix-numeric-value arg)))
+ (pcase narg
+ (16 -1) ; empty empty -> -
+ (-1 16) ; - -> empty empty
+ (4 nil) ; empty -> no-prefix
+ (_ 4)))) ; no-prefix -> empty
+
+(defun cider--prefix-invert-prompt-p (arg)
+ "Test prefix value ARG for its effect on `cider-prompt-for-symbol`."
+ (let ((narg (prefix-numeric-value arg)))
+ (pcase narg
+ (16 t) ; empty empty
+ (4 t) ; empty
+ (_ nil))))
+
+(defun cider--prompt-for-symbol-p (&optional prefix)
+ "Check if cider should prompt for symbol.
+Tests againsts PREFIX and the value of `cider-prompt-for-symbol'.
+Invert meaning of `cider-prompt-for-symbol' if PREFIX indicates it should be."
+ (if (cider--prefix-invert-prompt-p prefix)
+ (not cider-prompt-for-symbol) cider-prompt-for-symbol))
+
+(defun cider--find-ns (ns &optional other-window)
+ "Find the file containing NS's definition.
+Optionally open it in a different window if OTHER-WINDOW is truthy."
+ (if-let* ((path (cider-sync-request:ns-path ns)))
+ (cider-jump-to (cider-find-file path) nil other-window)
+ (user-error "Can't find namespace `%s'" ns)))
+
+;;;###autoload
+(defun cider-find-ns (&optional arg ns)
+ "Find the file containing NS.
+A prefix ARG of `-` or a double prefix argument causes
+the results to be displayed in a different window."
+ (interactive "P")
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "ns-path")
+ (if ns
+ (cider--find-ns ns)
+ (let* ((namespaces (cider-sync-request:ns-list))
+ (ns (completing-read "Find namespace: " namespaces)))
+ (cider--find-ns ns (cider--open-other-window-p arg)))))
+
+;;;###autoload
+(defun cider-find-keyword (&optional arg)
+ "Find the namespace of the keyword at point and its first occurrence there.
+
+For instance - if the keyword at point is \":cider.demo/keyword\", this command
+would find the namespace \"cider.demo\" and afterwards find the first mention
+of \"::keyword\" there.
+
+Prompt according to prefix ARG and `cider-prompt-for-symbol'.
+A single or double prefix argument inverts the meaning of
+`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes
+the results to be displayed in a different window. The default value is
+thing at point."
+ (interactive "P")
+ (cider-ensure-connected)
+ (let* ((kw (let ((kw-at-point (cider-symbol-at-point 'look-back)))
+ (if (or cider-prompt-for-symbol arg)
+ (read-string
+ (format "Keyword (default %s): " kw-at-point)
+ nil nil kw-at-point)
+ kw-at-point)))
+ (ns-qualifier (and
+ (string-match "^:+\\(.+\\)/.+$" kw)
+ (match-string 1 kw)))
+ (kw-ns (if ns-qualifier
+ (cider-resolve-alias (cider-current-ns) ns-qualifier)
+ (cider-current-ns)))
+ (kw-to-find (concat "::" (replace-regexp-in-string "^:+\\(.+/\\)?" "" kw))))
+
+ (when (and ns-qualifier (string= kw-ns (cider-current-ns)))
+ (error "Could not resolve alias `%s' in `%s'" ns-qualifier (cider-current-ns)))
+ (cider--find-ns kw-ns arg)
+ (search-forward-regexp kw-to-find nil 'noerror)))
+
+(provide 'cider-find)
+;;; cider-find.el ends here
--- /dev/null
+;;; cider-format.el --- Code and EDN formatting functionality -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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 '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 #'cider-sync-request:format-code))
+
+\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 #'cider-sync-request:format-code))
+
+\f
+;;; Format EDN
+
+(declare-function cider--pretty-print-width "cider-repl")
+
+;;;###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 (cider--pretty-print-width)))))
+
+;;;###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 (- (cider--pretty-print-width) 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-grimoire.el --- Grimoire integration -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2018 Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.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 few commands for Grimoire documentation lookup.
+
+;;; Code:
+
+(require 'cider-client)
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-popup)
+
+(require 'nrepl-dict)
+
+(require 'url-vars)
+
+(declare-function markdown-mode "markdown-mode.el")
+(declare-function markdown-toggle-fontify-code-blocks-natively "markdown-mode.el")
+
+(defconst cider-grimoire-url "http://conj.io/")
+
+(defconst cider-grimoire-buffer "*cider-grimoire*")
+
+(defun cider-grimoire-replace-special (name)
+ "Convert the dashes in NAME to a grimoire friendly format."
+ (thread-last name
+ (replace-regexp-in-string "\\?" "_QMARK_")
+ (replace-regexp-in-string "\\." "_DOT_")
+ (replace-regexp-in-string "\\/" "_SLASH_")
+ (replace-regexp-in-string "\\(\\`_\\)\\|\\(_\\'\\)" "")))
+
+(defun cider-grimoire-url (name ns)
+ "Generate a grimoire search v0 url from NAME, NS."
+ (let ((base-url cider-grimoire-url))
+ (when (and name ns)
+ (concat base-url "search/v0/" ns "/" (cider-grimoire-replace-special name) "/"))))
+
+(defun cider-grimoire-web-lookup (symbol)
+ "Open the grimoire documentation for SYMBOL in a web browser."
+ (if-let* ((var-info (cider-var-info symbol)))
+ (let ((name (nrepl-dict-get var-info "name"))
+ (ns (nrepl-dict-get var-info "ns")))
+ (browse-url (cider-grimoire-url name ns)))
+ (error "Symbol %s not resolved" symbol)))
+
+;;;###autoload
+(defun cider-grimoire-web (&optional arg)
+ "Open grimoire 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)
+ "Grimoire doc for"
+ #'cider-grimoire-web-lookup))
+
+(defun cider-create-grimoire-buffer (content)
+ "Create a new grimoire buffer with CONTENT."
+ (with-current-buffer (cider-popup-buffer cider-grimoire-buffer t)
+ (read-only-mode -1)
+ (insert content)
+ (when (require 'markdown-mode nil 'noerror)
+ (markdown-mode)
+ (cider-popup-buffer-mode 1)
+ (when (fboundp 'markdown-toggle-fontify-code-blocks-natively)
+ (markdown-toggle-fontify-code-blocks-natively 1)))
+ (view-mode 1)
+ (goto-char (point-min))
+ (current-buffer)))
+
+(defun cider-grimoire-lookup (symbol)
+ "Look up the grimoire documentation for SYMBOL.
+
+If SYMBOL is a special form, the clojure.core ns is used, as is
+Grimoire's convention."
+ (if-let* ((var-info (cider-var-info symbol)))
+ (let ((name (nrepl-dict-get var-info "name"))
+ (ns (nrepl-dict-get var-info "ns" "clojure.core"))
+ (url-request-method "GET")
+ (url-request-extra-headers `(("Content-Type" . "text/plain"))))
+ (url-retrieve (cider-grimoire-url name ns)
+ (lambda (_status)
+ ;; we need to strip the http header
+ (goto-char (point-min))
+ (re-search-forward "^$")
+ (delete-region (point-min) (point))
+ (delete-blank-lines)
+ ;; and create a new buffer with whatever is left
+ (pop-to-buffer (cider-create-grimoire-buffer (buffer-string))))))
+ (error "Symbol %s not resolved" symbol)))
+
+;;;###autoload
+(defun cider-grimoire (&optional arg)
+ "Open grimoire documentation in a popup buffer.
+
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates."
+ (interactive "P")
+ (when (derived-mode-p 'clojurescript-mode)
+ (user-error "`cider-grimoire' doesn't support ClojureScript"))
+ (funcall (cider-prompt-for-symbol-function arg)
+ "Grimoire doc for"
+ #'cider-grimoire-lookup))
+
+(provide 'cider-grimoire)
+
+;;; cider-grimoire.el ends here
--- /dev/null
+;;; cider-inspector.el --- Object inspector -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2018 Vital Reactor, LLC
+;; Copyright © 2014-2018 Bozhidar Batsov and CIDER contributors
+
+;; Author: Ian Eslick <ianNOSPAMvitalreactor.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.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:
+
+;; Clojure object inspector inspired by SLIME.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'seq)
+(require 'cider-eval)
+
+;; ===================================
+;; Inspector Key Map and Derived Mode
+;; ===================================
+
+(defconst cider-inspector-buffer "*cider-inspect*")
+
+;;; Customization
+(defgroup cider-inspector nil
+ "Presentation and behaviour 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)
+ :group 'cider-inspector
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-inspector-fill-frame nil
+ "Controls whether the cider inspector window fills its frame."
+ :type 'boolean
+ :group 'cider-inspector
+ :package-version '(cider . "0.15.0"))
+
+(defvar cider-inspector-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map cider-popup-buffer-mode-map)
+ (define-key map (kbd "RET") #'cider-inspector-operate-on-point)
+ (define-key map [mouse-1] #'cider-inspector-operate-on-click)
+ (define-key map "l" #'cider-inspector-pop)
+ (define-key map "g" #'cider-inspector-refresh)
+ ;; Page-up/down
+ (define-key map [next] #'cider-inspector-next-page)
+ (define-key map [prior] #'cider-inspector-prev-page)
+ (define-key map " " #'cider-inspector-next-page)
+ (define-key map (kbd "M-SPC") #'cider-inspector-prev-page)
+ (define-key map (kbd "S-SPC") #'cider-inspector-prev-page)
+ (define-key map "s" #'cider-inspector-set-page-size)
+ (define-key map [tab] #'cider-inspector-next-inspectable-object)
+ (define-key map "\C-i" #'cider-inspector-next-inspectable-object)
+ (define-key map [(shift tab)] #'cider-inspector-previous-inspectable-object)
+ ;; Emacs translates S-TAB to BACKTAB on X.
+ (define-key map [backtab] #'cider-inspector-previous-inspectable-object)
+ map))
+
+(define-derived-mode cider-inspector-mode special-mode "Inspector"
+ "Major mode for inspecting Clojure data structures.
+
+\\{cider-inspector-mode-map}"
+ (set-syntax-table clojure-mode-syntax-table)
+ (setq-local electric-indent-chars nil)
+ (setq-local sesman-system 'CIDER)
+ (visual-line-mode 1))
+
+;;;###autoload
+(defun cider-inspect-last-sexp ()
+ "Inspect the result of the the expression preceding point."
+ (interactive)
+ (cider-inspect-expr (cider-last-sexp) (cider-current-ns)))
+
+;;;###autoload
+(defun cider-inspect-defun-at-point ()
+ "Inspect the result of the \"top-level\" expression at point."
+ (interactive)
+ (cider-inspect-expr (cider-defun-at-point) (cider-current-ns)))
+
+;;;###autoload
+(defun cider-inspect-last-result ()
+ "Inspect the most recent eval result."
+ (interactive)
+ (cider-inspect-expr "*1" (cider-current-ns)))
+
+;;;###autoload
+(defun cider-inspect (&optional arg)
+ "Inspect the result of the preceding sexp.
+
+With a prefix argument ARG it inspects the result of the \"top-level\" form.
+With a second prefix argument it prompts for an expression to eval and inspect."
+ (interactive "p")
+ (pcase arg
+ (1 (cider-inspect-last-sexp))
+ (4 (cider-inspect-defun-at-point))
+ (16 (call-interactively #'cider-inspect-expr))))
+
+(defvar cider-inspector-location-stack nil
+ "A stack used to save point locations in inspector buffers.
+These locations are used to emulate `save-excursion' between
+`cider-inspector-push' and `cider-inspector-pop' operations.")
+
+(defvar cider-inspector-page-location-stack nil
+ "A stack used to save point locations in inspector buffers.
+These locations are used to emulate `save-excursion' between
+`cider-inspector-next-page' and `cider-inspector-prev-page' operations.")
+
+(defvar cider-inspector-last-command nil
+ "Contains the value of the most recently used `cider-inspector-*' command.
+This is used as an alternative to the built-in `last-command'. Whenever we
+invoke any command through \\[execute-extended-command] and its variants,
+the value of `last-command' is not set to the command it invokes.")
+
+(defvar cider-inspector--current-repl nil
+ "Contains the reference to the REPL where inspector was last invoked from.
+This is needed for internal inspector buffer operations (push,
+pop) to execute against the correct REPL session.")
+
+;; Operations
+;;;###autoload
+(defun cider-inspect-expr (expr ns)
+ "Evaluate EXPR in NS and inspect its value.
+Interactively, EXPR is read from the minibuffer, and NS the
+current buffer's namespace."
+ (interactive (list (cider-read-from-minibuffer "Inspect expression: " (cider-sexp-at-point))
+ (cider-current-ns)))
+ (setq cider-inspector--current-repl (cider-current-repl))
+ (when-let* ((value (cider-sync-request:inspect-expr expr ns (or cider-inspector-page-size 32))))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-pop ()
+ "Pop the last value off the inspector stack and render it.
+See `cider-sync-request:inspect-pop' and `cider-inspector--render-value'."
+ (interactive)
+ (setq cider-inspector-last-command 'cider-inspector-pop)
+ (when-let* ((value (cider-sync-request:inspect-pop)))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-push (idx)
+ "Inspect the value at IDX in the inspector stack and render it.
+See `cider-sync-request:insepect-push' and `cider-inspector--render-value'"
+ (push (point) cider-inspector-location-stack)
+ (when-let* ((value (cider-sync-request:inspect-push idx)))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-refresh ()
+ "Re-render the currently inspected value.
+See `cider-sync-request:insepect-refresh' and `cider-inspector--render-value'"
+ (interactive)
+ (when-let* ((value (cider-sync-request:inspect-refresh)))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-next-page ()
+ "Jump to the next page when inspecting a paginated sequence/map.
+
+Does nothing if already on the last page."
+ (interactive)
+ (push (point) cider-inspector-page-location-stack)
+ (when-let* ((value (cider-sync-request:inspect-next-page)))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-prev-page ()
+ "Jump to the previous page when expecting a paginated sequence/map.
+
+Does nothing if already on the first page."
+ (interactive)
+ (setq cider-inspector-last-command 'cider-inspector-prev-page)
+ (when-let* ((value (cider-sync-request:inspect-prev-page)))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-set-page-size (page-size)
+ "Set the page size in pagination mode to the specified PAGE-SIZE.
+
+Current page will be reset to zero."
+ (interactive "nPage size: ")
+ (when-let* ((value (cider-sync-request:inspect-set-page-size page-size)))
+ (cider-inspector--render-value value)))
+
+;; nREPL interactions
+(defun cider-sync-request:inspect-pop ()
+ "Move one level up in the inspector stack."
+ (thread-first '("op" "inspect-pop")
+ (cider-nrepl-send-sync-request cider-inspector--current-repl)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-push (idx)
+ "Inspect the inside value specified by IDX."
+ (thread-first `("op" "inspect-push"
+ "idx" ,idx)
+ (cider-nrepl-send-sync-request cider-inspector--current-repl)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-refresh ()
+ "Re-render the currently inspected value."
+ (thread-first '("op" "inspect-refresh")
+ (cider-nrepl-send-sync-request cider-inspector--current-repl)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-next-page ()
+ "Jump to the next page in paginated collection view."
+ (thread-first '("op" "inspect-next-page")
+ (cider-nrepl-send-sync-request cider-inspector--current-repl)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-prev-page ()
+ "Jump to the previous page in paginated collection view."
+ (thread-first '("op" "inspect-prev-page")
+ (cider-nrepl-send-sync-request cider-inspector--current-repl)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-set-page-size (page-size)
+ "Set the page size in paginated view to PAGE-SIZE."
+ (thread-first `("op" "inspect-set-page-size"
+ "page-size" ,page-size)
+ (cider-nrepl-send-sync-request cider-inspector--current-repl)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-expr (expr ns page-size)
+ "Evaluate EXPR in context of NS and inspect its result.
+Set the page size in paginated view to PAGE-SIZE."
+ (thread-first (append (nrepl--eval-request expr ns)
+ `("inspect" "true"
+ "page-size" ,page-size))
+ (cider-nrepl-send-sync-request cider-inspector--current-repl)
+ (nrepl-dict-get "value")))
+
+;; Render Inspector from Structured Values
+(defun cider-inspector--render-value (value)
+ "Render VALUE."
+ (cider-make-popup-buffer cider-inspector-buffer 'cider-inspector-mode 'ancillary)
+ (cider-inspector-render cider-inspector-buffer value)
+ (cider-popup-buffer-display cider-inspector-buffer t)
+ (when cider-inspector-fill-frame (delete-other-windows))
+ (with-current-buffer cider-inspector-buffer
+ (when (eq cider-inspector-last-command 'cider-inspector-pop)
+ (setq cider-inspector-last-command nil)
+ ;; Prevents error message being displayed when we try to pop
+ ;; from the top-level of a data struture
+ (when cider-inspector-location-stack
+ (goto-char (pop cider-inspector-location-stack))))
+
+ (when (eq cider-inspector-last-command 'cider-inspector-prev-page)
+ (setq cider-inspector-last-command nil)
+ ;; Prevents error message being displayed when we try to
+ ;; go to a prev-page from the first page
+ (when cider-inspector-page-location-stack
+ (goto-char (pop cider-inspector-page-location-stack))))))
+
+(defun cider-inspector-render (buffer str)
+ "Render STR in BUFFER."
+ (with-current-buffer buffer
+ (cider-inspector-mode)
+ (let ((inhibit-read-only t))
+ (condition-case nil
+ (cider-inspector-render* (car (read-from-string str)))
+ (error (insert "\nInspector error for: " str))))
+ (goto-char (point-min))))
+
+(defun cider-inspector-render* (elements)
+ "Render ELEMENTS."
+ (dolist (el elements)
+ (cider-inspector-render-el* el)))
+
+(defun cider-inspector-render-el* (el)
+ "Render EL."
+ (cond ((symbolp el) (insert (symbol-name el)))
+ ((stringp el) (insert (propertize el 'font-lock-face 'font-lock-keyword-face)))
+ ((and (consp el) (eq (car el) :newline))
+ (insert "\n"))
+ ((and (consp el) (eq (car el) :value))
+ (cider-inspector-render-value (cadr el) (cl-caddr el)))
+ (t (message "Unrecognized inspector object: %s" el))))
+
+(defun cider-inspector-render-value (value idx)
+ "Render VALUE at IDX."
+ (cider-propertize-region
+ (list 'cider-value-idx idx
+ 'mouse-face 'highlight)
+ (cider-inspector-render-el* (cider-font-lock-as-clojure value))))
+
+
+;; ===================================================
+;; Inspector Navigation (lifted from SLIME inspector)
+;; ===================================================
+
+(defun cider-find-inspectable-object (direction limit)
+ "Find the next/previous inspectable object.
+DIRECTION can be either 'next or 'prev.
+LIMIT is the maximum or minimum position in the current buffer.
+
+Return a list of two values: If an object could be found, the
+starting position of the found object and T is returned;
+otherwise LIMIT and NIL is returned."
+ (let ((finder (cl-ecase direction
+ (next 'next-single-property-change)
+ (prev 'previous-single-property-change))))
+ (let ((prop nil) (curpos (point)))
+ (while (and (not prop) (not (= curpos limit)))
+ (let ((newpos (funcall finder curpos 'cider-value-idx nil limit)))
+ (setq prop (get-text-property newpos 'cider-value-idx))
+ (setq curpos newpos)))
+ (list curpos (and prop t)))))
+
+(defun cider-inspector-next-inspectable-object (arg)
+ "Move point to the next inspectable object.
+With optional ARG, move across that many objects.
+If ARG is negative, move backwards."
+ (interactive "p")
+ (let ((maxpos (point-max)) (minpos (point-min))
+ (previously-wrapped-p nil))
+ ;; Forward.
+ (while (> arg 0)
+ (seq-let (pos foundp) (cider-find-inspectable-object 'next maxpos)
+ (if foundp
+ (progn (goto-char pos) (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) (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 (1- (point))))))
+
+(defun cider-inspector-operate-on-point ()
+ "Invoke the command for the text at point.
+1. If point is on a value then recursively call the inspector on
+that value.
+2. If point is on an action then call that action.
+3. If point is on a range-button fetch and insert the range."
+ (interactive)
+ (seq-let (property value) (cider-inspector-property-at-point)
+ (cl-case property
+ (cider-value-idx
+ (cider-inspector-push value))
+ ;; TODO: range and action handlers
+ (t (error "No object at point")))))
+
+(defun cider-inspector-operate-on-click (event)
+ "Move to EVENT's position and operate the part."
+ (interactive "@e")
+ (let ((point (posn-point (event-end event))))
+ (cond ((and point
+ (or (get-text-property point 'cider-value-idx)))
+ (goto-char point)
+ (cider-inspector-operate-on-point))
+ (t
+ (error "No clickable part here")))))
+
+(provide 'cider-inspector)
+
+;;; cider-inspector.el ends here
--- /dev/null
+;;; cider-macroexpansion.el --- Macro expansion support -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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)
+(require 'cider-compat)
+
+(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-refered vars from other
+ namespaces are refered using the alias for that namespace (if
+ defined), other vars are displayed fully qualified."
+ :type '(choice (const :tag "Suppress namespaces" none)
+ (const :tag "Show fully-qualified namespaces" qualified)
+ (const :tag "Show namespace aliases" tidy))
+ :group 'cider
+ :package-version '(cider . "0.7.0"))
+
+(defcustom cider-macroexpansion-print-metadata nil
+ "Determines if metadata is included in macroexpansion results."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defun cider-sync-request:macroexpand (expander expr &optional display-namespaces)
+ "Macroexpand, using EXPANDER, the given EXPR.
+The default for DISPLAY-NAMESPACES is taken from
+`cider-macroexpansion-display-namespaces'."
+ (cider-ensure-op-supported "macroexpand")
+ (thread-first `("op" "macroexpand"
+ "expander" ,expander
+ "code" ,expr
+ "ns" ,(cider-current-ns)
+ "display-namespaces" ,(or display-namespaces
+ (symbol-name cider-macroexpansion-display-namespaces)))
+ (nconc (when cider-macroexpansion-print-metadata
+ '("print-meta" "true")))
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "expansion")))
+
+(defun cider-macroexpand-undo (&optional arg)
+ "Undo the last macroexpansion, using `undo-only'.
+ARG is passed along to `undo-only'."
+ (interactive)
+ (let ((inhibit-read-only t))
+ (undo-only arg)))
+
+(defvar cider-last-macroexpand-expression nil
+ "Specify the last macroexpansion preformed.
+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))
+ (cider--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.
+
+\\{cider-macroexpansion-mode-map}"
+ nil
+ " Macroexpand"
+ cider-macroexpansion-mode-map)
+
+(provide 'cider-macroexpansion)
+
+;;; cider-macroexpansion.el ends here
--- /dev/null
+;;; cider-mode.el --- Minor mode for REPL interactions -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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 'subr-x)
+(require 'cider-compat)
+
+(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
+ cider-repl-type
+ (when cider-mode-line-show-connection
+ (format ":%s@%s:%s"
+ (or (cider--project-name nrepl-project-dir) "<no project>")
+ (pcase (car nrepl-endpoint)
+ ("localhost" "")
+ (x x))
+ (cadr nrepl-endpoint)))))
+ "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 `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 (equal type "multi")
+ (equal 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))
+ (if clear-repl
+ (cider-repl-clear-buffer)
+ (cider-repl-clear-output))
+ (switch-to-buffer origin-buffer)))
+
+(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)
+ "symbol" ,sym)
+ (cider-interactive-eval-handler (current-buffer))))))
+
+;;; cider-run
+(defvar cider--namespace-history nil
+ "History of user input for namespace prompts.")
+
+(defun cider--var-namespace (var)
+ "Return the namespace of VAR.
+VAR is a fully qualified Clojure variable name as a string."
+ (replace-regexp-in-string "\\(?:#'\\)?\\(.*\\)/.*" "\\1" var))
+
+(defun cider-run (&optional function)
+ "Run -main or FUNCTION, prompting for its namespace if necessary.
+With a prefix argument, prompt for function to run instead of -main."
+ (interactive (list (when current-prefix-arg (read-string "Function name: "))))
+ (cider-ensure-connected)
+ (let ((name (or function "-main")))
+ (when-let* ((response (cider-nrepl-send-sync-request
+ `("op" "ns-list-vars-by-name"
+ "name" ,name))))
+ (if-let* ((vars (split-string (substring (nrepl-dict-get response "var-list") 1 -1))))
+ (cider-interactive-eval
+ (if (= (length vars) 1)
+ (concat "(" (car vars) ")")
+ (let* ((completions (mapcar #'cider--var-namespace vars))
+ (def (or (car cider--namespace-history)
+ (car completions))))
+ (format "(#'%s/%s)"
+ (completing-read (format "Namespace (%s): " def)
+ completions nil t nil
+ 'cider--namespace-history def)
+ name))))
+ (user-error "No %s var defined in any namespace" (cider-propertize name 'fn))))))
+
+;;; Insert (and eval) in REPL functionality
+(defvar cider-insert-commands-map
+ (let ((map (define-prefix-command 'cider-insert-commands-map)))
+ ;; single key bindings defined last for display in menu
+ (define-key map (kbd "e") #'cider-insert-last-sexp-in-repl)
+ (define-key map (kbd "d") #'cider-insert-defun-in-repl)
+ (define-key map (kbd "r") #'cider-insert-region-in-repl)
+ (define-key map (kbd "n") #'cider-insert-ns-form-in-repl)
+
+ ;; duplicates with C- for convenience
+ (define-key map (kbd "C-e") #'cider-insert-last-sexp-in-repl)
+ (define-key map (kbd "C-d") #'cider-insert-defun-in-repl)
+ (define-key map (kbd "C-r") #'cider-insert-region-in-repl)
+ (define-key map (kbd "C-n") #'cider-insert-ns-form-in-repl)))
+
+(defcustom cider-switch-to-repl-after-insert-p t
+ "Whether to switch to the repl after inserting a form into the repl."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "0.18.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."
+ (while (string-match "\\`[ \t\n\r]+\\|[ \t\n\r]+\\'" form)
+ (setq form (replace-match "" t t form)))
+ (with-current-buffer (cider-current-repl)
+ (goto-char (point-max))
+ (let ((beg (point)))
+ (insert form)
+ (indent-region beg (point)))
+ (when (if cider-invert-insert-eval-p
+ (not eval)
+ eval)
+ (cider-repl-return)))
+ (when cider-switch-to-repl-after-insert-p
+ (cider-switch-to-repl-buffer)))
+
+(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 curent 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 manual online" cider-view-manual]
+ ["View refcard online" 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)
+ ["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 sexp" cider-eval-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 last sexp in context" cider-eval-last-sexp-in-context]
+ ["Eval last sexp and insert" cider-eval-print-last-sexp
+ :keys "\\[universal-argument] \\[cider-eval-last-sexp]"]
+ ["Eval last sexp in popup buffer" cider-pprint-eval-last-sexp]
+ ["Eval last sexp and replace" cider-eval-last-sexp-and-replace]
+ ["Eval last sexp to REPL" cider-eval-last-sexp-to-repl]
+ ["Eval last sexp and pretty-print to REPL" cider-pprint-eval-last-sexp-to-repl]
+ ["Eval last sexp and pretty-print to comment" cider-pprint-eval-last-sexp-to-comment]
+ "--"
+ ["Eval selected region" cider-eval-region]
+ ["Eval ns form" cider-eval-ns-form]
+ "--"
+ ["Interrupt evaluation" cider-interrupt]
+ "--"
+ ["Insert last sexp in REPL" cider-insert-last-sexp-in-repl]
+ ["Insert 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])
+ ("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")
+
+(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>.")
+
+(defconst cider-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c C-d") 'cider-doc-map)
+ (define-key map (kbd "M-.") #'cider-find-var)
+ (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 "M-,") #'cider-pop-back)
+ (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") #'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-q") #'cider-quit)
+ (define-key map (kbd "C-c M-r") #'cider-restart)
+ (dolist (variable '(cider-mode-interactions-menu
+ cider-mode-eval-menu
+ cider-mode-menu))
+ (easy-menu-do-define (intern (format "%s-open" variable))
+ map
+ (get variable 'variable-documentation)
+ (cider--menu-add-help-strings (symbol-value variable))))
+ map))
+
+;; This menu works as an easy entry-point into CIDER. Even if cider.el isn't
+;; loaded yet, this will be shown in Clojure buffers next to the "Clojure"
+;; menu.
+;;;###autoload
+(with-eval-after-load 'clojure-mode
+ (easy-menu-define cider-clojure-mode-menu-open clojure-mode-map
+ "Menu for Clojure mode.
+ This is displayed in `clojure-mode' buffers, if `cider-mode' is not active."
+ `("CIDER" :visible (not cider-mode)
+ ["Start a Clojure REPL" cider-jack-in-clj
+ :help "Starts an nREPL server and connects a Clojure REPL to it."]
+ ["Connect to a Clojure REPL" cider-connect-clj
+ :help "Connects to a REPL that's already running."]
+ ["Start a ClojureScript REPL" cider-jack-in-cljs
+ :help "Starts an nREPL server and connects a ClojureScript REPL to it."]
+ ["Connect to a ClojureScript REPL" cider-connect-cljs
+ :help "Connects to a ClojureScript REPL that's already running."]
+ ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clj&cljs
+ :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL."]
+ "--"
+ ["View manual online" cider-view-manual])))
+
+;;; Dynamic indentation
+(defcustom cider-dynamic-indentation t
+ "Whether CIDER should aid Clojure(Script) indentation.
+If non-nil, CIDER uses runtime information (such as the \":style/indent\"
+metadata) to improve standard `clojure-mode' indentation.
+If nil, CIDER won't interfere with `clojure-mode's indentation.
+
+Toggling this variable only takes effect after a file is closed and
+re-visited."
+ :type 'boolean
+ :package-version '(cider . "0.11.0")
+ :group 'cider)
+
+(defun cider--get-symbol-indent (symbol-name)
+ "Return the indent metadata for SYMBOL-NAME in the current namespace."
+ (let* ((ns (let ((clojure-cache-ns t)) ; we force ns caching here for performance reasons
+ (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 (face depends on type).
+
+The value can also be t, which means to font-lock as much as possible."
+ :type '(choice (set :tag "Fine-tune font-locking"
+ (const :tag "Any defined macro" macro)
+ (const :tag "Any defined function" function)
+ (const :tag "Any defined var" var)
+ (const :tag "Any defined deprecated" deprecated)
+ (const :tag "Any symbol from clojure.core" core))
+ (const :tag "Font-lock as much as possible" t))
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-font-lock-reader-conditionals t
+ "Apply font-locking to unused reader conditional expressions depending 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 #'cider-repl-type (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 the symbols in SYMBOLS-PLIST and CORE-PLIST."
+ (let ((cider-font-lock-dynamically (if (eq cider-font-lock-dynamically t)
+ '(function var macro core deprecated)
+ cider-font-lock-dynamically))
+ deprecated enlightened
+ macros functions vars instrumented traced)
+ (cl-labels ((handle-plist
+ (plist)
+ (let ((do-function (memq 'function cider-font-lock-dynamically))
+ (do-var (memq 'var cider-font-lock-dynamically))
+ (do-macro (memq 'macro cider-font-lock-dynamically))
+ (do-deprecated (memq 'deprecated cider-font-lock-dynamically)))
+ (while plist
+ (let ((sym (pop plist))
+ (meta (pop plist)))
+ (pcase (nrepl-dict-get meta "cider/instrumented")
+ (`nil nil)
+ (`"\"breakpoint-if-interesting\""
+ (push sym instrumented))
+ (`"\"light-form\""
+ (push sym enlightened)))
+ ;; The ::traced keywords can be inlined by MrAnderson, so
+ ;; we catch that case too.
+ ;; FIXME: This matches values too, not just keys.
+ (when (seq-find (lambda (k) (and (stringp k)
+ (string-match (rx "clojure.tools.trace/traced" eos) k)))
+ meta)
+ (push sym traced))
+ (when (and do-deprecated (nrepl-dict-get meta "deprecated"))
+ (push sym deprecated))
+ (cond ((and do-macro (nrepl-dict-get meta "macro"))
+ (push sym macros))
+ ((and do-function (or (nrepl-dict-get meta "fn")
+ (nrepl-dict-get meta "arglists")))
+ (push sym functions))
+ (do-var (push sym vars))))))))
+ (when (memq 'core cider-font-lock-dynamically)
+ (let ((cider-font-lock-dynamically '(function var macro core deprecated)))
+ (handle-plist core-plist)))
+ (handle-plist symbols-plist))
+ `(
+ ,@(when macros
+ `((,(concat (rx (or "(" "#'")) ; Can't take the value of macros.
+ "\\(" (regexp-opt macros 'symbols) "\\)")
+ 1 (cider--unless-local-match font-lock-keyword-face))))
+ ,@(when functions
+ `((,(regexp-opt functions 'symbols) 0
+ (cider--unless-local-match font-lock-function-name-face))))
+ ,@(when vars
+ `((,(regexp-opt vars 'symbols) 0
+ (cider--unless-local-match font-lock-variable-name-face))))
+ ,@(when deprecated
+ `((,(regexp-opt deprecated 'symbols) 0
+ (cider--unless-local-match 'cider-deprecated-face) append)))
+ ,@(when enlightened
+ `((,(regexp-opt enlightened 'symbols) 0
+ (cider--unless-local-match 'cider-enlightened-face) append)))
+ ,@(when instrumented
+ `((,(regexp-opt instrumented 'symbols) 0
+ (cider--unless-local-match 'cider-instrumented-face) append)))
+ ,@(when traced
+ `((,(regexp-opt traced 'symbols) 0
+ (cider--unless-local-match 'cider-traced-face) append))))))
+
+(defconst cider--static-font-lock-keywords
+ (eval-when-compile
+ `((,(regexp-opt '("#break" "#dbg" "#light") 'symbols) 0 font-lock-warning-face)))
+ "Default expressions to highlight in CIDER mode.")
+
+(defvar-local cider--dynamic-font-lock-keywords nil)
+
+(defun cider-refresh-dynamic-font-lock (&optional ns)
+ "Ensure that the current buffer has up-to-date font-lock rules.
+NS defaults to `cider-current-ns', and it can also be a dict describing the
+namespace itself."
+ (interactive)
+ (when (and cider-font-lock-dynamically
+ font-lock-mode)
+ (font-lock-remove-keywords nil cider--dynamic-font-lock-keywords)
+ (when-let* ((ns (or ns (cider-current-ns)))
+ (symbols (cider-resolve-ns-symbols ns)))
+ (setq-local cider--dynamic-font-lock-keywords
+ (cider--compile-font-lock-keywords
+ symbols (cider-resolve-ns-symbols (cider-resolve-core-ns))))
+ (font-lock-add-keywords nil cider--dynamic-font-lock-keywords 'end))
+ (cider--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)))
+ (save-excursion
+ ;; Move up until we reach a sexp that encloses the entire region (or
+ ;; a top-level sexp), and set that as the new BEG.
+ (goto-char end)
+ (while (and (or (> (point) beg)
+ (not (eq (char-after) ?\()))
+ (condition-case nil
+ (progn (backward-up-list) t)
+ (scan-error nil))))
+ (setq beg (min beg (point)))
+ ;; If there are locals above the current sexp, reapply them to the
+ ;; current sexp.
+ (let ((locals-above (when (> beg (point-min))
+ (get-text-property (1- beg) 'cider-locals))))
+ (condition-case nil
+ (clojure-forward-logical-sexp 1)
+ (error (goto-char end)))
+ (add-text-properties beg (point) `(cider-locals ,locals-above))
+ ;; Extend the region being font-locked to include whole sexps.
+ (setq end (max end (point)))
+ (goto-char beg)
+ (ignore-errors
+ (cider--parse-and-apply-locals end locals-above))))))
+
+(defun cider--docview-as-string (sym info)
+ "Return a string of what would be displayed by `cider-docview-render'.
+SYM and INFO is passed to `cider-docview-render'"
+ (with-temp-buffer
+ (cider-docview-render (current-buffer) sym info)
+ (goto-char (point-max))
+ (forward-line -1)
+ (replace-regexp-in-string
+ "[`']" "\\\\=\\&"
+ (buffer-substring-no-properties (point-min) (1- (point))))))
+
+(defcustom cider-use-tooltips t
+ "If non-nil, CIDER displays mouse-over tooltips."
+ :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 help-at-pt-display-when-idle))
+ (with-current-buffer obj
+ (ignore-errors
+ (save-excursion
+ (goto-char pos)
+ (when-let* ((sym (cider-symbol-at-point)))
+ (if (member sym (get-text-property (point) 'cider-locals))
+ (concat (format "`%s' is a local" sym)
+ (when cider--debug-mode
+ (let* ((locals (nrepl-dict-get cider--debug-mode-response "locals"))
+ (local-val (cadr (assoc sym locals))))
+ (format " with value:\n%s" local-val))))
+ (let* ((info (cider-sync-request:info sym))
+ (candidates (nrepl-dict-get info "candidates")))
+ (if candidates
+ (concat "There were ambiguities resolving this symbol:\n\n"
+ (mapconcat (lambda (x) (cider--docview-as-string sym x))
+ candidates
+ (concat "\n\n" (make-string 60 ?-) "\n\n")))
+ (cider--docview-as-string sym info)))))))))))
+
+(defun cider--wrap-fontify-locals (func)
+ "Return a function that will call FUNC after parsing local variables.
+The local variables are stored in a list under the `cider-locals' text
+property."
+ (lambda (beg end &rest rest)
+ (with-silent-modifications
+ (remove-text-properties beg end '(cider-locals nil cider-block-dynamic-font-lock nil))
+ (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
+(defvar x-gtk-use-system-tooltips)
+
+;;;###autoload
+(define-minor-mode cider-mode
+ "Minor mode for REPL interaction from a Clojure buffer.
+
+\\{cider-mode-map}"
+ nil
+ cider-mode-line
+ cider-mode-map
+ (if cider-mode
+ (progn
+ (setq-local sesman-system 'CIDER)
+ (cider-eldoc-setup)
+ (make-local-variable 'completion-at-point-functions)
+ (add-to-list 'completion-at-point-functions
+ #'cider-complete-at-point)
+ (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)
+ (setq next-error-function #'cider-jump-to-compilation-error))
+ (mapc #'kill-local-variable '(completion-at-point-functions
+ next-error-function
+ x-gtk-use-system-tooltips
+ font-lock-fontify-region-function
+ clojure-get-indent-function))
+ (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)
+ (cider--font-lock-flush)))
+
+(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-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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 'subr-x)
+
+(require 'cider-client)
+(require 'cider-popup)
+(require 'cider-stacktrace)
+
+(define-obsolete-variable-alias 'cider-save-files-on-cider-ns-refresh 'cider-ns-save-files-on-refresh "0.18")
+(defcustom cider-ns-save-files-on-refresh 'prompt
+ "Controls whether to prompt to save Clojure files on `cider-ns-refresh'.
+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"))
+
+(defconst cider-ns-refresh-log-buffer "*cider-ns-refresh-log*")
+
+(define-obsolete-variable-alias 'cider-refresh-show-log-buffer 'cider-ns-refresh-show-log-buffer "0.18")
+(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"))
+
+(define-obsolete-variable-alias 'cider-refresh-before-fn 'cider-ns-refresh-before-fn "0.18")
+(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"))
+
+(define-obsolete-variable-alias 'cider-refresh-after-fn 'cider-ns-refresh-after-fn "0.18")
+(defcustom cider-ns-refresh-after-fn nil
+ "Clojure function for `cider-ns-refresh' to call after reloading.
+If nil, nothing will be invoked after reloading. Must be a
+namespace-qualified function of zero arity."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defun cider-ns-refresh--handle-response (response log-buffer)
+ "Refresh LOG-BUFFER with RESPONSE."
+ (nrepl-dbind-response response (out err reloading status error error-ns after before)
+ (cl-flet* ((log (message &optional face)
+ (cider-emit-into-popup-buffer log-buffer message face t))
+
+ (log-echo (message &optional face)
+ (log message face)
+ (unless cider-ns-refresh-show-log-buffer
+ (let ((message-truncate-lines t))
+ (message "cider-ns-refresh: %s" message)))))
+ (cond
+ (out
+ (log out))
+
+ (err
+ (log err 'font-lock-warning-face))
+
+ ((member "invoking-before" status)
+ (log-echo (format "Calling %s\n" before) 'font-lock-string-face))
+
+ ((member "invoked-before" status)
+ (log-echo (format "Successfully called %s\n" before) 'font-lock-string-face))
+
+ ((member "invoked-not-resolved" status)
+ (log-echo "Could not resolve refresh function\n" 'font-lock-string-face))
+
+ (reloading
+ (log-echo (format "Reloading %s\n" reloading) 'font-lock-string-face))
+
+ ((member "reloading" (nrepl-dict-keys response))
+ (log-echo "Nothing to reload\n" 'font-lock-string-face))
+
+ ((member "ok" status)
+ (log-echo "Reloading successful\n" 'font-lock-string-face))
+
+ (error-ns
+ (log-echo (format "Error reloading %s\n" error-ns) 'font-lock-warning-face))
+
+ ((member "invoking-after" status)
+ (log-echo (format "Calling %s\n" after) 'font-lock-string-face))
+
+ ((member "invoked-after" status)
+ (log-echo (format "Successfully called %s\n" after) 'font-lock-string-face))))
+
+ (with-selected-window (or (get-buffer-window cider-ns-refresh-log-buffer)
+ (selected-window))
+ (with-current-buffer cider-ns-refresh-log-buffer
+ (goto-char (point-max))))
+
+ (when (member "error" status)
+ (cider--render-stacktrace-causes error))))
+
+(defun cider-ns-refresh--save-project-buffers ()
+ "Ensure modified project buffers are saved before certain operations.
+Its behavior is controlled by `cider-save-files-on-cider-ns-refresh'."
+ (when-let* ((project-root (clojure-project-dir)))
+ (when cider-save-files-on-cider-ns-refresh
+ (save-some-buffers
+ (eq cider-save-files-on-cider-ns-refresh t)
+ (lambda ()
+ (and
+ (derived-mode-p 'clojure-mode)
+ (string-prefix-p project-root
+ (file-truename default-directory)
+ (eq system-type 'windows-nt))))))))
+
+;;;###autoload
+(defun cider-ns-reload (&optional prompt)
+ "Send a (require 'ns :reload) to the REPL.
+
+With an argument PROMPT, it prompts for a namespace name. This is the
+Clojure out of the box reloading experience and does not rely on
+org.clojure/tools.namespace. See Commentary of this file for a longer list
+of differences. From the Clojure doc: \":reload forces loading of all the
+identified libs even if they are already loaded\"."
+ (interactive "P")
+ (let ((ns (if prompt
+ (string-remove-prefix "'" (read-from-minibuffer "Namespace: " (clojure-find-ns)))
+ (clojure-find-ns))))
+ (cider-interactive-eval (format "(require '%s :reload)" ns))))
+
+;;;###autoload
+(defun cider-ns-reload-all (&optional prompt)
+ "Send a (require 'ns :reload-all) to the REPL.
+
+With an argument PROMPT, it prompts for a namespace name. This is the
+Clojure out of the box reloading experience and does not rely on
+org.clojure/tools.namespace. See Commentary of this file for a longer list
+of differences. From the Clojure doc: \":reload-all implies :reload and
+also forces loading of all libs that the identified libs directly or
+indirectly load via require\"."
+ (interactive "P")
+ (let ((ns (if prompt
+ (string-remove-prefix "'" (read-from-minibuffer "Namespace: " (clojure-find-ns)))
+ (clojure-find-ns))))
+ (cider-interactive-eval (format "(require '%s :reload-all)" ns))))
+
+;;;###autoload
+(defun cider-ns-refresh (&optional mode)
+ "Reload modified and unloaded namespaces on the classpath.
+
+With a single prefix argument, or if MODE is `refresh-all', reload all
+namespaces on the classpath unconditionally.
+
+With a double prefix argument, or if MODE is `clear', clear the state of
+the namespace tracker before reloading. This is useful for recovering from
+some classes of error (for example, those caused by circular dependencies)
+that a normal reload would not otherwise recover from. The trade-off of
+clearing is that stale code from any deleted files may not be completely
+unloaded.
+
+With a negative prefix argument, or if MODE is `inhibit-fns', prevent any
+refresh functions (defined in `cider-ns-refresh-before-fn' and
+`cider-ns-refresh-after-fn') from being invoked."
+ (interactive "p")
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "refresh")
+ (cider-ns-refresh--save-project-buffers)
+ (let ((clear? (member mode '(clear 16)))
+ (refresh-all? (member mode '(refresh-all 4)))
+ (inhibit-refresh-fns (member mode '(inhibit-fns -1))))
+ (cider-map-repls :clj
+ (lambda (conn)
+ ;; Inside the lambda, so the buffer is not created if we error out.
+ (let ((log-buffer (or (get-buffer cider-ns-refresh-log-buffer)
+ (cider-make-popup-buffer cider-ns-refresh-log-buffer))))
+ (when cider-ns-refresh-show-log-buffer
+ (cider-popup-buffer-display log-buffer))
+ (when inhibit-refresh-fns
+ (cider-emit-into-popup-buffer log-buffer
+ "inhibiting refresh functions\n"
+ nil
+ t))
+ (when clear?
+ (cider-nrepl-send-sync-request '("op" "refresh-clear") conn))
+ (cider-nrepl-send-request
+ (nconc `("op" ,(if refresh-all? "refresh-all" "refresh")
+ "print-length" ,cider-stacktrace-print-length
+ "print-level" ,cider-stacktrace-print-level)
+ (when (cider--pprint-fn)
+ `("pprint-fn" ,(cider--pprint-fn)))
+ (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))))))
+
+;;;###autoload
+(define-obsolete-function-alias 'cider-refresh 'cider-ns-refresh "0.18")
+
+(provide 'cider-ns)
+;;; cider-ns.el ends here
--- /dev/null
+;;; cider-overlays.el --- Managing CIDER overlays -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2018 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 'cider-compat)
+(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"))
+
+(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. 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 "End of line" t)
+ (const :tag "Bottom of screen" nil)
+ (const :tag "Both" both))
+ :group 'cider
+ :package-version '(cider . "0.10.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.
+Also see `cider-use-overlays'."
+ :type '(choice (integer :tag "Duration in seconds")
+ (const :tag "Until next command" command)
+ (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 ()
+ "Remove result overlay from current buffer.
+This function also removes itself from `post-command-hook'."
+ (remove-hook 'post-command-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 end of line.
+VALUE is used as the overlay's after-string property, meaning it is
+displayed at the end of the overlay. The overlay itself is placed from
+beginning to end of current line.
+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 over
+ the entire line at that place (defaulting to `point'). 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)
+ (line-end-position)))
+ (display-string (format format value))
+ (o nil))
+ (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
+ ;; 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))))
+ (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 &optional point)
+ "Display the result VALUE of an interactive eval operation.
+VALUE is syntax-highlighted and displayed in the echo area.
+If POINT and `cider-use-overlays' are non-nil, it is also displayed in an
+overlay at the end of the line containing POINT.
+Note that, while POINT can be a number, it's preferable to be a marker, as
+that will better handle some corner cases where the original buffer is not
+focused."
+ (let* ((font-value (if cider-result-use-clojure-font-lock
+ (cider-font-lock-as-clojure value)
+ value))
+ (used-overlay (when (and point cider-use-overlays)
+ (cider--make-result-overlay font-value
+ :where point
+ :duration cider-eval-result-duration))))
+ (message
+ "%s"
+ (propertize (format "%s%s" cider-eval-result-prefix font-value)
+ ;; The following hides the message from the echo-area, but
+ ;; displays it in the Messages buffer. We only hide the message
+ ;; if the user wants to AND if the overlay succeeded.
+ 'invisible (and used-overlay
+ (not (eq cider-use-overlays 'both)))))))
+
+\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
+(define-package "cider" "20181110.1413" "Clojure Interactive Development Environment that Rocks"
+ '((emacs "25")
+ (clojure-mode "5.9")
+ (pkg-info "0.4")
+ (queue "0.2")
+ (spinner "1.7")
+ (seq "2.16")
+ (sesman "0.3.2"))
+ :keywords
+ '("languages" "clojure" "cider")
+ :authors
+ '(("Tim King" . "kingtimNOSPAMgmail.com")
+ ("Phil Hagelberg" . "technomancyNOSPAMgmail.com")
+ ("Bozhidar Batsov" . "bozhidarNOSPAMbatsov.com")
+ ("Artur Malabarba" . "bruce.connor.amNOSPAMgmail.com")
+ ("Hugo Duncan" . "hugoNOSPAMhugoduncan.org")
+ ("Steve Purcell" . "steveNOSPAMsanityinc.com"))
+ :maintainer
+ '("Bozhidar Batsov" . "bozhidarNOSPAMbatsov.com")
+ :url "http://www.github.com/clojure-emacs/cider")
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
--- /dev/null
+;;; cider-popup.el --- Creating and quitting popup buffers -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2018 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)
+(require 'cider-compat)
+
+(define-minor-mode cider-popup-buffer-mode
+ "Mode for CIDER popup buffers"
+ nil
+ (" cider-tmp")
+ '(("q" . cider-popup-buffer-quit-function)))
+
+(defvar-local cider-popup-buffer-quit-function #'cider-popup-buffer-quit
+ "The function that is used to quit a temporary popup buffer.")
+
+(defun cider-popup-buffer-quit-function (&optional kill-buffer-p)
+ "Wrapper to invoke the function `cider-popup-buffer-quit-function'.
+KILL-BUFFER-P is passed along."
+ (interactive)
+ (funcall cider-popup-buffer-quit-function kill-buffer-p))
+
+(defun cider-popup-buffer (name &optional select mode ancillary)
+ "Create new popup buffer called NAME.
+If SELECT is non-nil, select the newly created window.
+If major MODE is non-nil, enable it for the popup buffer.
+If ANCILLARY is non-nil, the buffer is added to `cider-ancillary-buffers'
+and automatically removed when killed."
+ (thread-first (cider-make-popup-buffer name mode ancillary)
+ (cider-popup-buffer-display select)))
+
+(defun cider-popup-buffer-display (buffer &optional select)
+ "Display BUFFER.
+If SELECT is non-nil, select the BUFFER."
+ (let ((window (get-buffer-window buffer 'visible)))
+ (when window
+ (with-current-buffer buffer
+ (set-window-point window (point))))
+ ;; If the buffer we are popping up is already displayed in the selected
+ ;; window, the below `inhibit-same-window' logic will cause it to be
+ ;; displayed twice - so we early out in this case. Note that we must check
+ ;; `selected-window', as async request handlers are executed in the context
+ ;; of the current connection buffer (i.e. `current-buffer' is dynamically
+ ;; bound to that).
+ (unless (eq window (selected-window))
+ ;; Non nil `inhibit-same-window' ensures that current window is not covered
+ ;; Non nil `inhibit-switch-frame' ensures that the other frame is not selected
+ ;; if that's where the buffer is being shown.
+ (funcall (if select #'pop-to-buffer #'display-buffer)
+ buffer `(nil . ((inhibit-same-window . ,pop-up-windows)
+ (reusable-frames . visible))))))
+ buffer)
+
+(defun cider-popup-buffer-quit (&optional kill)
+ "Quit the current (temp) window.
+Bury its buffer using `quit-restore-window'.
+If prefix argument KILL is non-nil, kill the buffer instead of burying it."
+ (interactive)
+ (quit-restore-window (selected-window) (if kill 'kill 'append)))
+
+(defvar-local cider-popup-output-marker nil)
+
+(defvar cider-ancillary-buffers nil
+ "A list ancillary buffers created by the various CIDER commands.
+We track them mostly to be able to clean them up on quit.")
+
+(defun cider-make-popup-buffer (name &optional mode ancillary)
+ "Create a temporary buffer called NAME using major MODE (if specified).
+If ANCILLARY is non-nil, the buffer is added to `cider-ancillary-buffers'
+and automatically removed when killed."
+ (with-current-buffer (get-buffer-create name)
+ (kill-all-local-variables)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (when mode
+ (funcall mode))
+ (cider-popup-buffer-mode 1)
+ (setq cider-popup-output-marker (point-marker))
+ (setq buffer-read-only t)
+ (when ancillary
+ (add-to-list 'cider-ancillary-buffers name)
+ (add-hook 'kill-buffer-hook
+ (lambda ()
+ (setq cider-ancillary-buffers
+ (remove name cider-ancillary-buffers)))
+ nil 'local))
+ (current-buffer)))
+
+(defun cider-emit-into-popup-buffer (buffer value &optional face inhibit-indent)
+ "Emit into BUFFER the provided VALUE optionally using FACE.
+Indent emitted value (usually a sexp) unless INHIBIT-INDENT is specified
+and non-nil."
+ ;; Long string output renders Emacs unresponsive and users might intentionally
+ ;; kill the frozen popup buffer. Therefore, we don't re-create the buffer and
+ ;; silently ignore the output.
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t)
+ (buffer-undo-list t)
+ (moving (= (point) cider-popup-output-marker)))
+ (save-excursion
+ (goto-char cider-popup-output-marker)
+ (let ((value-str (format "%s" value)))
+ (when face
+ (if (fboundp 'add-face-text-property)
+ (add-face-text-property 0 (length value-str) face nil value-str)
+ (add-text-properties 0 (length value-str) (list 'face face) 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-2018 Edwin Watkeys and CIDER contributors
+
+;; Author: Edwin Watkeys <edwNOSPAMposeur.com>
+;; Juan E. Maya <jmayaalv@gmail.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") #'cider-profile-clear)
+ (define-key map (kbd "S") #'cider-profile-summary)
+ (define-key map (kbd "s") #'cider-profile-var-summary)
+ (define-key map (kbd "n") #'cider-profile-ns-toggle)
+ (define-key map (kbd "v") #'cider-profile-var-profiled-p)
+ (define-key map (kbd "+") #'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 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
+
+;; Copyright (c) 2017 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-compat)
+(require 'cider-popup)
+(require 'clojure-mode)
+(require 'derived)
+(require 'pulse)
+
+(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))
+ :group 'cider-repl-history
+ :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)
+ :group 'cider-repl-history
+ :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")))
+ :group 'cider-repl-history
+ :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
+ :group 'cider-repl-history
+ :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
+ :group 'cider-repl-history
+ :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
+ :group 'cider-repl-history
+ :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))
+ :group 'cider-repl-history
+ :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
+ :group 'cider-repl-history
+ :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
+ :group 'cider-repl-history
+ :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
+ :group 'cider-repl-history
+ :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)
+ :group 'cider-repl-history
+ :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
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-display-duplicate-highest t
+ "When `cider-repl-history-display-duplicates' is nil, then display highest (most recent) duplicate items in the command history."
+ :type 'boolean
+ :group 'cider-repl-history
+ :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
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-hook nil
+ "A list of functions to call after `cider-repl-history'."
+ :type 'hook
+ :group 'cider-repl-history
+ :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
+ :group 'cider-repl-history
+ :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
+ "The 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 ()
+ "If variable `cider-repl-history-resize-window' is non-nil, resize the *cider-repl-history* 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, prompting 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 retun 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 and kill *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-highlighed-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-highlighed-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-highlighed-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-highlighed-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)
+ "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 udpated 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-highlighed-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))
+
+(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.
+
+\\{cider-repl-history-mode-map}"
+ (setq-local sesman-system 'CIDER)
+ (define-key cider-repl-history-mode-map (kbd "n") 'cider-repl-history-forward)
+ (define-key cider-repl-history-mode-map (kbd "p") 'cider-repl-history-previous)
+ (define-key cider-repl-history-mode-map (kbd "SPC") 'cider-repl-history-insert-and-quit)
+ (define-key cider-repl-history-mode-map (kbd "RET") 'cider-repl-history-insert-and-quit)
+ (define-key cider-repl-history-mode-map [(mouse-2)] 'cider-repl-history-mouse-insert)
+ (define-key cider-repl-history-mode-map (kbd "l") 'cider-repl-history-occur)
+ (define-key cider-repl-history-mode-map (kbd "s") 'cider-repl-history-search-forward)
+ (define-key cider-repl-history-mode-map (kbd "r") 'cider-repl-history-search-backward)
+ (define-key cider-repl-history-mode-map (kbd "g") 'cider-repl-history-update)
+ (define-key cider-repl-history-mode-map (kbd "q") 'cider-repl-history-quit)
+ (define-key cider-repl-history-mode-map (kbd "U") 'cider-repl-history-undo-other-window)
+ (define-key cider-repl-history-mode-map (kbd "?") 'describe-mode)
+ (define-key cider-repl-history-mode-map (kbd "h") 'describe-mode))
+
+;;;###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-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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 'cider-client)
+(require 'cider-doc)
+(require 'cider-test)
+(require 'cider-eldoc) ; for cider-eldoc-setup
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-util)
+(require 'cider-resolve)
+
+(require 'clojure-mode)
+(require 'easymenu)
+(require 'cl-lib)
+(require 'sesman)
+
+(eval-when-compile
+ (defvar paredit-version)
+ (defvar paredit-space-for-delimiter-predicates))
+
+\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."
+ :group 'cider-repl)
+
+(defface cider-repl-stdout-face
+ '((t (:inherit font-lock-string-face)))
+ "Face for STDOUT output in the REPL buffer."
+ :group 'cider-repl)
+
+(defface cider-repl-stderr-face
+ '((t (:inherit font-lock-warning-face)))
+ "Face for STDERR output in the REPL buffer."
+ :group 'cider-repl
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-repl-input-face
+ '((t (:bold t)))
+ "Face for previous input in the REPL buffer."
+ :group 'cider-repl)
+
+(defface cider-repl-result-face
+ '((t ()))
+ "Face for the result of an evaluation in the REPL buffer."
+ :group 'cider-repl)
+
+(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))
+ :group 'cider-repl)
+
+(defcustom cider-repl-display-in-current-window nil
+ "Controls whether the REPL buffer is displayed in the current window."
+ :type 'boolean
+ :group 'cider-repl)
+
+(defcustom cider-repl-scroll-on-output t
+ "Controls whether the REPL buffer auto-scrolls on new output.
+
+When set to t (the default), if the REPL buffer contains more lines than the
+size of the window, the buffer is automatically re-centered upon completion
+of evaluating an expression, so that the bottom line of output is on the
+bottom line of the window.
+
+If this is set to nil, no re-centering takes place."
+ :type 'boolean
+ :group 'cider-repl
+ :package-version '(cider . "0.11.0"))
+
+(defcustom cider-repl-use-pretty-printing nil
+ "Control whether results in the REPL are pretty-printed or not.
+The `cider-toggle-pretty-printing' command can be used to interactively
+change the setting's value."
+ :type 'boolean
+ :group 'cider-repl)
+
+(defcustom cider-repl-pretty-print-width nil
+ "Control the width of pretty printing on the REPL.
+This sets the wrap point for pretty printing on the repl. If nil, it
+defaults to the variable `fill-column'."
+ :type '(restricted-sexp :match-alternatives
+ (integerp 'nil))
+ :group 'cider-repl
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-use-content-types t
+ "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
+ :group 'cider-repl
+ :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
+ :group 'cider-repl
+ :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
+ :group 'cider-repl
+ :package-version '(cider . "0.10.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
+ :group 'cider-repl)
+
+(defcustom cider-repl-print-length 100
+ "Initial value for *print-length* set during REPL start."
+ :type 'integer
+ :group 'cider
+ :package-version '(cider . "0.17.0"))
+
+(defcustom cider-repl-print-level nil
+ "Initial value for *print-level* set during REPL start."
+ :type 'integer
+ :group 'cider
+ :package-version '(cider . "0.17.0"))
+
+(defcustom cider-repl-display-help-banner t
+ "When non-nil a bit of help text will be displayed on REPL start."
+ :type 'boolean
+ :group 'cider-repl
+ :package-version '(cider . "0.11.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)
+ (when (and repl-type cider-repl-auto-detect-type)
+ (cider-set-repl-type repl-type))
+ (unless (nrepl-dict-empty-p changed-namespaces)
+ (setq cider-repl-ns-cache (nrepl-dict-merge cider-repl-ns-cache changed-namespaces))
+ (dolist (b (buffer-list))
+ (with-current-buffer b
+ ;; Metadata changed, so signatures may have changed too.
+ (setq cider-eldoc-last-symbol nil)
+ (when (or cider-mode (derived-mode-p 'cider-repl-mode))
+ (when-let* ((ns-dict (or (nrepl-dict-get changed-namespaces (cider-current-ns))
+ (let ((ns-dict (cider-resolve--get-in (cider-current-ns))))
+ (when (seq-find (lambda (ns) (nrepl-dict-get changed-namespaces ns))
+ (nrepl-dict-get ns-dict "aliases"))
+ ns-dict)))))
+ (cider-refresh-dynamic-font-lock ns-dict))))))))))
+
+(declare-function cider-set-buffer-ns "cider-mode")
+(defun cider-repl-set-initial-ns (buffer)
+ "Require standard REPL util functions and set the ns of the REPL's BUFFER.
+Namespace is \"user\" by default, but can be overridden in apps like
+lein (:init-ns). Both of these operations need to be done as a sync
+request at the beginning of the session. Bundling them together for
+efficiency."
+ ;; we don't want to get a timeout during init
+ (let ((nrepl-sync-request-timeout nil))
+ (with-current-buffer buffer
+ (let* ((response (nrepl-send-sync-request
+ (lax-plist-put (nrepl--eval-request "(str *ns*)")
+ "inhibit-cider-middleware" "true")
+ (cider-current-repl)))
+ (initial-ns (or (read (nrepl-dict-get response "value"))
+ "user")))
+ (cider-set-buffer-ns initial-ns)))))
+
+(defun cider-repl-require-repl-utils ()
+ "Require standard REPL util functions into the current REPL."
+ (interactive)
+ (nrepl-send-sync-request
+ (lax-plist-put
+ (nrepl--eval-request
+ "(when (clojure.core/resolve 'clojure.main/repl-requires)
+ (clojure.core/map clojure.core/require clojure.main/repl-requires))")
+ "inhibit-cider-middleware" "true")
+ (cider-current-repl)))
+
+(defun cider-repl--build-config-expression ()
+ "Build the initial config expression."
+ (when (or cider-repl-print-length cider-repl-print-level)
+ (concat
+ "(do"
+ (when cider-repl-print-length (format " (set! *print-length* %d)" cider-repl-print-length))
+ (when cider-repl-print-level (format " (set! *print-level* %d)" cider-repl-print-level))
+ ")")))
+
+(defun cider-repl-set-config ()
+ "Set an inititial REPL configuration."
+ (interactive)
+ (when-let* ((config-expression (cider-repl--build-config-expression)))
+ (nrepl-send-sync-request
+ (lax-plist-put
+ (nrepl--eval-request config-expression)
+ "inhibit-cider-middleware" "true")
+ (cider-current-repl))))
+
+(defun cider-repl-init (buffer &optional no-banner)
+ "Initialize the REPL in BUFFER.
+BUFFER must be a REPL buffer with `cider-repl-mode' and a running
+client process connection. Unless NO-BANNER is non-nil, insert a banner."
+ (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 (display-buffer buffer))
+ ((pred identity) (pop-to-buffer buffer)))
+ (cider-repl-set-initial-ns buffer)
+ (cider-repl-require-repl-utils)
+ (cider-repl-set-config)
+ (unless no-banner
+ (cider-repl--insert-banner-and-prompt buffer))
+ (with-current-buffer buffer
+ (set-window-point (get-buffer-window) (point-max)))
+ buffer)
+
+(defun cider-repl--insert-banner-and-prompt (buffer)
+ "Insert REPL banner and REPL prompt in BUFFER."
+ (with-current-buffer buffer
+ (insert (propertize (cider-repl--banner) 'font-lock-face 'font-lock-comment-face))
+ (when cider-repl-display-help-banner
+ (insert (propertize (cider-repl--help-banner) 'font-lock-face 'font-lock-comment-face)))
+ (goto-char (point-max))
+ (cider-repl--mark-output-start)
+ (cider-repl--mark-input-start)
+ (cider-repl--insert-prompt cider-buffer-ns)))
+
+(defun cider-repl--banner ()
+ "Generate the welcome REPL buffer banner."
+ (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--help-banner ()
+ "Generate the help banner."
+ (substitute-command-keys
+ "\n;; ======================================================================
+;; If you're new to CIDER it is highly recommended to go through its
+;; 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 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)
+;; * Enable `eldoc-mode' to display function & method signatures in the minibuffer.
+;; * 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)))
+
+(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))
+
+(defun cider-repl--show-maximum-output ()
+ "Put the end of the buffer at the bottom of the window."
+ (when (and cider-repl-scroll-on-output (eobp))
+ (let ((win (get-buffer-window (current-buffer) t)))
+ (when win
+ (with-selected-window win
+ (set-window-point win (point-max))
+ (recenter -1))))))
+
+(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"))
+ :group 'cider-repl
+ :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--flush-ansi-color-context ()
+ "Flush ansi color context after printing.
+When there is a possible unfinished ansi control sequence,
+ `ansi-color-context` maintains this list."
+ (when (and ansi-color-context (stringp (cadr ansi-color-context)))
+ (insert-before-markers (cadr ansi-color-context))
+ (setq ansi-color-context nil)))
+
+(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 '(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'.")
+
+(defun cider-repl--emit-output-at-pos (buffer string output-face position &optional bol)
+ "Using BUFFER, insert STRING (applying to it OUTPUT-FACE) at POSITION.
+If BOL is non-nil insert at the beginning of line. Run
+`cider-repl-preoutput-hook' on STRING."
+ (with-current-buffer buffer
+ (save-excursion
+ (cider-save-marker cider-repl-output-start
+ (cider-save-marker cider-repl-output-end
+ (goto-char position)
+ ;; TODO: Review the need for bol
+ (when (and bol (not (bolp))) (insert-before-markers "\n"))
+ (setq string (propertize string
+ 'font-lock-face output-face
+ 'rear-nonsticky '(font-lock-face)))
+ (setq string (cider-run-chained-hook 'cider-repl-preoutput-hook string))
+ (insert-before-markers string)
+ (cider-repl--flush-ansi-color-context)
+ (when (and (= (point) cider-repl-prompt-start-mark)
+ (not (bolp)))
+ (insert-before-markers "\n")
+ (set-marker cider-repl-output-end (1- (point)))))))
+ (cider-repl--show-maximum-output)))
+
+(defun cider-repl--emit-interactive-output (string face)
+ "Emit STRING as interactive output using FACE."
+ (with-current-buffer (cider-current-repl)
+ (let ((pos (cider-repl--end-of-line-before-input-start))
+ (string (replace-regexp-in-string "\n\\'" "" string)))
+ (cider-repl--emit-output-at-pos (current-buffer) string face pos t))))
+
+(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-output (buffer string face &optional bol)
+ "Using BUFFER, emit STRING font-locked with FACE.
+If BOL is non-nil, emit at the beginning of the line."
+ (with-current-buffer buffer
+ (cider-repl--emit-output-at-pos buffer string face cider-repl-input-start-mark bol)))
+
+(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-save-marker cider-repl-output-start
+ (cider-save-marker cider-repl-output-end
+ (cider-repl--insert-prompt cider-buffer-ns))))
+ (cider-repl--show-maximum-output)))
+
+(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
+ (cider-save-marker cider-repl-output-end
+ (goto-char cider-repl-input-start-mark)
+ (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))))))
+ (cider-repl--show-maximum-output)))
+
+(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 string)
+ "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
+ (cider-save-marker cider-repl-output-end
+ (goto-char cider-repl-input-start-mark)
+ (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)))
+ (insert-image image string)
+ (set-marker cider-repl-input-start-mark (point) buffer)
+ (set-marker cider-repl-prompt-start-mark (point) buffer))))
+ (cider-repl--show-maximum-output))
+ 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))
+ :group 'cider-repl
+ :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-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))
+ "Association list from content-types to handlers.
+Handlers must be functions of two required and two optional arguments - the
+REPL buffer to insert into, the value of the given content type as a raw
+string, the REPL's show prefix as any and an `end-of-line' flag.
+
+The return value of the handler should be a flag, indicating whether or not
+the REPL is ready for a prompt to be displayed. Most handlers should return
+t, as the content-type response is (currently) an alternative to the
+value response. However for handlers which themselves issue subsequent
+nREPL ops, it may be convenient to prevent inserting a prompt.")
+
+(defun cider-repl-handler (buffer)
+ "Make an nREPL evaluation handler for the REPL BUFFER."
+ (let (after-first-result-chunk
+ (show-prompt t))
+ (nrepl-make-response-handler
+ buffer
+ (lambda (buffer value)
+ (cider-repl-emit-result buffer value (not after-first-result-chunk) t)
+ (setq after-first-result-chunk t))
+ (lambda (buffer out)
+ (cider-repl-emit-stdout buffer out))
+ (lambda (buffer err)
+ (cider-repl-emit-stderr buffer err))
+ (lambda (buffer)
+ (when show-prompt
+ (cider-repl-emit-prompt buffer)
+ (let ((win (get-buffer-window (current-buffer) t)))
+ (when win
+ (with-selected-window win
+ (set-window-point win cider-repl-input-start-mark))
+ (cider-repl--show-maximum-output)))))
+ nrepl-err-handler
+ (lambda (buffer pprint-out)
+ (cider-repl-emit-result buffer pprint-out (not after-first-result-chunk))
+ (setq after-first-result-chunk t))
+ (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 after-first-result-chunk t
+ show-prompt (funcall handler content-type buffer value
+ (not after-first-result-chunk) t))
+ (progn (cider-repl-emit-result buffer value (not after-first-result-chunk) t)
+ (setq after-first-result-chunk t)))))))
+
+(defun cider--repl-request-plist (right-margin &optional pprint-fn)
+ "Plist to be appended to generic eval requests, as for the REPL.
+PPRINT-FN and RIGHT-MARGIN are as in `cider--nrepl-pprint-request-plist'."
+ (nconc (when cider-repl-use-pretty-printing
+ (cider--nrepl-pprint-request-plist right-margin pprint-fn))
+ (when cider-repl-use-content-types
+ (cider--nrepl-content-type-plist))))
+
+(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")
+ (cider-repl--show-maximum-output))
+ (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 (cider--pretty-print-width)))))))
+
+(defun cider-repl-return (&optional end-of-input)
+ "Evaluate the current input string, or insert a newline.
+Send the current input ony 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--recenter-if-needed))
+ ((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--recenter-if-needed ()
+ "Make sure that the point is visible."
+ (unless (pos-visible-in-window-p (point-max))
+ (save-excursion
+ (goto-char (point-max))
+ (recenter -1))))
+
+(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 all open parenthesized 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--pretty-print-width ()
+ "Return the width to use for pretty-printing."
+ (or cider-repl-pretty-print-width
+ fill-column
+ 80))
+
+(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-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--end-of-line-before-input-start ()
+ "Return the position of the end of the line preceding the beginning of input."
+ (1- (previous-single-property-change cider-repl-input-start-mark 'field nil
+ (1+ (point-min)))))
+
+(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 ((start (save-excursion
+ (cider-repl-previous-prompt)
+ (ignore-errors (forward-sexp))
+ (forward-line)
+ (point)))
+ (end (cider-repl--end-of-line-before-input-start)))
+ (when (< start end)
+ (let ((inhibit-read-only t))
+ (cider-repl--clear-region start end)
+ (save-excursion
+ (goto-char start)
+ (insert
+ (propertize ";; output cleared" '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 implemetation 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)
+ (cider-nrepl-request:eval (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)
+ (reflection "Reflection warning, +\\(\\([^\n:]+\\):\\([0-9]+\\):[0-9]+\\)" 1 nil 2 3))
+ "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)
+ :group 'cider-repl
+ :package-version '(cider. "0.16.0"))
+
+(defun cider--locref-at-point-1 (reg-list &optional pos)
+ "Workhorse for getting locref at POS.
+REG-LIST is an entry in `cider-locref-regexp-alist'."
+ (save-excursion
+ (let ((pos (or pos (point))))
+ (goto-char pos)
+ (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."
+ (seq-some (lambda (rl) (cider--locref-at-point-1 rl pos))
+ 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
+ ;; retrieve from info middleware
+ (when var
+ (or (cider-sync-request:ns-path var)
+ (nrepl-dict-get (cider-sync-request:info var) "file")))
+ ;; when not found, return the file detected by regexp
+ (when-let* ((file (plist-get loc :file)))
+ (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)))))))
+ (if file
+ (cider--jump-to-loc-from-info (nrepl-dict "file" file "line" line) t)
+ (error "No source location for %s" var)))
+ (user-error "No location reference at point")))
+
+(defvar cider-locref-hoover-overlay
+ (let ((o (make-overlay 1 1)))
+ (overlay-put o 'category 'cider-error-hoover)
+ ;; (overlay-put o 'face 'highlight)
+ (overlay-put o 'pointer 'hand)
+ (overlay-put o 'mouse-face 'highlight)
+ (overlay-put o 'follow-link 'mouse)
+ (overlay-put o 'keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map [return] 'cider-jump-to-locref-at-point)
+ (define-key map [mouse-2] 'cider-jump-to-locref-at-point)
+ map))
+ o)
+ "Overlay used during hoovering on location references in REPL buffers.
+One for all REPLs.")
+
+(defun cider-locref-help-echo (_win buffer pos)
+ "Function for help-echo property in REPL buffers.
+WIN, BUFFER and POS are the window, buffer and point under mouse position."
+ (with-current-buffer buffer
+ (if-let* ((hl (plist-get (cider-locref-at-point pos) :highlight)))
+ (move-overlay cider-locref-hoover-overlay (car hl) (cdr hl))
+ (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
+ :group 'cider-repl)
+
+;; 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
+ :group 'cider-repl)
+
+(defcustom cider-repl-history-file nil
+ "File to save the persistent REPL history to."
+ :type 'string
+ :safe #'stringp
+ :group 'cider-repl)
+
+(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)
+ :group 'cider-repl)
+
+(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-mode")
+(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-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 "ns" #'cider-repl-set-ns)
+(cider-repl-add-shortcut "toggle-pretty" #'cider-repl-toggle-pretty-printing)
+(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 "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 "hasta la vista" #'cider-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)
+(cider-repl-add-shortcut "version" #'cider-version)
+(cider-repl-add-shortcut "require-repl-utils" #'cider-repl-require-repl-utils)
+
+(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")))))
+
+\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]
+ ["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]
+ ["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 manual online" cider-view-manual]
+ ["View refcard online" 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)
+
+(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))
+ (make-local-variable 'completion-at-point-functions)
+ (add-to-list 'completion-at-point-functions
+ #'cider-complete-at-point)
+ (set-syntax-table cider-repl-mode-syntax-table)
+ (cider-eldoc-setup)
+ ;; At the REPL, we define beginning-of-defun and end-of-defun to be
+ ;; the start of the previous prompt or next prompt respectively.
+ ;; Notice the interplay with `cider-repl-beginning-of-defun'.
+ (setq-local beginning-of-defun-function #'cider-repl-mode-beginning-of-defun)
+ (setq-local end-of-defun-function #'cider-repl-mode-end-of-defun)
+ (setq-local prettify-symbols-alist clojure--prettify-symbols-alist)
+ ;; apply dir-local variables to REPL buffers
+ (hack-dir-local-variables-non-file-buffer)
+ (when cider-repl-history-file
+ (cider-repl-history-load cider-repl-history-file)
+ (add-hook 'kill-buffer-hook #'cider-repl-history-just-save t t)
+ (add-hook 'kill-emacs-hook #'cider-repl-history-just-save))
+ (add-hook 'paredit-mode-hook (lambda () (clojure-paredit-setup cider-repl-mode-map))))
+
+(provide 'cider-repl)
+
+;;; cider-repl.el ends here
--- /dev/null
+;;; cider-resolve.el --- Resolve clojure symbols according to current nREPL connection
+
+;; Copyright © 2015-2018 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* ((referal (cider-resolve--get-in ns "refers" name)))
+ (cider-resolve-var ns referal)
+ ;; 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 (equal 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-2018 Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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\n"
+ "The initial message displayed in new scratch buffers."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.18.0"))
+
+(defvar cider-clojure-interaction-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map clojure-mode-map)
+ (define-key map (kbd "C-j") #'cider-eval-print-last-sexp)
+ (define-key map [remap paredit-newline] #'cider-eval-print-last-sexp)
+ (easy-menu-define cider-clojure-interaction-mode-menu map
+ "Menu for Clojure Interaction mode"
+ '("Clojure Interaction"
+ (["Eval and print last sexp" #'cider-eval-print-last-sexp]
+ "--"
+ ["Reset" #'cider-scratch-reset])))
+ map))
+
+(defconst cider-scratch-buffer-name "*cider-scratch*")
+
+;;;###autoload
+(defun cider-scratch ()
+ "Go to the scratch buffer named `cider-scratch-buffer-name'."
+ (interactive)
+ (pop-to-buffer (cider-scratch-find-or-create-buffer)))
+
+(defun cider-scratch-find-or-create-buffer ()
+ "Find or create the scratch buffer."
+ (or (get-buffer cider-scratch-buffer-name)
+ (cider-scratch--create-buffer)))
+
+(define-derived-mode cider-clojure-interaction-mode clojure-mode "Clojure Interaction"
+ "Major mode for typing and evaluating Clojure forms.
+Like clojure-mode except that \\[cider-eval-print-last-sexp] evals the Lisp expression
+before point, and prints its value into the buffer, advancing point.
+
+\\{cider-clojure-interaction-mode-map}"
+ (setq-local sesman-system 'CIDER))
+
+(defun cider-scratch--insert-welcome-message ()
+ "Insert the welcome message for the scratch buffer."
+ (insert cider-scratch-initial-message))
+
+(defun cider-scratch--create-buffer ()
+ "Create a new scratch buffer."
+ (with-current-buffer (get-buffer-create cider-scratch-buffer-name)
+ (cider-clojure-interaction-mode)
+ (cider-scratch--insert-welcome-message)
+ (current-buffer)))
+
+(defun cider-scratch-reset ()
+ "Reset the current scratch buffer."
+ (interactive)
+ (erase-buffer)
+ (cider-scratch--insert-welcome-message))
+
+(provide 'cider-scratch)
+
+;;; cider-scratch.el ends here
--- /dev/null
+;;; cider-selector.el --- Buffer selection command inspired by SLIME's selector -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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 (mode)
+ "Return the most recently visited buffer, deriving its `major-mode' from MODE.
+Only considers buffers that are not already visible."
+ (cl-loop for buffer in (buffer-list)
+ when (and (with-current-buffer buffer
+ (derived-mode-p mode))
+ ;; names starting with space are considered hidden by Emacs
+ (not (string-match-p "^ " (buffer-name buffer)))
+ (null (get-buffer-window buffer 'visible)))
+ return buffer
+ finally (error "Can't find unshown buffer in %S" mode)))
+
+;;;###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 then
+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 (get-buffer buffer))
+ (message "No such buffer: %S" buffer)
+ (ding))
+ ((get-buffer-window buffer)
+ (select-window (get-buffer-window buffer)))
+ (cider-selector-other-window
+ (switch-to-buffer-other-window buffer))
+ (t
+ (switch-to-buffer buffer)))))))
+ `(setq cider-selector-methods
+ (cl-sort (cons (list ,key ,description ,method)
+ (cl-remove ,key cider-selector-methods :key #'car))
+ #'< :key #'car))))
+
+(def-cider-selector-method ?? "Selector help buffer."
+ (ignore-errors (kill-buffer cider-selector-help-buffer))
+ (with-current-buffer (get-buffer-create cider-selector-help-buffer)
+ (insert "CIDER Selector Methods:\n\n")
+ (cl-loop for (key line nil) in cider-selector-methods
+ do (insert (format "%c:\t%s\n" key line)))
+ (goto-char (point-min))
+ (help-mode)
+ (display-buffer (current-buffer) t))
+ (cider-selector)
+ (current-buffer))
+
+(cl-pushnew (list ?4 "Select in other window" (lambda () (cider-selector t)))
+ cider-selector-methods :key #'car)
+
+(def-cider-selector-method ?c
+ "Most recently visited clojure-mode buffer."
+ (cider-selector--recently-visited-buffer 'clojure-mode))
+
+(def-cider-selector-method ?e
+ "Most recently visited emacs-lisp-mode buffer."
+ (cider-selector--recently-visited-buffer 'emacs-lisp-mode))
+
+(def-cider-selector-method ?q "Abort."
+ (top-level))
+
+(def-cider-selector-method ?r
+ "Current REPL buffer."
+ (cider-current-repl))
+
+(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 profiler 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-2018 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 'cl-lib)
+(require 'cider-popup)
+(require 'button)
+(require 'easymenu)
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-client)
+(require 'cider-util)
+
+(require 'seq)
+
+;; 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
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.7.0"))
+
+(defcustom cider-stacktrace-default-filters '(tooling dup)
+ "Frame types to omit from initial stacktrace display."
+ :type 'list
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defcustom cider-stacktrace-print-length 50
+ "Set the maximum length of sequences in displayed cause data.
+
+This sets the value of Clojure's `*print-length*` when pretty printing the
+`ex-data` map for exception causes in the stacktrace that are instances of
+`IExceptionInfo`.
+
+Be advised that setting this to `nil` will cause the attempted printing of
+infinite data structures."
+ :type '(choice integer (const nil))
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-stacktrace-print-level 50
+ "Set the maximum level of nesting in displayed cause data.
+
+This sets the value of Clojure's `*print-level*` when pretty printing the
+`ex-data` map for exception causes in the stacktrace that are instances of
+`IExceptionInfo`.
+
+Be advised that setting this to `nil` will cause the attempted printing of
+cyclical data structures."
+ :type '(choice integer (const nil))
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.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*")
+
+(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
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.12.0"))
+
+;; Faces
+
+(defface cider-stacktrace-error-class-face
+ '((t (:inherit font-lock-warning-face)))
+ "Face for exception class names"
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-error-message-face
+ '((t (:inherit font-lock-doc-face)))
+ "Face for exception messages"
+ :group 'cider-stacktrace
+ :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"
+ :group 'cider-stacktrace
+ :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"
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-face
+ '((t (:inherit default)))
+ "Face for stack frame text"
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-ns-face
+ '((t (:inherit font-lock-comment-face)))
+ "Face for stack frame namespace name"
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-fn-face
+ '((t (:inherit default :weight bold)))
+ "Face for stack frame function name"
+ :group 'cider-stacktrace
+ :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."
+ :group 'cider-stacktrace
+ :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."
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.12.0"))
+
+;; Colors & Theme Support
+
+(defvar cider-stacktrace-frames-background-color
+ (cider-scale-background-color)
+ "Background color for stacktrace frames.")
+
+(defadvice enable-theme (after cider-stacktrace-adapt-to-theme activate)
+ "When theme is changed, update `cider-stacktrace-frames-background-color'."
+ (setq cider-stacktrace-frames-background-color (cider-scale-background-color)))
+
+
+(defadvice disable-theme (after cider-stacktrace-adapt-to-theme activate)
+ "When theme is disabled, 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)))
+
+
+;; 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 element 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 element ERROR-TYPE from the `cider-stacktrace-suppressed-errors' set."
+ (setq cider-stacktrace-suppressed-errors
+ (remove error-type cider-stacktrace-suppressed-errors)))
+
+(defun cider-stacktrace-suppressed-error-p (error-type)
+ "Return non-nil if element ERROR-TYPE is a member of the `cider-stacktrace-suppressed-errors' set."
+ (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 useed, otherwise its current value is incremented.
+When it reaches 3, it wraps to 0."
+ (let ((level (or level (1+ (elt cider-stacktrace-cause-visibility num)))))
+ (aset cider-stacktrace-cause-visibility num (mod level 3))
+ (cider-stacktrace-apply-cause-visibility)))
+
+(defun cider-stacktrace-cycle-all-causes ()
+ "Cycle the visibility of all exception causes."
+ (interactive)
+ (with-current-buffer cider-error-buffer
+ (save-excursion
+ ;; Find nearest cause.
+ (unless (get-text-property (point) 'cause)
+ (cider-stacktrace-next-cause)
+ (unless (get-text-property (point) 'cause)
+ (cider-stacktrace-previous-cause)))
+ ;; Cycle its level, and apply that to all causes.
+ (let* ((num (get-text-property (point) 'cause))
+ (level (1+ (elt cider-stacktrace-cause-visibility num))))
+ (setq-local cider-stacktrace-cause-visibility
+ (make-vector 10 (mod level 3)))
+ (cider-stacktrace-apply-cause-visibility)))))
+
+(defun cider-stacktrace-cycle-current-cause ()
+ "Cycle the visibility of current exception at point, if any."
+ (interactive)
+ (with-current-buffer cider-error-buffer
+ (when-let* ((num (get-text-property (point) 'cause)))
+ (cider-stacktrace-cycle-cause num))))
+
+(defun cider-stacktrace-cycle-cause-1 ()
+ "Cycle the visibility of exception cause #1."
+ (interactive)
+ (cider-stacktrace-cycle-cause 1))
+
+(defun cider-stacktrace-cycle-cause-2 ()
+ "Cycle the visibility of exception cause #2."
+ (interactive)
+ (cider-stacktrace-cycle-cause 2))
+
+(defun cider-stacktrace-cycle-cause-3 ()
+ "Cycle the visibility of exception cause #3."
+ (interactive)
+ (cider-stacktrace-cycle-cause 3))
+
+(defun cider-stacktrace-cycle-cause-4 ()
+ "Cycle the visibility of exception cause #4."
+ (interactive)
+ (cider-stacktrace-cycle-cause 4))
+
+(defun cider-stacktrace-cycle-cause-5 ()
+ "Cycle the visibility of exception cause #5."
+ (interactive)
+ (cider-stacktrace-cycle-cause 5))
+
+(defun cider-stacktrace-toggle (flag)
+ "Update `cider-stacktrace-filters' to add or remove FLAG, and apply filters."
+ (cider-stacktrace-apply-filters
+ (setq cider-stacktrace-filters
+ (if (memq flag cider-stacktrace-filters)
+ (remq flag cider-stacktrace-filters)
+ (cons flag cider-stacktrace-filters)))))
+
+(defun cider-stacktrace-toggle-all ()
+ "Toggle `all' in filter list."
+ (interactive)
+ (cider-stacktrace-toggle 'all))
+
+(defun cider-stacktrace-show-only-project ()
+ "Display only the stackframes from the project."
+ (interactive)
+ (cider-stacktrace-toggle 'project))
+
+(defun cider-stacktrace-toggle-java ()
+ "Toggle display of Java stack frames."
+ (interactive)
+ (cider-stacktrace-toggle 'java))
+
+(defun cider-stacktrace-toggle-clj ()
+ "Toggle display of Clojure stack frames."
+ (interactive)
+ (cider-stacktrace-toggle 'clj))
+
+(defun cider-stacktrace-toggle-repl ()
+ "Toggle display of REPL stack frames."
+ (interactive)
+ (cider-stacktrace-toggle 'repl))
+
+(defun cider-stacktrace-toggle-tooling ()
+ "Toggle display of Tooling stack frames (compiler, nREPL middleware, etc)."
+ (interactive)
+ (cider-stacktrace-toggle 'tooling))
+
+(defun cider-stacktrace-toggle-duplicates ()
+ "Toggle display of stack frames that are duplicates of their descendents."
+ (interactive)
+ (cider-stacktrace-toggle 'dup))
+
+;; Text button functions
+
+(defun cider-stacktrace-filter (button)
+ "Apply filter(s) indicated by the BUTTON."
+ (with-temp-message "Filters may also be toggled with the keyboard."
+ (let ((flag (button-get button 'filter)))
+ (cond ((member flag cider-stacktrace--all-negative-filters)
+ (cider-stacktrace-toggle flag))
+ ((member flag cider-stacktrace--all-positive-filters)
+ (cider-stacktrace-show-only-project))
+ (t (cider-stacktrace-toggle-all))))
+ (sit-for 5)))
+
+(defun cider-stacktrace-toggle-suppression (button)
+ "Toggle stacktrace pop-over/pop-under behavior for the `error-type' in BUTTON.
+Achieved by destructively manipulating the `cider-stacktrace-suppressed-errors' set."
+ (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
+ (and (null var) (cider-resolve-java-class class))
+ (nrepl-dict-get info "file")
+ (button-get button 'file)))
+ ;; give priority to `info` files as `info` returns full paths.
+ (info (nrepl-dict-put info "file" file)))
+ (cider--jump-to-loc-from-info info t)
+ (forward-line line-shift)
+ (back-to-indentation)))
+
+(declare-function cider-find-var "cider-find")
+
+(defun cider-stacktrace-jump (&optional arg)
+ "Find definition for stack frame at point, if available.
+The prefix ARG and `cider-prompt-for-symbol' decide whether to
+prompt and whether to use a new window. Similar to `cider-find-var'."
+ (interactive "P")
+ (let ((button (button-at (point))))
+ (if (and button (button-get button 'line))
+ (cider-stacktrace-navigate button)
+ (cider-find-var arg))))
+
+
+;; Rendering
+(defvar cider-use-tooltips)
+(defun cider-stacktrace-tooltip (tooltip)
+ "Return TOOLTIP if `cider-use-tooltips' is set to true, nil otherwise."
+ (when cider-use-tooltips tooltip))
+
+(defun cider-stacktrace-emit-indented (text &optional indent fill fontify)
+ "Insert TEXT, and optionally FILL and FONTIFY as clojure the entire block.
+INDENT is a string to insert before each line. When INDENT is nil, first
+line is not indented and INDENT defaults to a white-spaced string with
+length given by `current-column'."
+ (let ((text (if fontify
+ (cider-font-lock-as-clojure text)
+ text))
+ (do-first indent)
+ (indent (or indent (make-string (current-column) ? )))
+ (beg (point)))
+ (insert text)
+ (goto-char beg)
+ (when do-first
+ (insert indent))
+ (forward-line)
+ (while (not (eobp))
+ (insert indent)
+ (forward-line))
+ (when (and fill cider-stacktrace-fill-column)
+ (when (and (numberp cider-stacktrace-fill-column))
+ (setq-local fill-column cider-stacktrace-fill-column))
+ (setq-local fill-prefix indent)
+ (fill-region beg (point)))))
+
+(defun cider-stacktrace-render-filters (buffer special-filters filters)
+ "Emit into BUFFER toggle buttons for each of the FILTERS.
+SPECIAL-FILTERS are filters that show stack certain stack frames, hiding
+others."
+ (with-current-buffer buffer
+ (insert " Show: ")
+ (dolist (filter special-filters)
+ (insert-text-button (car filter)
+ 'filter (cadr filter)
+ 'follow-link t
+ 'action 'cider-stacktrace-filter
+ 'help-echo (cider-stacktrace-tooltip
+ (format "Toggle %s stack frames"
+ (car filter))))
+ (insert " "))
+ (insert "\n")
+ (insert " Hide: ")
+ (dolist (filter filters)
+ (insert-text-button (car filter)
+ 'filter (cadr filter)
+ 'follow-link t
+ 'action 'cider-stacktrace-filter
+ 'help-echo (cider-stacktrace-tooltip
+ (format "Toggle %s stack frames"
+ (car filter))))
+ (insert " "))
+
+ (let ((hidden "(0 frames hidden)"))
+ (put-text-property 0 (length hidden) 'hidden-count t hidden)
+ (insert " " hidden "\n"))))
+
+(defun cider-stacktrace-render-suppression-toggle (buffer error-types)
+ "Emit into BUFFER toggle buttons for each of the ERROR-TYPES leading this stacktrace buffer."
+ (with-current-buffer buffer
+ (when error-types
+ (insert " This is an unexpected CIDER middleware error.\n Please submit a bug report via `")
+ (insert-text-button "M-x cider-report-bug"
+ 'follow-link t
+ 'action (lambda (_button) (cider-report-bug))
+ 'help-echo (cider-stacktrace-tooltip
+ "Report bug to the CIDER team."))
+ (insert "`.\n\n")
+ (insert "\
+ If these stacktraces are occuring 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
+ (nrepl-dbind-response frame (file line flags class method name var ns fn)
+ (let ((flags (mapcar 'intern flags))) ; strings -> symbols
+ (insert-text-button (format "%26s:%5d %s/%s"
+ (if (member 'repl flags) "REPL" file) line
+ (if (member 'clj flags) ns class)
+ (if (member 'clj flags) fn method))
+ 'var var 'class class 'method method
+ 'name name 'file file 'line line
+ 'flags flags 'follow-link t
+ 'action 'cider-stacktrace-navigate
+ 'help-echo (cider-stacktrace-tooltip
+ "View source at this location")
+ 'font-lock-face 'cider-stacktrace-face
+ 'type 'cider-plain-button)
+ (save-excursion
+ (let ((p4 (point))
+ (p1 (search-backward " "))
+ (p2 (search-forward "/"))
+ (p3 (search-forward-regexp "[^/$]+")))
+ (put-text-property p1 p4 'font-lock-face 'cider-stacktrace-ns-face)
+ (put-text-property p2 p3 'font-lock-face 'cider-stacktrace-fn-face)
+ (put-text-property (line-beginning-position) (line-end-position)
+ 'cider-stacktrace-frame t)))
+ (insert "\n")))))
+
+(defun cider-stacktrace-render-compile-error (buffer cause)
+ "Emit into BUFFER the compile error CAUSE, and enable jumping to it."
+ (with-current-buffer buffer
+ (nrepl-dbind-response cause (file path line column)
+ (let ((indent " ")
+ (message-face 'cider-stacktrace-error-message-face))
+ (insert indent)
+ (insert (propertize "Error compiling " 'font-lock-face message-face))
+ (insert-text-button path 'compile-error t
+ 'file file 'line line 'column column 'follow-link t
+ 'action (lambda (_button)
+ (cider-jump-to (cider-find-file file)
+ (cons line column)))
+ 'help-echo (cider-stacktrace-tooltip
+ "Jump to the line that caused the error"))
+ (insert (propertize (format " at (%d:%d)" line column)
+ 'font-lock-face message-face))))))
+
+(defun cider-stacktrace--toggle-visibility (id)
+ "Toggle visibility of the region with ID invisibility prop.
+ID can also be a button, in which case button's property :id is used
+instead. This function can be used directly in button actions."
+ (let ((id (if (or (numberp id) (symbolp id))
+ ;; There is no proper way to identify buttons. Assuming that
+ ;; id's can be either numbers or symbols.
+ id
+ (button-get id :id))))
+ (if (and (consp buffer-invisibility-spec)
+ (assoc id buffer-invisibility-spec))
+ (remove-from-invisibility-spec (cons id t))
+ (add-to-invisibility-spec (cons id t)))))
+
+(defun cider-stacktrace--insert-named-group (indent name &rest vals)
+ "Insert named group with the ability to toggle visibility.
+NAME is a string naming the group. VALS are strings to be inserted after
+the NAME. The whole group is prefixed by string INDENT."
+ (let* ((str (and vals (replace-regexp-in-string "\n+\\'" "" (apply #'concat vals))))
+ (id (and str
+ (string-match "\n" str)
+ (cl-gensym name))))
+ (insert indent)
+ (if id
+ (let* ((beg-link (string-match "[^ :]" name))
+ (end-link (string-match "[ :]" name (1+ beg-link))))
+ (insert (substring name 0 beg-link))
+ (insert-text-button (substring name beg-link end-link)
+ :id id
+ 'face '((:weight bold) (:underline t))
+ 'follow-link t
+ 'help-echo "Toggle visibility"
+ 'action #'cider-stacktrace--toggle-visibility)
+ (insert (substring name end-link)))
+ (insert (propertize name 'face '((:weight bold)))))
+ (let ((pos (point)))
+ (when str
+ (cider-stacktrace-emit-indented (concat str "\n") nil nil t)
+ (when id
+ (remove-from-invisibility-spec (cons id t))
+ (let ((hide-beg (save-excursion (goto-char pos) (point-at-eol)))
+ (hide-end (1- (point-at-bol))))
+ (overlay-put (make-overlay hide-beg hide-end) 'invisible id)))))))
+
+(defun cider-stacktrace--emit-spec-problems (spec-data indent)
+ "Emit SPEC-DATA indented with INDENT."
+ (nrepl-dbind-response spec-data (spec value problems)
+ (insert "\n")
+ (cider-stacktrace--insert-named-group indent " Spec: " spec)
+ (cider-stacktrace--insert-named-group indent " Value: " value)
+ (insert "\n")
+ (cider-stacktrace--insert-named-group indent "Problems: \n")
+ (let ((indent2 (concat indent " ")))
+ (dolist (prob problems)
+ (nrepl-dbind-response prob (in val predicate reason spec at extra)
+ (insert "\n")
+ (when (not (string= val value))
+ (cider-stacktrace--insert-named-group indent2 " val: " val))
+ (when in
+ (cider-stacktrace--insert-named-group indent2 " in: " in))
+ (cider-stacktrace--insert-named-group indent2 "failed: " predicate)
+ (when spec
+ (cider-stacktrace--insert-named-group indent2 " spec: " spec))
+ (when at
+ (cider-stacktrace--insert-named-group indent2 " at: " at))
+ (when reason
+ (cider-stacktrace--insert-named-group indent2 "reason: " reason))
+ (when extra
+ (cider-stacktrace--insert-named-group indent2 "extras: \n")
+ (cider-stacktrace-emit-indented extra (concat indent2 " ") nil t)))))))
+
+(defun cider-stacktrace-render-cause (buffer cause num note)
+ "Emit into BUFFER the CAUSE NUM, exception class, message, data, and NOTE."
+ (with-current-buffer buffer
+ (nrepl-dbind-response cause (class message data spec stacktrace)
+ (let ((indent " ")
+ (class-face 'cider-stacktrace-error-class-face)
+ (message-face 'cider-stacktrace-error-message-face))
+ (cider-propertize-region `(cause ,num)
+ ;; Detail level 0: exception class
+ (cider-propertize-region '(detail 0)
+ (insert (format "%d. " num)
+ (propertize note 'font-lock-face 'font-lock-comment-face) " "
+ (propertize class 'font-lock-face class-face)
+ "\n"))
+ ;; Detail level 1: message + ex-data
+ (cider-propertize-region '(detail 1)
+ (if (equal class "clojure.lang.Compiler$CompilerException")
+ (cider-stacktrace-render-compile-error buffer cause)
+ (cider-stacktrace-emit-indented
+ (propertize (or message "(No message)")
+ 'font-lock-face message-face)
+ indent t))
+ (insert "\n")
+ (when spec
+ (cider-stacktrace--emit-spec-problems spec (concat indent " ")))
+ (when data
+ (cider-stacktrace-emit-indented data indent nil t)))
+ ;; Detail level 2: stacktrace
+ (cider-propertize-region '(detail 2)
+ (insert "\n")
+ (let ((beg (point))
+ (bg `(:background ,cider-stacktrace-frames-background-color)))
+ (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))
+ (goto-char (next-single-property-change (point) 'flags)))))))))
+
+(defun cider-stacktrace-render (buffer causes &optional error-types)
+ "Emit into BUFFER useful stacktrace information for the CAUSES.
+Takes an optional ERROR-TYPES list which will render a 'suppression' toggle
+that alters the pop-over/pop-under behavorior of the stacktrace buffers
+created by these types of errors. The suppressed errors set can be customized
+through the `cider-stacktrace-suppressed-errors' variable."
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert "\n")
+ ;; Stacktrace filters
+ (cider-stacktrace-render-filters
+ buffer
+ `(("Project-Only" project) ("All" all))
+ `(("Clojure" clj) ("Java" java) ("REPL" repl)
+ ("Tooling" tooling) ("Duplicates" dup)))
+ (insert "\n")
+ ;; Option to suppress internal/middleware errors
+ (when error-types
+ (cider-stacktrace-render-suppression-toggle buffer error-types)
+ (insert "\n\n"))
+ ;; Stacktrace exceptions & frames
+ (let ((num (length causes)))
+ (dolist (cause causes)
+ (let ((note (if (= num (length causes)) "Unhandled" "Caused by")))
+ (cider-stacktrace-render-cause buffer cause num note)
+ (setq num (1- num))))))
+ (cider-stacktrace-initialize causes)
+ (font-lock-refresh-defaults)))
+
+(provide 'cider-stacktrace)
+
+;;; cider-stacktrace.el ends here
--- /dev/null
+;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2018 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 'cider-common)
+(require 'cider-client)
+(require 'cider-popup)
+(require 'cider-stacktrace)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-overlays)
+
+(require 'button)
+(require 'cl-lib)
+(require 'easymenu)
+(require 'seq)
+
+;;; 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
+ :group 'cider-test
+ :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
+ :group 'cider-test
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-test-defining-forms '("deftest" "defspec")
+ "Forms that define individual tests.
+CIDER considers the \"top-level\" form around point to define a test if
+the form starts with one of these forms.
+Add to this list to have CIDER recognize additional test defining macros."
+ :type '(repeat string)
+ :group 'cider-test
+ :package-version '(cider . "0.15.0"))
+
+(defvar cider-test-last-summary nil
+ "The summary of the last run test.")
+
+(defvar cider-test-last-results nil
+ "The results of the last run test.")
+
+(defconst cider-test-report-buffer "*cider-test-report*"
+ "Buffer name in which to display test reports.")
+
+;;; Faces
+
+(defface cider-test-failure-face
+ '((((class color) (background light))
+ :background "orange red")
+ (((class color) (background dark))
+ :background "firebrick"))
+ "Face for failed tests."
+ :group 'cider-test
+ :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."
+ :group 'cider-test
+ :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."
+ :group 'cider-test
+ :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.")
+
+(defadvice enable-theme (after cider-test-adapt-to-theme activate)
+ "When theme is changed, update `cider-test-items-background-color'."
+ (setq cider-test-items-background-color (cider-scale-background-color)))
+
+
+(defadvice disable-theme (after cider-test-adapt-to-theme activate)
+ "When theme is disabled, 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-g") #'cider-test-rerun-test)
+ (define-key map (kbd "C-n") #'cider-test-run-ns-tests)
+ (define-key map (kbd "C-s") #'cider-test-run-ns-tests-with-filters)
+ (define-key map (kbd "C-l") #'cider-test-run-loaded-tests)
+ (define-key map (kbd "C-p") #'cider-test-run-project-tests)
+ (define-key map (kbd "C-b") #'cider-test-show-report)
+ ;; Single-key bindings defined last for display in menu
+ (define-key map (kbd "r") #'cider-test-rerun-failed-tests)
+ (define-key map (kbd "t") #'cider-test-run-test)
+ (define-key map (kbd "g") #'cider-test-rerun-test)
+ (define-key map (kbd "n") #'cider-test-run-ns-tests)
+ (define-key map (kbd "s") #'cider-test-run-ns-tests-with-filters)
+ (define-key map (kbd "l") #'cider-test-run-loaded-tests)
+ (define-key map (kbd "p") #'cider-test-run-project-tests)
+ (define-key map (kbd "b") #'cider-test-show-report)
+ map))
+
+(defconst cider-test-menu
+ '("Test"
+ ["Run test" cider-test-run-test]
+ ["Run namespace tests" cider-test-run-ns-tests]
+ ["Run namespace tests with filters" cider-test-run-ns-tests-with-filters]
+ ["Run all loaded tests" cider-test-run-loaded-tests]
+ ["Run all loaded tests with filters" (apply-partially cider-test-run-loaded-tests 'prompt-for-filters)]
+ ["Run all project tests" cider-test-run-project-tests]
+ ["Run all project tests with filters" (apply-partially cider-test-run-project-tests 'prompt-for-filters)]
+ ["Run tests after load-file" cider-auto-test-mode
+ :style toggle :selected cider-auto-test-mode]
+ "--"
+ ["Interrupt running tests" cider-interrupt]
+ ["Rerun failed/erring tests" cider-test-rerun-failed-tests]
+ ["Show test report" cider-test-show-report]
+ "--"
+ ["Configure testing" (customize-group 'cider-test)])
+ "CIDER test submenu.")
+
+(defvar cider-test-report-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c ,") 'cider-test-commands-map)
+ (define-key map (kbd "C-c C-t") 'cider-test-commands-map)
+ (define-key map (kbd "M-p") #'cider-test-previous-result)
+ (define-key map (kbd "M-n") #'cider-test-next-result)
+ (define-key map (kbd "M-.") #'cider-test-jump)
+ (define-key map (kbd "<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))
+
+;; 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
+ (nconc `("op" "test-stacktrace"
+ "ns" ,ns
+ "var" ,var
+ "index" ,index)
+ (when (cider--pprint-fn)
+ `("pprint-fn" ,(cider--pprint-fn)))
+ (when cider-stacktrace-print-length
+ `("print-length" ,cider-stacktrace-print-length))
+ (when cider-stacktrace-print-level
+ `("print-level" ,cider-stacktrace-print-level)))
+ (lambda (response)
+ (nrepl-dbind-response response (class status)
+ (cond (class (setq causes (cons response causes)))
+ (status (when causes
+ (cider-stacktrace-render
+ (cider-popup-buffer cider-error-buffer
+ cider-auto-select-error-buffer
+ #'cider-stacktrace-mode
+ 'ancillary)
+ (reverse causes))))))))))
+
+(defun cider-test-stacktrace ()
+ "Display stacktrace for the erring test at point."
+ (interactive)
+ (let ((ns (get-text-property (point) 'ns))
+ (var (get-text-property (point) 'var))
+ (index (get-text-property (point) 'index))
+ (err (get-text-property (point) 'error)))
+ (if (and err ns var index)
+ (cider-test-stacktrace-for ns var index)
+ (message "No test error at point"))))
+
+
+;;; Expected vs actual diffing
+
+(defvar cider-test-ediff-buffers nil
+ "The expected/actual buffers used to display diff.")
+
+(defun cider-test--extract-from-actual (actual n)
+ "Extract form N from ACTUAL, ignoring outermost not.
+
+ACTUAL is a string like \"(not (= 3 4))\", of the sort returned by
+clojure.test.
+
+N = 1 => 3, N = 2 => 4, etc."
+ (with-temp-buffer
+ (insert actual)
+ (clojure-mode)
+ (goto-char (point-min))
+ (re-search-forward "(" nil t 2)
+ (clojure-forward-logical-sexp n)
+ (forward-whitespace 1)
+ (let ((beg (point)))
+ (clojure-forward-logical-sexp)
+ (buffer-substring beg (point)))))
+
+(defun cider-test-ediff ()
+ "Show diff of the expected vs actual value for the test at point.
+With the actual value, the outermost '(not ...)' s-expression is removed."
+ (interactive)
+ (let* ((expected-buffer (generate-new-buffer " *expected*"))
+ (actual-buffer (generate-new-buffer " *actual*"))
+ (diffs (get-text-property (point) 'diffs))
+ (actual* (get-text-property (point) 'actual))
+ (expected (cond (diffs (get-text-property (point) 'expected))
+ (actual* (cider-test--extract-from-actual actual* 1))))
+ (actual (cond (diffs (caar diffs))
+ (actual* (cider-test--extract-from-actual actual* 2)))))
+ (if (not (and expected actual))
+ (message "No test failure at point")
+ (with-current-buffer expected-buffer
+ (insert expected)
+ (clojure-mode))
+ (with-current-buffer actual-buffer
+ (insert actual)
+ (clojure-mode))
+ (apply #'ediff-buffers
+ (setq cider-test-ediff-buffers
+ (list (buffer-name expected-buffer)
+ (buffer-name actual-buffer)))))))
+
+(defun cider-test-ediff-cleanup ()
+ "Cleanup expected/actual buffers used for diff."
+ (interactive)
+ (mapc (lambda (b) (when (get-buffer b) (kill-buffer b)))
+ cider-test-ediff-buffers))
+
+(add-hook 'ediff-cleanup-hook #'cider-test-ediff-cleanup)
+
+
+;;; Report rendering
+
+(defun cider-test-type-face (type)
+ "Return the font lock face for the test result TYPE."
+ (pcase type
+ ("pass" 'cider-test-success-face)
+ ("fail" 'cider-test-failure-face)
+ ("error" 'cider-test-error-face)
+ (_ 'default)))
+
+(defun cider-test-type-simple-face (type)
+ "Return a face for the test result TYPE using the highlight color as foreground."
+ (let ((face (cider-test-type-face type)))
+ `(:foreground ,(face-attribute face :background))))
+
+(defun cider-test-render-summary (buffer summary)
+ "Emit into BUFFER the report SUMMARY statistics."
+ (with-current-buffer buffer
+ (nrepl-dbind-response summary (ns var test pass fail error)
+ (insert (format "Tested %d namespaces\n" ns))
+ (insert (format "Ran %d assertions, in %d test functions\n" test var))
+ (unless (zerop fail)
+ (cider-insert (format "%d failures" fail) 'cider-test-failure-face t))
+ (unless (zerop error)
+ (cider-insert (format "%d errors" error) 'cider-test-error-face t))
+ (when (zerop (+ fail error))
+ (cider-insert (format "%d passed" pass) 'cider-test-success-face t))
+ (insert "\n\n"))))
+
+(defun cider-test-render-assertion (buffer test)
+ "Emit into BUFFER report detail for the TEST assertion."
+ (with-current-buffer buffer
+ (nrepl-dbind-response test (var context type message expected actual diffs error gen-input)
+ (cl-flet ((insert-label (s)
+ (cider-insert (format "%8s: " s) 'font-lock-comment-face))
+ (insert-align-label (s)
+ (insert (format "%12s" s)))
+ (insert-rect (s)
+ (insert-rectangle (thread-first s
+ cider-font-lock-as-clojure
+ (split-string "\n")))
+ (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)))
+ (cider-insert (capitalize type) type-face nil " in ")
+ (cider-insert var 'font-lock-function-name-face t)
+ (when context (cider-insert context 'font-lock-doc-face t))
+ (when message (cider-insert message 'font-lock-string-face t))
+ (when expected
+ (insert-label "expected")
+ (insert-rect expected)
+ (insert "\n"))
+ (if diffs
+ (dolist (d diffs)
+ (cl-destructuring-bind (actual (removed added)) d
+ (insert-label "actual")
+ (insert-rect actual)
+ (insert-label "diff")
+ (insert "- ")
+ (insert-rect removed)
+ (insert-align-label "+ ")
+ (insert-rect added)
+ (insert "\n")))
+ (when actual
+ (insert-label "actual")
+ (insert-rect actual)))
+ (when error
+ (insert-label "error")
+ (insert-text-button error
+ 'follow-link t
+ 'action '(lambda (_button) (cider-test-stacktrace))
+ 'help-echo "View causes and stacktrace")
+ (insert "\n"))
+ (when gen-input
+ (insert-label "input")
+ (insert (cider-font-lock-as-clojure gen-input)))
+ (overlay-put (make-overlay beg (point)) 'font-lock-face bg))
+ (insert "\n"))))))
+
+(defun cider-test-non-passing (tests)
+ "For a list of TESTS, each an `nrepl-dict`, return only those that did not pass."
+ (seq-filter (lambda (test)
+ (unless (equal (nrepl-dict-get test "type") "pass")
+ test))
+ tests))
+
+(defun cider-test-render-report (buffer summary results)
+ "Emit into BUFFER the report for the SUMMARY, and test RESULTS."
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t))
+ (cider-test-report-mode)
+ (cider-insert "Test Summary" 'bold t)
+ (dolist (ns (nrepl-dict-keys results))
+ (insert (cider-propertize ns 'ns) "\n"))
+ (cider-insert "\n")
+ (cider-test-render-summary buffer summary)
+ (nrepl-dbind-response summary (fail error)
+ (unless (zerop (+ fail error))
+ (cider-insert "Results" 'bold t "\n")
+ ;; Results are a nested dict, keyed first by ns, then var. Within each
+ ;; var is a sequence of test assertion results.
+ (nrepl-dict-map
+ (lambda (ns vars)
+ (nrepl-dict-map
+ (lambda (_var tests)
+ (let* ((problems (cider-test-non-passing tests))
+ (count (length problems)))
+ (when (< 0 count)
+ (insert (format "%s\n%d non-passing tests:\n\n"
+ (cider-propertize ns 'ns) count))
+ (dolist (test problems)
+ (cider-test-render-assertion buffer test)))))
+ vars))
+ results)))
+ (goto-char (point-min))
+ (current-buffer))))
+
+
+;;; Message echo
+
+(defun cider-test-echo-running (ns &optional test)
+ "Echo a running message for the test NS, which may be a keyword.
+The optional arg TEST denotes an individual test name."
+ (if test
+ (message "Running test %s in %s..."
+ (cider-propertize test 'bold)
+ (cider-propertize ns 'ns))
+ (message "Running tests in %s..."
+ (concat (cider-propertize
+ (cond ((stringp ns) ns)
+ ((eq :non-passing ns) "failing")
+ ((eq :loaded ns) "all loaded")
+ ((eq :project ns) "all project"))
+ 'ns)
+ (unless (stringp ns) " namespaces")))))
+
+(defun cider-test-echo-summary (summary results)
+ "Echo SUMMARY statistics for a test run returning RESULTS."
+ (nrepl-dbind-response summary (ns test var fail error)
+ (if (nrepl-dict-empty-p results)
+ (message (concat (propertize "No assertions (or no tests) were run." 'face 'cider-test-error-face)
+ "Did you forget to use `is' in your tests?"))
+ (message (propertize
+ "%sRan %d assertions, in %d test functions. %d failures, %d errors."
+ 'face (cond ((not (zerop error)) 'cider-test-error-face)
+ ((not (zerop fail)) 'cider-test-failure-face)
+ (t 'cider-test-success-face)))
+ (concat (if (= 1 ns) ; ns count from summary
+ (cider-propertize (car (nrepl-dict-keys results)) 'ns)
+ (propertize (format "%d namespaces" ns) 'face 'default))
+ (propertize ": " 'face 'default))
+ test var fail error))))
+
+;;; Test definition highlighting
+;;
+;; On receipt of test results, failing/erring test definitions are highlighted.
+;; Highlights are cleared on the next report run, and may be cleared manually
+;; by the user.
+
+;; NOTE If keybindings specific to test sources are desired, it would be
+;; straightforward to turn this into a `cider-test-mode' minor mode, which we
+;; enable on test sources, much like the legacy `clojure-test-mode'. At present,
+;; though, there doesn't seem to be much value in this, since the report buffer
+;; provides the primary means of interacting with test results.
+
+(defun cider-test-highlight-problem (buffer test)
+ "Highlight the BUFFER test definition for the non-passing TEST."
+ (with-current-buffer buffer
+ ;; we don't need the file name here, as we always operate on the current
+ ;; buffer and the line data is correct even for vars that were
+ ;; defined interactively
+ (nrepl-dbind-response test (type line message expected actual)
+ (when line
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (search-forward "(" nil t)
+ (let ((beg (point)))
+ (forward-sexp)
+ (cider--make-overlay beg (point) 'cider-test
+ 'font-lock-face (cider-test-type-face type)
+ 'type type
+ 'help-echo message
+ 'message message
+ 'expected expected
+ 'actual actual)))))))
+
+(defun cider-find-var-file (ns var)
+ "Return the buffer visiting the file in which the NS VAR is defined.
+Or nil if not found."
+ (cider-ensure-op-supported "info")
+ (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
+ :group 'cider-test
+ :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
+
+(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
+ (when prompt-for-filters
+ (cider-test--prompt-for-selectors "Test selectors to include (space separated): ")))
+ (exclude-selectors
+ (when prompt-for-filters
+ (cider-test--prompt-for-selectors "Test selectors to exclude (space separated): "))))
+ (cider-map-repls :clj-strict
+ (lambda (conn)
+ (unless silent
+ (if (and tests (= (length tests) 1))
+ ;; we generate a different message when running individual tests
+ (cider-test-echo-running ns (car tests))
+ (cider-test-echo-running ns)))
+ (let ((request `("op" ,(cond ((stringp ns) "test")
+ ((eq :project ns) "test-all")
+ ((eq :loaded ns) "test-all")
+ ((eq :non-passing ns) "retest")))))
+ ;; we add optional parts of the request only when relevant
+ (when (and (listp include-selectors) include-selectors)
+ (setq request (append request `("include" ,include-selectors))))
+ (when (and (listp exclude-selectors) exclude-selectors)
+ (setq request (append request `("exclude" ,exclude-selectors))))
+ (when (stringp ns)
+ (setq request (append request `("ns" ,ns))))
+ (when (stringp ns)
+ (setq request (append request `("tests" ,tests))))
+ (when (or (stringp ns) (eq :project ns))
+ (setq request (append request `("load?" ,"true"))))
+ (cider-nrepl-send-request
+ request
+ (lambda (response)
+ (nrepl-dbind-response response (summary results status out err)
+ (cond ((member "namespace-not-found" status)
+ (unless silent
+ (message "No test namespace: %s" (cider-propertize ns 'ns))))
+ (out (cider-emit-interactive-eval-output out))
+ (err (cider-emit-interactive-eval-err-output err))
+ (results
+ (nrepl-dbind-response summary (error fail)
+ (setq cider-test-last-summary summary)
+ (setq cider-test-last-results results)
+ (cider-test-highlight-problems results)
+ (cider-test-echo-summary summary results)
+ (if (or (not (zerop (+ error fail)))
+ cider-test-show-report-on-success)
+ (cider-test-render-report
+ (cider-popup-buffer
+ cider-test-report-buffer
+ cider-auto-select-test-report-buffer)
+ summary
+ results)
+ (when (get-buffer cider-test-report-buffer)
+ (with-current-buffer cider-test-report-buffer
+ (let ((inhibit-read-only t))
+ (erase-buffer)))
+ (cider-test-render-report
+ cider-test-report-buffer
+ summary results))))))))
+ conn))))))
+
+(defun cider-test-rerun-failed-tests ()
+ "Rerun failed and erring tests from the last test run."
+ (interactive)
+ (if cider-test-last-summary
+ (nrepl-dbind-response cider-test-last-summary (fail error)
+ (if (not (zerop (+ error fail)))
+ (cider-test-execute :non-passing)
+ (message "No prior failures to retest")))
+ (message "No prior results to retest")))
+
+(defun cider-test-run-loaded-tests (prompt-for-filters)
+ "Run all tests defined in currently loaded namespaces.
+
+If PROMPT-FOR-FILTERS is non-nil, prompt the user for a test selectors to filter the tests with."
+ (interactive "P")
+ (cider-test-execute :loaded nil nil prompt-for-filters))
+
+(defun cider-test-run-project-tests (prompt-for-filters)
+ "Run all tests defined in all project namespaces, loading these as needed.
+
+If PROMPT-FOR-FILTERS is non-nil, prompt the user for a test selectors to filter the tests with."
+ (interactive "P")
+ (cider-test-execute :project nil nil prompt-for-filters))
+
+(defun cider-test-run-ns-tests-with-filters (suppress-inference)
+ "Run tests filtered by selectors for the current Clojure namespace context.
+
+With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the
+current ns."
+ (interactive "P")
+ (cider-test-run-ns-tests suppress-inference nil 't))
+
+(defun cider-test-run-ns-tests (suppress-inference &optional silent prompt-for-filters)
+ "Run all tests for the current Clojure namespace context.
+
+If SILENT is non-nil, suppress all messages other then test results.
+With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the
+current ns. If PROMPT-FOR-FILTERS is non-nil, prompt the user for
+test selectors to filter the tests with."
+ (interactive "P")
+ (if-let* ((ns (if suppress-inference
+ (cider-current-ns t)
+ (funcall cider-test-infer-test-ns (cider-current-ns t)))))
+ (cider-test-execute ns nil silent prompt-for-filters)
+ (if (eq major-mode 'cider-test-report-mode)
+ (when (y-or-n-p (concat "Test report does not define a namespace. "
+ "Rerun failed/erring tests?"))
+ (cider-test-rerun-failed-tests))
+ (unless silent
+ (message "No namespace to test in current context")))))
+
+(defvar cider-test-last-test-ns nil
+ "The ns of the last test ran with `cider-test-run-test'.")
+(defvar cider-test-last-test-var nil
+ "The var of the last test ran with `cider-test-run-test'.")
+
+(defun cider-test-update-last-test (ns var)
+ "Update the last test by setting NS and VAR.
+
+See `cider-test-rerun-test'."
+ (setq cider-test-last-test-ns ns
+ cider-test-last-test-var var))
+
+(defun cider-test-run-test ()
+ "Run the test at point.
+The test ns/var exist as text properties on report items and on highlighted
+failed/erred test definitions. When not found, a test definition at point
+is searched."
+ (interactive)
+ (let ((ns (get-text-property (point) 'ns))
+ (var (get-text-property (point) 'var)))
+ (if (and ns var)
+ ;; we're in a `cider-test-report-mode' buffer
+ ;; or on a highlighted failed/erred test definition
+ (progn
+ (cider-test-update-last-test ns var)
+ (cider-test-execute ns (list var)))
+ ;; we're in a `clojure-mode' buffer
+ (let* ((ns (clojure-find-ns))
+ (def (clojure-find-def)) ; it's a list of the form (deftest something)
+ (deftype (car def))
+ (var (cadr def)))
+ (if (and ns (member deftype cider-test-defining-forms))
+ (progn
+ (cider-test-update-last-test ns (list var))
+ (cider-test-execute ns (list var)))
+ (message "No test at point"))))))
+
+(defun cider-test-rerun-test ()
+ "Re-run the test that was previously ran."
+ (interactive)
+ (if (and cider-test-last-test-ns cider-test-last-test-var)
+ (cider-test-execute cider-test-last-test-ns cider-test-last-test-var)
+ (user-error "No test to re-run")))
+
+;;; Auto-test mode
+(defun cider--test-silently ()
+ "Like `cider-test-run-tests', but with less feedback.
+Only notify the user if there actually were any tests to run and only after
+the results are received."
+ (when (cider-connected-p)
+ (let ((cider-auto-select-test-report-buffer nil)
+ (cider-test-show-report-on-success nil))
+ (cider-test-run-ns-tests nil 'soft))))
+
+;;;###autoload
+(define-minor-mode cider-auto-test-mode
+ "Toggle automatic testing of Clojure files.
+
+When enabled this reruns tests every time a Clojure file is loaded.
+Only runs tests corresponding to the loaded file's namespace and does
+nothing if no tests are defined or if the file failed to load."
+ nil (cider-mode " Test") 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-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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 (symbol)
+ "Toggle var tracing for SYMBOL."
+ (thread-first `("op" "toggle-trace-var"
+ "ns" ,(cider-current-ns)
+ "sym" ,symbol)
+ (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-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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 'cider-compat)
+(require 'clojure-mode)
+(require 'nrepl-dict)
+
+(defalias 'cider-pop-back 'pop-tag-mark)
+
+(defcustom cider-font-lock-max-length 10000
+ "The max length of strings to fontify in `cider-font-lock-as'.
+
+Setting this to nil removes the fontification restriction."
+ :group 'cider
+ :type 'boolean
+ :package-version '(cider . "0.10.0"))
+
+(defun cider-util--hash-keys (hashtable)
+ "Return a list of keys in HASHTABLE."
+ (let ((keys '()))
+ (maphash (lambda (k _v) (setq keys (cons k keys))) hashtable)
+ keys))
+
+(defun cider-util--clojure-buffers ()
+ "Return a list of all existing `clojure-mode' buffers."
+ (seq-filter
+ (lambda (buffer) (with-current-buffer buffer (derived-mode-p 'clojure-mode)))
+ (buffer-list)))
+
+(defun cider-current-dir ()
+ "Return the directory of the current buffer."
+ (if buffer-file-name
+ (file-name-directory buffer-file-name)
+ default-directory))
+
+(defun cider-in-string-p ()
+ "Return non-nil if point is in a string."
+ (let ((beg (save-excursion (beginning-of-defun) (point))))
+ (nth 3 (parse-partial-sexp beg (point)))))
+
+(defun cider-in-comment-p ()
+ "Return non-nil if point is in a comment."
+ (let ((beg (save-excursion (beginning-of-defun) (point))))
+ (nth 4 (parse-partial-sexp beg (point)))))
+
+(defun cider--tooling-file-p (file-name)
+ "Return t if FILE-NAME is not a 'real' source file.
+Currently, only check if the relative file name starts with 'form-init'
+which nREPL uses for temporary evaluation file names."
+ (let ((fname (file-name-nondirectory file-name)))
+ (string-match-p "^form-init" fname)))
+
+(defun cider--cljc-buffer-p (&optional buffer)
+ "Return non-nil if the current buffer is visiting a cljc file.
+
+If BUFFER is provided act on that buffer instead."
+ (with-current-buffer (or buffer (current-buffer))
+ (or (derived-mode-p 'clojurec-mode))))
+
+\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
+ (end-of-defun)
+ (let ((end (point)))
+ (clojure-backward-logical-sexp 1)
+ (cider--text-or-limits bounds (point) end)))))
+
+(defun cider-ns-form ()
+ "Retrieve the ns form."
+ (when (clojure-find-ns)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (cider-defun-at-point))))
+
+(defun cider-symbol-at-point (&optional look-back)
+ "Return the name of the symbol at point, otherwise nil.
+Ignores the REPL prompt. If LOOK-BACK is non-nil, move backwards trying to
+find a symbol if there isn't one at point."
+ (or (when-let* ((str (thing-at-point 'symbol)))
+ (unless (text-property-any 0 (length str) 'field 'cider-repl-prompt str)
+ (substring-no-properties str)))
+ (when look-back
+ (save-excursion
+ (ignore-errors
+ (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-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)
+ (skip-chars-forward "[:blank:]")
+ (when (looking-at-p "\n") (forward-char 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
+
+(defalias 'cider--font-lock-ensure
+ (if (fboundp 'font-lock-ensure)
+ #'font-lock-ensure
+ (with-no-warnings
+ (lambda (&optional _beg _end)
+ (when font-lock-mode
+ (font-lock-fontify-buffer))))))
+
+(defalias 'cider--font-lock-flush
+ (if (fboundp 'font-lock-flush)
+ #'font-lock-flush
+ (with-no-warnings
+ (lambda (&optional _beg _end)
+ (when font-lock-mode
+ (font-lock-fontify-buffer))))))
+
+(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)
+ (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."
+ (cider-font-lock-as 'clojure-mode 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)))))
+
+(autoload 'pkg-info-version-info "pkg-info.el")
+
+(defvar cider-version)
+(defvar cider-codename)
+
+(defun cider--version ()
+ "Retrieve CIDER's version.
+A codename is added to stable versions."
+ (let ((version (condition-case nil
+ (pkg-info-version-info 'cider)
+ (error cider-version))))
+ (if (string-match-p "-snapshot" cider-version)
+ version
+ (format "%s (%s)" 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/en/%s/"
+ "The URL to CIDER's manual.")
+
+(defun cider--manual-version ()
+ "Convert the version to a ReadTheDocs-friendly version."
+ (if (string-match-p "-snapshot" cider-version)
+ "latest"
+ "stable"))
+
+(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/doc/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 "`\\(.*?\\)`"
+ "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!"
+ ,(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'."
+ (eval (nth (random (length cider-words-of-inspiration))
+ cider-words-of-inspiration)))
+
+(defvar cider-tips
+ '("Press <\\[cider-connect]> to connect to a running nREPL server."
+ "Press <\\[cider-quit]> to quit the current connection."
+ "Press <\\[cider-view-manual]> to view CIDER's manual."
+ "Press <\\[cider-view-refcard]> to view CIDER's refcard."
+ "Press <\\[describe-mode]> to see a list of the keybindings available (this will work in every Emacs buffer)."
+ "Press <\\[cider-repl-handle-shortcut]> to quickly invoke some REPL command."
+ "Press <\\[cider-switch-to-last-clojure-buffer]> to switch between the REPL and a Clojure source buffer."
+ "Press <\\[cider-doc]> to view the documentation for something (e.g. a var, a Java method)."
+ "Press <\\[cider-find-resource]> to find a resource on the classpath."
+ "Press <\\[cider-find-var]> to jump to the source of something (e.g. a var, a Java method)."
+ "Press <\\[cider-selector]> to quickly select a CIDER buffer."
+ "Press <\\[cider-test-run-ns-tests]> to run the tests for the current namespace."
+ "Press <\\[cider-test-run-loaded-tests]> to run all loaded tests."
+ "Press <\\[cider-test-run-project-tests]> to run all tests for the current project."
+ "Press <\\[cider-apropos]> to look for a symbol by some search string."
+ "Press <\\[cider-apropos-documentation]> to look for a symbol that has some string in its docstring."
+ "Press <\\[cider-eval-defun-at-point]> to eval the top-level form at point."
+ "Press <\\[cider-eval-defun-up-to-point]> to eval the top-level form up to the point."
+ "Press <\\[cider-eval-sexp-up-to-point]> to eval the current form up to the point."
+ "Press <\\[cider-eval-sexp-at-point]> to eval the current form around the point."
+ "Press <\\[cider-eval-sexp-at-point-in-context]> to eval the current form around the point in a user-provided context."
+ "Press <\\[cider-eval-buffer]> to eval the entire source buffer."
+ "Press <\\[cider-scratch]> to create a Clojure scratchpad. Pretty handy for prototyping."
+ "Press <\\[cider-read-and-eval]> to evaluate some Clojure expression directly in the minibuffer."
+ "Press <\\[cider-drink-a-sip]> to get more CIDER tips."
+ "Press <\\[cider-browse-ns-all]> to start CIDER's namespace browser."
+ "Press <\\[cider-classpath]> to start CIDER's classpath browser."
+ "Press <\\[cider-repl-history]> to start CIDER's REPL input history browser."
+ "Press <\\[cider-macroexpand-1]> to expand the preceding macro."
+ "Press <\\[cider-inspect]> to inspect the preceding expression's result."
+ "Press <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)
+ (`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))
+
+(defcustom cider-jdk-src-paths '("/usr/lib/jvm/openjdk-8/src.zip")
+ "Used by `cider-stacktrace-navigate'.
+Zip/jar files work, but it's better to extract them and put the directory
+paths here. Clojure sources here:
+https://repo1.maven.org/maven2/org/clojure/clojure/1.8.0/."
+ :group 'cider
+ :package-version '(cider . "0.17.0")
+ :type '(list string))
+
+(defun cider-resolve-java-class (class)
+ "Return a path to a Java source file that corresponds to CLASS.
+
+This will be a zip/jar path for archived sources and a normal
+file path otherwise."
+ (when class
+ (let ((file-name (concat (replace-regexp-in-string "\\." "/" class) ".java")))
+ (cl-find-if
+ 'file-exists-p
+ (mapcar
+ (lambda (d)
+ (cond ((file-directory-p d)
+ (expand-file-name file-name d))
+ ((and (file-exists-p d)
+ (member (file-name-extension d) '("jar" "zip")))
+ (format "zip:file:%s!/%s" d file-name))
+ (t (error "Unexpected archive: %s" d))))
+ cider-jdk-src-paths)))))
+
+(provide 'cider-util)
+
+;;; cider-util.el ends here
--- /dev/null
+;;; cider.el --- Clojure Interactive Development Environment that Rocks -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+;; Maintainer: Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; URL: http://www.github.com/clojure-emacs/cider
+;; Version: 0.19.0-snapshot
+;; Package-Requires: ((emacs "25") (clojure-mode "5.9") (pkg-info "0.4") (queue "0.2") (spinner "1.7") (seq "2.16") (sesman "0.3.2"))
+;; 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.
+
+;;; Installation:
+
+;; Available as a package in melpa.org and stable.melpa.org
+
+;; (add-to-list 'package-archives
+;; '("melpa" . "https://melpa.org/packages/"))
+;;
+;; or
+;;
+;; (add-to-list 'package-archives
+;; '("melpa-stable" . "https://stable.melpa.org/packages/") t)
+;;
+;; M-x package-install cider
+
+;;; Usage:
+
+;; 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 "Online Manual" "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-compat)
+(require 'cider-debug)
+(require 'cider-util)
+
+(require 'tramp-sh)
+(require 'subr-x)
+(require 'seq)
+(require 'sesman)
+
+(defconst cider-version "0.19.0-snapshot"
+ "Fallback version used when it cannot be extracted automatically.
+Normally it won't be used, unless `pkg-info' fails to extract the
+version from the CIDER package or library.")
+
+(defconst cider-codename "Saigon"
+ "Codename used to denote stable releases.")
+
+(defcustom cider-lein-command
+ "lein"
+ "The command used to execute Leiningen."
+ :type 'string
+ :group 'cider)
+
+(defcustom cider-lein-global-options
+ nil
+ "Command global options used to execute Leiningen (e.g.: -o for offline)."
+ :type 'string
+ :group 'cider
+ :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
+ :group 'cider
+ :safe #'stringp)
+
+(defcustom cider-boot-command
+ "boot"
+ "The command used to execute Boot."
+ :type 'string
+ :group 'cider
+ :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
+ :group 'cider
+ :safe #'stringp
+ :package-version '(cider . "0.14.0"))
+
+(defcustom cider-boot-parameters
+ "cider.tasks/nrepl-server -b localhost wait"
+ "Params passed to boot to start an nREPL server via `cider-jack-in'."
+ :type 'string
+ :group 'cider
+ :safe #'stringp
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-clojure-cli-command
+ "clojure"
+ "The command used to execute clojure with tools.deps (requires Clojure 1.9+).
+Don't use clj here, as it doesn't work when spawned from Emacs due to
+it using rlwrap."
+ :type 'string
+ :group 'cider
+ :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
+ :group 'cider
+ :safe #'stringp
+ :package-version '(cider . "0.17.0"))
+
+(defcustom cider-clojure-cli-parameters
+ "-m nrepl.cmdline --middleware '%s'"
+ "Params passed to clojure to start an nREPL server via `cider-jack-in'.
+This is evaluated using `format', with the first argument being the Clojure
+vector of middleware variables as a string."
+ :type 'string
+ :group 'cider
+ :safe #'stringp
+ :package-version '(cider . "0.17.0"))
+
+(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
+ :group 'cider
+ :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
+ :group 'cider
+ :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
+ :group 'cider
+ :safe #'stringp
+ :package-version '(cider . "0.17.0"))
+
+(defcustom cider-gradle-command
+ "gradle"
+ "The command used to execute Gradle."
+ :type 'string
+ :group 'cider
+ :safe #'stringp
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-gradle-global-options
+ "--no-daemon"
+ "Command line options used to execute Gradle (e.g.: -m for dry run)."
+ :type 'string
+ :group 'cider
+ :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
+ :group 'cider
+ :safe #'stringp
+ :package-version '(cider . "0.10.0"))
+
+(define-obsolete-variable-alias 'cider-default-repl-command 'cider-jack-in-default)
+(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))
+ :group 'cider
+ :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 :tag "Always ask" nil))
+ :group 'cider
+ :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))
+ :group 'cider
+ :safe #'stringp
+ :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")))
+ :group 'cider)
+
+(defcustom cider-connected-hook nil
+ "List of functions to call when connected to Clojure nREPL server."
+ :type 'hook
+ :group 'cider
+ :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
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-inject-dependencies-at-jack-in t
+ "When nil, do not inject repl dependencies (most likely nREPL middlewares) at `cider-jack-in' time."
+ :type 'boolean
+ :safe #'booleanp
+ :version '(cider . "0.11.0"))
+
+(defcustom cider-offer-to-open-cljs-app-in-browser t
+ "When nil, do not offer to open ClojureScript apps in a browser on connect."
+ :type 'boolean
+ :safe #'booleanp
+ :version '(cider . "0.15.0"))
+
+(defvar cider-ps-running-nrepls-command "ps u | grep leiningen"
+ "Process snapshot command used in `cider-locate-running-nrepl-ports'.")
+
+(defvar cider-ps-running-nrepl-path-regexp-list
+ '("\\(?:leiningen.original.pwd=\\)\\(.+?\\) -D"
+ "\\(?:-classpath +:?\\(.+?\\)/self-installs\\)")
+ "Regexp list to get project paths.
+Extract project paths from output of `cider-ps-running-nrepls-command'.
+Sub-match 1 must be the project path.")
+
+(defvar cider-host-history nil
+ "Completion history for connection hosts.")
+
+;;;###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)
+ ('shadow-cljs cider-shadow-cljs-command)
+ ('gradle cider-gradle-command)
+ (_ (user-error "Unsupported project type `%S'" project-type))))
+
+(defun cider-jack-in-resolve-command (project-type)
+ "Determine the resolved file path to `cider-jack-in-command'.
+Throws an error if PROJECT-TYPE is unknown."
+ (pcase project-type
+ ('lein (cider--resolve-command cider-lein-command))
+ ('boot (cider--resolve-command cider-boot-command))
+ ('clojure-cli (cider--resolve-command cider-clojure-cli-command))
+ ;; 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)) " "))))
+ ('gradle (cider--resolve-command cider-gradle-command))
+ (_ (user-error "Unsupported project type `%S'" project-type))))
+
+(defun cider-jack-in-global-options (project-type)
+ "Determine the command line options for `cider-jack-in' for the PROJECT-TYPE."
+ (pcase project-type
+ ('lein cider-lein-global-options)
+ ('boot cider-boot-global-options)
+ ('clojure-cli cider-clojure-cli-global-options)
+ ('shadow-cljs cider-shadow-cljs-global-options)
+ ('gradle cider-gradle-global-options)
+ (_ (user-error "Unsupported project type `%S'" project-type))))
+
+(defun cider-jack-in-params (project-type)
+ "Determine the commands params for `cider-jack-in' for the PROJECT-TYPE."
+ (pcase project-type
+ ('lein cider-lein-parameters)
+ ('boot cider-boot-parameters)
+ ('clojure-cli (format cider-clojure-cli-parameters
+ (concat
+ "["
+ (mapconcat
+ (apply-partially #'format "\"%s\"")
+ (cider-jack-in-normalized-nrepl-middlewares)
+ ", ")
+ "]")))
+ ('shadow-cljs cider-shadow-cljs-parameters)
+ ('gradle cider-gradle-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)
+;; We inject the newest known version of nREPL just in case
+;; your version of Boot or Leiningen is bundling an older one.
+(cider-add-to-alist 'cider-jack-in-dependencies
+ "nrepl" "0.4.5")
+
+(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.3.10")
+
+(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)
+(cider-add-to-alist 'cider-jack-in-dependencies-exclusions
+ "org.clojure/tools.nrepl" '("org.clojure/clojure"))
+
+(defconst cider-clojure-artifact-id "org.clojure/clojure"
+ "Artifact identifier for Clojure.")
+
+(defconst cider-minimum-clojure-version "1.8.0"
+ "Minimum supported version of Clojure.")
+
+(defconst cider-latest-clojure-version "1.10.0"
+ "Latest supported version of Clojure.")
+
+(defconst cider-required-middleware-version "0.18.0"
+ "The minimum CIDER nREPL version that's known to work properly with CIDER.")
+
+(defconst cider-latest-middleware-version "0.19.0-SNAPSHOT"
+ "The latest CIDER nREPL version that's known to work properly with CIDER.")
+
+(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 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)
+(cider-add-to-alist 'cider-jack-in-lein-plugins
+ "cider/cider-nrepl" cider-latest-middleware-version)
+
+(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."
+ (thread-last cider-jack-in-lein-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-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 plugins middlewares)
+ "Create boot jack-in dependencies.
+Does so by concatenating GLOBAL-OPTS, DEPENDENCIES,
+PLUGINS and MIDDLEWARES. PARAMS and MIDDLEWARES are passed on to
+`cider-boot-middleware-task` before concatenating and DEPENDENCIES and PLUGINS
+ 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 dependencies plugins))
+ (cider-boot-middleware-task 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)
+ "Create lein jack-in dependencies.
+Does so by concatenating GLOBAL-OPTS, DEPENDENCIES, with DEPENDENCIES-EXCLUSIONS
+removed, LEIN-PLUGINS, 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))
+ " -- ")
+ " -- "
+ params))
+
+(defun cider-clojure-cli-jack-in-dependencies (global-opts params dependencies)
+ "Create Clojure tools.deps jack-in dependencies.
+Does so by concatenating GLOBAL-OPTS, DEPENDENCIES finally PARAMS."
+ (let ((dependencies (append dependencies cider-jack-in-lein-plugins)))
+ (concat
+ global-opts
+ (unless (seq-empty-p global-opts) " ")
+ "-Sdeps '{:deps {"
+ (mapconcat #'identity
+ (seq-map (lambda (dep) (format "%s {:mvn/version \"%s\"}" (car dep) (cadr dep))) dependencies)
+ " ")
+ "}}' "
+ 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 dependencies cider-jack-in-lein-plugins)))
+ (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)
+ "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. 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
+ cider-jack-in-dependencies)
+ cider-jack-in-dependencies-exclusions
+ (cider-jack-in-normalized-lein-plugins)))
+ ('boot (cider-boot-jack-in-dependencies
+ global-opts
+ params
+ (cider-add-clojure-dependencies-maybe
+ cider-jack-in-dependencies)
+ (cider-jack-in-normalized-lein-plugins)
+ (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)))
+ ('shadow-cljs (cider-shadow-cljs-jack-in-dependencies
+ global-opts
+ params
+ (cider-add-clojure-dependencies-maybe
+ cider-jack-in-dependencies)))
+ ('gradle (concat
+ global-opts
+ (unless (seq-empty-p global-opts) " ")
+ 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-verify-clojurescript-is-present ()
+ "Check whether ClojureScript is present."
+ (unless (cider-library-present-p "clojure/clojurescript")
+ (user-error "ClojureScript is not available. See https://docs.cider.mx/en/latest/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.3.x (aka cider/piggieback) is not available. See https://docs.cider.mx/en/latest/clojurescript for details")))
+
+(defun cider-check-nashorn-requirements ()
+ "Check whether we can start a Nashorn ClojureScript REPL."
+ (cider-verify-piggieback-is-present))
+
+(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/figwheel-sidecar")
+ (user-error "Figwheel-sidecar is not available. Please check https://docs.cider.mx/en/latest/clojurescript")))
+
+(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 "bhauman/figwheel-main")
+ (user-error "Figwheel-main is not available. Please check https://docs.cider.mx/en/latest/clojurescript")))
+
+(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/weasel")
+ (user-error "Weasel in not available. Please check https://docs.cider.mx/en/latest/clojurescript/#browser-connected-clojurescript-repl")))
+
+(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")))
+
+(defun cider-check-shadow-cljs-requirements ()
+ "Check whether we can start a shadow-cljs REPL."
+ (unless (cider-library-present-p "thheller/shadow-cljs")
+ (user-error "The shadow-cljs ClojureScript REPL is not available")))
+
+(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))
+ options
+ (concat ":" options)))
+
+(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-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
+ (read-from-minibuffer "Select shadow-cljs build (e.g. dev): "))))
+ (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* ((form "(do (require '[shadow.cljs.devtools.api :as shadow]) (shadow/watch %s) (shadow/nrepl-select %s))")
+ (options (or cider-shadow-default-options
+ (read-from-minibuffer "Select shadow-cljs build (e.g. dev): ")))
+ (build (cider-normalize-cljs-init-options options)))
+ (format form build 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-init-form ()
+ "Produce the figwheel-main ClojureScript init form."
+ (let ((form "(do (require 'figwheel.main) (figwheel.main/start %s))")
+ (options (string-trim
+ (or cider-figwheel-main-default-options
+ (read-from-minibuffer "Select figwheel-main build (e.g. :dev): ")))))
+ (format form (cider-normalize-cljs-init-options options))))
+
+(defun cider-custom-cljs-repl-init-form ()
+ "Prompt for a form that would start a ClojureScript REPL.
+The supplied string will be wrapped in a do form if needed."
+ (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
+ '((nashorn "(do (require 'cljs.repl.nashorn) (cider.piggieback/cljs-repl (cljs.repl.nashorn/repl-env)))"
+ cider-check-nashorn-requirements)
+ (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)
+ (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)
+ (custom cider-custom-cljs-repl-init-form nil))
+ "A list of supported ClojureScript REPLs.
+
+For each one we have its name, the form we need to evaluate in a Clojure
+REPL to start the ClojureScript REPL and functions to very their requirements.
+
+The form should be either a string or a function producing a string.")
+
+(defun cider-register-cljs-repl-type (type init-form &optional 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 - 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 (stringp init-form) (symbolp init-form))
+ (user-error "The init form must be a string or a symbol referring to a function"))
+ (unless (or (null requirements-fn) (symbolp requirements-fn))
+ (user-error "The requirements-fn must be a symbol referring to a function"))
+ (add-to-list 'cider-cljs-repl-types (list type init-form requirements-fn)))
+
+(defcustom cider-default-cljs-repl nil
+ "The default ClojureScript REPL to start.
+This affects commands like `cider-jack-in-cljs'. Generally it's
+intended to be set via .dir-locals.el for individual projects, as its
+relatively unlikely you'd like to use the same type of REPL in each project
+you're working on."
+ :type '(choice (const :tag "Nashorn" nashorn)
+ (const :tag "Figwheel" figwheel)
+ (const :tag "Figwheel Main" figwheel-main)
+ (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 "Custom" custom))
+ :group 'cider
+ :safe #'symbolp
+ :package-version '(cider . "0.17.0"))
+
+(make-obsolete-variable 'cider-cljs-lein-repl 'cider-default-cljs-repl "0.17")
+(make-obsolete-variable 'cider-cljs-boot-repl 'cider-default-cljs-repl "0.17")
+(make-obsolete-variable 'cider-cljs-gradle-repl 'cider-default-cljs-repl "0.17")
+
+(defvar cider--select-cljs-repl-history nil)
+(defun cider-select-cljs-repl (&optional default)
+ "Select the ClojureScript REPL to use with `cider-jack-in-cljs'.
+DEFAULT is the default ClojureScript REPL to offer in completion."
+ (let ((repl-types (mapcar #'car cider-cljs-repl-types)))
+ (intern (completing-read "Select ClojureScript REPL type: " repl-types
+ nil nil nil 'cider--select-cljs-repl-history
+ (or default (car cider--select-cljs-repl-history))))))
+
+(defun cider-cljs-repl-form (repl-type)
+ "Get the cljs REPL form for REPL-TYPE."
+ (if-let* ((repl-form (cadr (seq-find
+ (lambda (entry)
+ (eq (car entry) repl-type))
+ cider-cljs-repl-types))))
+ ;; 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 "C-j j") #'cider-jack-in-clj)
+ (define-key map (kbd "C-j s") #'cider-jack-in-cljs)
+ (define-key map (kbd "C-j m") #'cider-jack-in-clj&cljs)
+ (define-key map (kbd "C-j C-j") #'cider-jack-in-clj)
+ (define-key map (kbd "C-j C-s") #'cider-jack-in-cljs)
+ (define-key map (kbd "C-j C-m") #'cider-jack-in-clj&cljs)
+ (define-key map (kbd "c j") #'cider-connect-clj)
+ (define-key map (kbd "c s") #'cider-connect-cljs)
+ (define-key map (kbd "c m") #'cider-connect-clj&cljs)
+ (define-key map (kbd "C-c j") #'cider-connect-clj)
+ (define-key map (kbd "C-c s") #'cider-connect-cljs)
+ (define-key map (kbd "C-c m") #'cider-connect-clj&cljs)
+ (define-key map (kbd "C-c C-j") #'cider-connect-clj)
+ (define-key map (kbd "C-c C-s") #'cider-connect-cljs)
+ (define-key map (kbd "C-c C-m") #'cider-connect-clj&cljs)
+ (define-key map (kbd "s j") #'cider-connect-sibling-clj)
+ (define-key map (kbd "s s") #'cider-connect-sibling-cljs)
+ (define-key map (kbd "C-s j") #'cider-connect-sibling-clj)
+ (define-key map (kbd "C-s s") #'cider-connect-sibling-cljs)
+ (define-key map (kbd "C-s C-j") #'cider-connect-sibling-clj)
+ (define-key map (kbd "C-s C-s") #'cider-connect-sibling-cljs)
+ map)
+ "CIDER jack-in and connect keymap.")
+
+;;;###autoload
+(defun cider-jack-in-clj (params)
+ "Start an nREPL server for the current project and connect to it.
+PARAMS is a plist optionally containing :project-dir and :jack-in-cmd.
+With the prefix argument, prompt for all these parameters."
+ (interactive "P")
+ (let ((params (thread-first params
+ (cider--update-project-dir)
+ (cider--check-existing-session)
+ (cider--update-jack-in-cmd))))
+ (nrepl-start-server-process
+ (plist-get params :project-dir)
+ (plist-get params :jack-in-cmd)
+ (lambda (server-buffer)
+ (cider-connect-sibling-clj params server-buffer)))))
+
+;;;###autoload
+(defun cider-jack-in-cljs (params)
+ "Start an nREPL server for the current project and connect to it.
+PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and
+:cljs-repl-type (e.g. Node, Figwheel, etc). With the prefix argument,
+prompt for all these parameters."
+ (interactive "P")
+ (let ((cider-jack-in-dependencies (append cider-jack-in-dependencies cider-jack-in-cljs-dependencies))
+ (cider-jack-in-lein-plugins (append cider-jack-in-lein-plugins cider-jack-in-cljs-lein-plugins))
+ (cider-jack-in-nrepl-middlewares (append cider-jack-in-nrepl-middlewares cider-jack-in-cljs-nrepl-middlewares))
+ (orig-buffer (current-buffer)))
+ ;; cider--update-jack-in-cmd relies indirectly on the above dynamic vars
+ (let ((params (thread-first params
+ (cider--update-project-dir)
+ (cider--check-existing-session)
+ (cider--update-jack-in-cmd))))
+ (nrepl-start-server-process
+ (plist-get params :project-dir)
+ (plist-get params :jack-in-cmd)
+ (lambda (server-buffer)
+ (with-current-buffer orig-buffer
+ (cider-connect-sibling-cljs params server-buffer)))))))
+
+;;;###autoload
+(defun cider-jack-in-clj&cljs (&optional params soft-cljs-start)
+ "Start an nREPL server and connect with clj and cljs REPLs.
+PARAMS is a plist optionally containing :project-dir, :jack-in-cmd and
+:cljs-repl-type (e.g. Node, Figwheel, etc). With the prefix argument,
+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 nil 'ensure)))
+ (other-params (cider--gather-connect-params nil other-repl))
+ (ses-name (unless (nrepl-server-p other-repl)
+ (sesman-session-name-for-object 'CIDER other-repl))))
+ (thread-first params
+ (cider--update-do-prompt)
+ (append other-params)
+ (plist-put :repl-init-function nil)
+ (plist-put :repl-type "clj")
+ (plist-put :session-name ses-name)))))
+
+;;;###autoload
+(defun cider-connect-sibling-cljs (params &optional other-repl)
+ "Create a ClojureScript REPL with the same server as OTHER-REPL.
+PARAMS is a plist optionally containing :cljs-repl-type (e.g. Node,
+Figwheel, etc). All other parameters are inferred from the OTHER-REPL.
+OTHER-REPL defaults to `cider-current-repl' but in programs can also be a
+server buffer, in which case a new session for that server is created."
+ (interactive "P")
+ (let* ((other-repl (or other-repl (cider-current-repl nil 'ensure)))
+ (other-params (cider--gather-connect-params nil other-repl))
+ (ses-name (unless (nrepl-server-p other-repl)
+ (sesman-session-name-for-object 'CIDER other-repl))))
+ (cider-nrepl-connect
+ (thread-first params
+ (cider--update-do-prompt)
+ (append other-params)
+ (cider--update-cljs-type)
+ (cider--update-cljs-init-function)
+ (plist-put :session-name ses-name)
+ (plist-put :repl-type "pending-cljs")))))
+
+;;;###autoload
+(defun cider-connect-clj (&optional params)
+ "Initialize a Clojure connection to an nREPL server.
+PARAMS is a plist optionally containing :host, :port and :project-dir. On
+prefix argument, prompt for all the parameters."
+ (interactive "P")
+ (cider-nrepl-connect
+ (thread-first params
+ (cider--update-project-dir)
+ (cider--update-host-port)
+ (cider--check-existing-session)
+ (plist-put :repl-init-function nil)
+ (plist-put :session-name nil)
+ (plist-put :repl-type "clj"))))
+
+;;;###autoload
+(defun cider-connect-cljs (&optional params)
+ "Initialize a ClojureScript connection to an nREPL server.
+PARAMS is a plist optionally containing :host, :port, :project-dir and
+:cljs-repl-type (e.g. Node, Figwheel, etc). On prefix, prompt for all the
+parameters regardless of their supplied or default values."
+ (interactive "P")
+ (cider-nrepl-connect
+ (thread-first params
+ (cider--update-project-dir)
+ (cider--update-host-port)
+ (cider--check-existing-session)
+ (cider--update-cljs-type)
+ (cider--update-cljs-init-function)
+ (plist-put :session-name nil)
+ (plist-put :repl-type "pending-cljs"))))
+
+;;;###autoload
+(defun cider-connect-clj&cljs (params &optional soft-cljs-start)
+ "Initialize a Clojure and ClojureScript connection to an nREPL server.
+PARAMS is a plist optionally containing :host, :port, :project-dir and
+:cljs-repl-type (e.g. Node, Figwheel, etc). When SOFT-CLJS-START is
+non-nil, don't start if ClojureScript requirements are not met."
+ (interactive "P")
+ (let* ((params (thread-first params
+ (cider--update-project-dir)
+ (cider--update-host-port)
+ (cider--check-existing-session)
+ (cider--update-cljs-type)))
+ (clj-repl (cider-connect-clj params)))
+ (if soft-cljs-start
+ (when (cider--check-cljs (plist-get params :cljs-repl-type) 'no-error)
+ (cider-connect-sibling-cljs params clj-repl))
+ (cider-connect-sibling-cljs params clj-repl))))
+
+(defvar cider-connection-init-commands
+ '(cider-jack-in-clj
+ cider-jack-in-cljs
+ cider-jack-in-clj&cljs
+ cider-connect-clj
+ cider-connect-cljs
+ cider-connect-clj&cljs
+ cider-connect-sibling-clj
+ cider-connect-sibling-cljs)
+ "A list of all user-level connection init commands in CIDER.")
+
+;;;###autoload
+(defun cider ()
+ "Start a connection of any type interactively."
+ (interactive)
+ (when-let* ((command (intern (completing-read "Select command: " cider-connection-init-commands))))
+ (call-interactively command)))
+
+\f
+;;; PARAMS updating
+
+(defun cider--update-do-prompt (params)
+ "Update :do-prompt in PARAMS."
+ (if (equal params '(4))
+ (list :do-prompt t)
+ params))
+
+(defun cider--update-project-dir (params)
+ "Update :project-dir in PARAMS."
+ (let* ((params (cider--update-do-prompt params))
+ (proj-dir (if (plist-get params :do-prompt)
+ (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)))))))
+
+(defun cider--update-jack-in-cmd (params)
+ "Update :jack-in-cmd key in PARAMS."
+ (let* ((params (cider--update-do-prompt params))
+ (project-dir (plist-get params :project-dir))
+ (project-type (cider-project-type project-dir))
+ (command (cider-jack-in-command project-type))
+ (command-resolved (cider-jack-in-resolve-command project-type))
+ (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 (format "nREPL server command: %s " command-params)
+ command-params)
+ command-params))
+ (cmd-params (if cider-inject-dependencies-at-jack-in
+ (cider-inject-jack-in-dependencies command-global-opts command-params project-type)
+ 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)
+ (y-or-n-p "Are you sure you want to run `cider-jack-in' without a Clojure project? ")))
+ (let* ((cmd (format "%s %s" command-resolved cmd-params)))
+ (plist-put params :jack-in-cmd cmd)))
+ (user-error "`cider-jack-in' is not allowed without a Clojure project"))))
+ (user-error "The %s executable isn't on your `exec-path'" command))))
+
+(defun cider--update-host-port (params)
+ "Update :host and :port 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)))))
+ (thread-first params
+ (plist-put :host (car endpoint))
+ (plist-put :port (cdr endpoint))))))
+
+(defun cider--update-cljs-init-function (params)
+ "Update PARAMS :repl-init-function for cljs connections."
+ (with-current-buffer (or (plist-get params :--context-buffer)
+ (current-buffer))
+ (let ((cljs-type (plist-get params :cljs-repl-type)))
+ (plist-put params :repl-init-function
+ (lambda ()
+ (cider--check-cljs cljs-type)
+ ;; FIXME: ideally this should be done in the state handler
+ (setq-local cider-cljs-repl-type cljs-type)
+ (cider-nrepl-send-request
+ (list "op" "eval"
+ "ns" (cider-current-ns)
+ "code" (cider-cljs-repl-form cljs-type))
+ (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)))))))
+
+(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 session with the same parameters exists (" (car session) "). "
+ "You can connect a sibling instead. Proceed? "))
+ (let ((debug-on-quit nil))
+ (signal 'quit nil)))))
+ params)
+
+\f
+;;; Aliases
+
+ ;;;###autoload
+(defalias 'cider-jack-in #'cider-jack-in-clj)
+ ;;;###autoload
+(defalias 'cider-jack-in-clojure #'cider-jack-in-clj)
+;;;###autoload
+(defalias 'cider-jack-in-clojurescript #'cider-jack-in-cljs)
+
+;;;###autoload
+(defalias 'cider-connect #'cider-connect-clj)
+;;;###autoload
+(defalias 'cider-connect-clojure #'cider-connect-clj)
+;;;###autoload
+(defalias 'cider-connect-clojurescript #'cider-connect-cljs)
+
+;;;###autoload
+(defalias 'cider-connect-sibling-clojure #'cider-connect-sibling-clj)
+;;;###autoload
+(defalias 'cider-connect-sibling-clojurescript #'cider-connect-sibling-cljs)
+
+\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")))))
+ (sel-host (cider--completing-read-host hosts))
+ (host (car sel-host))
+ (port (or (cadr sel-host)
+ (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)))))
+
+(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)))
+ (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-locate-running-nrepl-ports (&optional dir)
+ "Locate ports of running nREPL servers.
+When DIR is non-nil also look for nREPL port files in DIR. Return a list
+of list of the form (project-dir port)."
+ (let* ((paths (cider--running-nrepl-paths))
+ (proj-ports (mapcar (lambda (d)
+ (when-let* ((port (and d (nrepl-extract-port (cider--file-path d)))))
+ (list (file-name-nondirectory (directory-file-name d)) port)))
+ (cons (clojure-project-dir dir) paths))))
+ (seq-uniq (delq nil proj-ports))))
+
+(defun cider--running-nrepl-paths ()
+ "Retrieve project paths of running nREPL servers.
+Use `cider-ps-running-nrepls-command' and `cider-ps-running-nrepl-path-regexp-list'."
+ (let (paths)
+ (with-temp-buffer
+ (insert (shell-command-to-string cider-ps-running-nrepls-command))
+ (dolist (regexp cider-ps-running-nrepl-path-regexp-list)
+ (goto-char 1)
+ (while (re-search-forward regexp nil t)
+ (setq paths (cons (match-string 1) paths)))))
+ (seq-uniq paths)))
+
+(defun cider--identify-buildtools-present (&optional project-dir)
+ "Identify build systems present by their build files in PROJECT-DIR.
+PROJECT-DIR defaults to current project."
+ (let* ((default-directory (or project-dir (clojure-project-dir (cider-current-dir))))
+ (build-files '((lein . "project.clj")
+ (boot . "build.boot")
+ (clojure-cli . "deps.edn")
+ (shadow-cljs . "shadow-cljs.edn")
+ (gradle . "build.gradle"))))
+ (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)))))
+
+
+;; 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)))
+
+;;;###autoload
+(with-eval-after-load 'clojure-mode
+ (define-key clojure-mode-map (kbd "C-c M-x") #'cider)
+ (define-key clojure-mode-map (kbd "C-c M-j") #'cider-jack-in-clj)
+ (define-key clojure-mode-map (kbd "C-c M-J") #'cider-jack-in-cljs)
+ (define-key clojure-mode-map (kbd "C-c M-c") #'cider-connect-clj)
+ (define-key clojure-mode-map (kbd "C-c M-C") #'cider-connect-cljs)
+ (define-key clojure-mode-map (kbd "C-c C-x") 'cider-start-map)
+ (define-key clojure-mode-map (kbd "C-c C-s") 'sesman-map)
+ (require 'sesman)
+ (sesman-install-menu clojure-mode-map)
+ (add-hook 'clojure-mode-hook (lambda () (setq-local sesman-system 'CIDER))))
+
+(provide 'cider)
+
+;;; cider.el ends here
--- /dev/null
+;;; nrepl-client.el --- Client for Clojure nREPL -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.am@gmail.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 leiningen or boot). 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 'cider-compat)
+(require 'cl-lib)
+(require 'nrepl-dict)
+(require 'queue)
+(require 'tramp)
+
+\f
+;;; 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
+ :group 'nrepl)
+
+(defcustom nrepl-disconnected-hook nil
+ "List of functions to call when disconnected from the nREPL server."
+ :type 'hook
+ :group 'nrepl)
+
+(defcustom nrepl-file-loaded-hook nil
+ "List of functions to call when a load file has completed."
+ :type 'hook
+ :group 'nrepl)
+
+(defcustom nrepl-force-ssh-for-remote-hosts nil
+ "If non-nil, do not attempt a direct connection for remote hosts."
+ :type 'boolean
+ :group 'nrepl)
+
+(defcustom nrepl-use-ssh-fallback-for-remote-hosts nil
+ "If non-nil, attempt to connect via ssh to remote hosts when unable to connect directly."
+ :type 'boolean
+ :group 'nrepl)
+
+(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
+ :group 'nrepl)
+
+(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
+ :group 'nrepl)
+
+\f
+;;; 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
+ "Auxillary information received from the describe op.")
+
+\f
+;;; 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*")
+
+(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-hidden-name
+ (nrepl-make-buffer-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-hidden-name
+ (nrepl-make-buffer-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))
+
+\f
+;;; 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 .nrepl-port, nrepl-port or target/repl-port files in directory DIR."
+ (or (nrepl--port-from-file (expand-file-name "repl-port" dir))
+ (nrepl--port-from-file (expand-file-name ".nrepl-port" dir))
+ (nrepl--port-from-file (expand-file-name "target/repl-port" dir))
+ (nrepl--port-from-file (expand-file-name ".shadow-cljs/nrepl.port" dir))))
+
+(defun nrepl--port-from-file (file)
+ "Attempts to read port from a file named by FILE."
+ (when (file-exists-p file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (buffer-string))))
+
+\f
+;;; 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))
+ ;; handle both \n\r and \r\n
+ (result (replace-regexp-in-string "\r\n\\|\n\r" "\n" original))
+ ;; we don't handle single carriage returns, insert newline
+ (result (replace-regexp-in-string "\r" "\n" result)))
+ (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-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-temp-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))
+ (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))))
+
+\f
+;;; 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 behaviour of the callbacks. Errors signaled by these
+functions are demoted to messages, so that they don't prevent the
+callbacks from running.")
+
+(defun nrepl-client-filter (proc string)
+ "Decode message(s) from PROC contained in STRING and dispatch them."
+ (let ((string-q (process-get proc :string-q)))
+ (queue-enqueue string-q string)
+ ;; Start decoding only if the last letter is 'e'
+ (when (eq ?e (aref string (1- (length string))))
+ (let ((response-q (process-get proc :response-q)))
+ (nrepl-bdecode string-q response-q)
+ (while (queue-head response-q)
+ (with-current-buffer (process-buffer proc)
+ (let ((response (queue-dequeue response-q)))
+ (with-demoted-errors "Error in one of the `nrepl-response-handler-functions': %s"
+ (run-hook-with-args 'nrepl-response-handler-functions response))
+ (nrepl--dispatch-response response))))))))
+
+(defun nrepl--dispatch-response (response)
+ "Dispatch the RESPONSE to associated callback.
+First we check the callbacks of pending requests. If no callback was found,
+we check the completed requests, since responses could be received even for
+older requests with \"done\" status."
+ (nrepl-dbind-response response (id)
+ (nrepl-log-message response 'response)
+ (let ((callback (or (gethash id nrepl-pending-requests)
+ (gethash id nrepl-completed-requests))))
+ (if callback
+ (funcall callback response)
+ (error "[nREPL] No response handler with id %s found" id)))))
+
+(defun nrepl-client-sentinel (process message)
+ "Handle sentinel events from PROCESS.
+Notify MESSAGE and if the process is closed run `nrepl-disconnected-hook'
+and kill the process buffer."
+ (if (string-match "deleted\\b" message)
+ (message "[nREPL] Connection closed")
+ (message "[nREPL] Connection closed unexpectedly (%s)"
+ (substring message 0 -1)))
+ (when (equal (process-status process) 'closed)
+ (when-let* ((client-buffer (process-buffer process)))
+ (sesman-remove-object 'CIDER nil client-buffer
+ (not (process-get process :keep-server))
+ 'no-error)
+ (nrepl--clear-client-sessions client-buffer)
+ (with-current-buffer client-buffer
+ (goto-char (point-max))
+ (insert-before-markers
+ (propertize
+ (format "\n*** Closed on %s ***\n" (current-time-string))
+ 'face 'cider-repl-stderr-face))
+ (run-hooks 'nrepl-disconnected-hook)
+ (let ((server-buffer nrepl-server-buffer))
+ (when (and (buffer-live-p server-buffer)
+ (not (process-get process :keep-server)))
+ (setq nrepl-server-buffer nil)
+ (nrepl--maybe-kill-server-buffer server-buffer)))))))
+
+\f
+;;; Network
+
+(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* ((remote-dir (if host (format "/ssh:%s:" host) 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'"
+ `((?s . ,ssh)
+ (?p . ,port)
+ (?h . ,v-host)
+ (?u . ,(if v-user (format "-l '%s' " v-user) ""))))))
+
+(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)))))))))
+
+\f
+;;; Client: Process Handling
+
+(defun nrepl--kill-process (proc)
+ "Kill PROC using the appropriate, os specific way.
+Implement a workaround to clean up an orphaned JVM process left around
+after exiting the REPL on some windows machines."
+ (if (memq system-type '(cygwin windows-nt))
+ (interrupt-process proc)
+ (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)
+ "Create new client process identified by HOST and PORT.
+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 (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)))
+
+\f
+;;; 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-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
+ pprint-out-handler
+ content-type-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',
+'pprint-out' 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, PPRINT-OUT-HANDLER and
+CONTENT-TYPE-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
+ pprint-out)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (when (and ns (not (derived-mode-p 'clojure-mode)))
+ (cider-set-buffer-ns ns))))
+ (cond ((and content-type content-type-handler)
+ (funcall content-type-handler buffer
+ (if (string= content-transfer-encoding "base64")
+ (base64-decode-string body)
+ body)
+ content-type))
+ (value
+ (when value-handler
+ (funcall value-handler buffer value)))
+ (out
+ (when stdout-handler
+ (funcall stdout-handler buffer out)))
+ (pprint-out
+ (cond (pprint-out-handler (funcall pprint-out-handler buffer pprint-out))
+ (stdout-handler (funcall stdout-handler buffer pprint-out))))
+ (err
+ (when stderr-handler
+ (funcall stderr-handler buffer err)))
+ (status
+ (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)
+ ;; nREPL 0.4.3 started echoing back the name of the missing ns
+ (if ns
+ (message "Namespace `%s' not found." ns)
+ (message "Namespace not found.")))
+ (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))))))))
+
+\f
+;;; 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
+ (> (cadr (time-subtract (current-time) time0))
+ nrepl-sync-request-timeout))
+ (error "Sync nREPL request timed out %s" request)))
+ ;; 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 nil (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: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"))
+
+\f
+;;; 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)))
+
+(defun nrepl-server-filter (process output)
+ "Process nREPL server output from PROCESS contained in OUTPUT."
+ ;; 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 (and (null nrepl-endpoint)
+ (string-match "nREPL server started on port \\([0-9]+\\)" output))
+ (let ((port (string-to-number (match-string 1 output))))
+ (setq nrepl-endpoint (list :host (or (file-remote-p default-directory 'host)
+ "localhost")
+ :port port))
+ (message "[nREPL] server started on %s" port)
+ (when nrepl-on-port-callback
+ (funcall nrepl-on-port-callback (process-buffer process)))))))))
+
+(declare-function cider--close-connection "cider-connection")
+(defun nrepl-server-sentinel (process event)
+ "Handle nREPL server PROCESS EVENT."
+ (let* ((server-buffer (process-buffer process))
+ (clients (seq-filter (lambda (b)
+ (eq (buffer-local-value 'nrepl-server-buffer b)
+ server-buffer))
+ (buffer-list)))
+ (problem (if (and server-buffer (buffer-live-p server-buffer))
+ (with-current-buffer server-buffer
+ (buffer-substring (point-min) (point-max)))
+ "")))
+ (when server-buffer
+ (kill-buffer server-buffer))
+ (cond
+ ((string-match-p "^killed\\|^interrupt" event)
+ nil)
+ ((string-match-p "^hangup" event)
+ (mapc #'cider--close-connection clients))
+ ;; On Windows, a failed start sends the "finished" event. On Linux it sends
+ ;; "exited abnormally with code 1".
+ (t (error "Could not start nREPL server: %s" problem)))))
+
+\f
+;;; 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
+ :group 'nrepl
+ :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)
+ :group 'nrepl)
+
+(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) (seq-contains '("id" "op" "session" "time-stamp") (car pair))))
+ (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")))))
+
+(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)
+ (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-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2018 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; 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.
+
+;;; Code:
+(require 'cl-lib)
+
+
+(defun nrepl-dict (&rest key-vals)
+ "Create nREPL dict from KEY-VALS."
+ (cons 'dict key-vals))
+
+(defun nrepl-dict-p (object)
+ "Return t if OBJECT is an nREPL dict."
+ (and (listp object)
+ (eq (car object) 'dict)))
+
+(defun nrepl-dict-empty-p (dict)
+ "Return t if nREPL dict DICT is empty."
+ (null (cdr dict)))
+
+(defun nrepl-dict-contains (dict key)
+ "Return nil if nREPL dict DICT doesn't contain KEY.
+If DICT does contain KEY, then a non-nil value is returned. Due to the
+current implementation, this return value is the tail of DICT's key-list
+whose car is KEY. Comparison is done with `equal'."
+ (member key (nrepl-dict-keys dict)))
+
+(defun nrepl-dict-get (dict key &optional default)
+ "Get from DICT value associated with KEY, optional DEFAULT if KEY not in DICT.
+If dict is nil, return nil. If DEFAULT not provided, and KEY not in DICT,
+return nil. If DICT is not an nREPL dict object, an error is thrown."
+ (when dict
+ (if (nrepl-dict-p dict)
+ (if (nrepl-dict-contains dict key)
+ (lax-plist-get (cdr dict) key)
+ default)
+ (error "Not an nREPL dict object: %s" dict))))
+
+(defun nrepl-dict-put (dict key value)
+ "Associate in DICT, KEY to VALUE.
+Return new dict. Dict is modified by side effects."
+ (if (null dict)
+ `(dict ,key ,value)
+ (if (not (nrepl-dict-p dict))
+ (error "Not an nREPL dict object: %s" dict)
+ (setcdr dict (lax-plist-put (cdr dict) key value))
+ dict)))
+
+(defun nrepl-dict-keys (dict)
+ "Return all the keys in the nREPL DICT."
+ (if (nrepl-dict-p dict)
+ (cl-loop for l on (cdr dict) by #'cddr
+ collect (car l))
+ (error "Not an nREPL dict")))
+
+(defun nrepl-dict-vals (dict)
+ "Return all the values in the nREPL DICT."
+ (if (nrepl-dict-p dict)
+ (cl-loop for l on (cdr dict) by #'cddr
+ collect (cadr l))
+ (error "Not an nREPL dict")))
+
+(defun nrepl-dict-map (fn dict)
+ "Map FN on nREPL DICT.
+FN must accept two arguments key and value."
+ (if (nrepl-dict-p dict)
+ (cl-loop for l on (cdr dict) by #'cddr
+ collect (funcall fn (car l) (cadr l)))
+ (error "Not an nREPL dict")))
+
+(defun nrepl-dict-merge (dict1 dict2)
+ "Destructively merge DICT2 into DICT1.
+Keys in DICT2 override those in DICT1."
+ (let ((base (or dict1 '(dict))))
+ (nrepl-dict-map (lambda (k v)
+ (nrepl-dict-put base k v))
+ (or dict2 '(dict)))
+ base))
+
+(defun nrepl-dict-get-in (dict keys)
+ "Return the value in a nested DICT.
+KEYS is a list of keys. Return nil if any of the keys is not present or if
+any of the values is nil."
+ (let ((out dict))
+ (while (and keys out)
+ (setq out (nrepl-dict-get out (pop keys))))
+ out))
+
+(defun nrepl-dict-flat-map (function dict)
+ "Map FUNCTION over DICT and flatten the result.
+FUNCTION follows the same restrictions as in `nrepl-dict-map', and it must
+also alway return a sequence (since the result will be flattened)."
+ (when dict
+ (apply #'append (nrepl-dict-map function dict))))
+
+\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
+;;; Dbind
+(defmacro nrepl-dbind-response (response keys &rest body)
+ "Destructure an nREPL RESPONSE dict.
+Bind the value of the provided KEYS and execute BODY."
+ (declare (debug (form (&rest symbolp) body)))
+ `(let ,(cl-loop for key in keys
+ collect `(,key (nrepl-dict-get ,response ,(format "%s" key))))
+ ,@body))
+(put 'nrepl-dbind-response 'lisp-indent-function 2)
+
+(provide 'nrepl-dict)
+
+;;; nrepl-dict.el ends here
projects / emacsconfig.git / commitdiff