From 850199b21a813a094133d9cf4dd4d5535434b23d Mon Sep 17 00:00:00 2001 From: Gergely Polonkai Date: Thu, 22 Sep 2016 18:37:03 +0200 Subject: [PATCH] Install new packages --- elpa/cider-20160914.2335/cider-apropos.el | 202 ++ elpa/cider-20160914.2335/cider-autoloads.el | 314 +++ elpa/cider-20160914.2335/cider-browse-ns.el | 219 ++ elpa/cider-20160914.2335/cider-classpath.el | 112 + elpa/cider-20160914.2335/cider-client.el | 1119 +++++++++ elpa/cider-20160914.2335/cider-common.el | 257 +++ elpa/cider-20160914.2335/cider-compat.el | 157 ++ elpa/cider-20160914.2335/cider-debug.el | 752 +++++++ elpa/cider-20160914.2335/cider-doc.el | 522 +++++ elpa/cider-20160914.2335/cider-eldoc.el | 430 ++++ elpa/cider-20160914.2335/cider-grimoire.el | 118 + elpa/cider-20160914.2335/cider-inspector.el | 390 ++++ elpa/cider-20160914.2335/cider-interaction.el | 1787 +++++++++++++++ .../cider-macroexpansion.el | 207 ++ elpa/cider-20160914.2335/cider-mode.el | 750 ++++++ elpa/cider-20160914.2335/cider-overlays.el | 311 +++ elpa/cider-20160914.2335/cider-pkg.el | 12 + elpa/cider-20160914.2335/cider-popup.el | 129 ++ elpa/cider-20160914.2335/cider-repl.el | 1377 +++++++++++ elpa/cider-20160914.2335/cider-resolve.el | 129 ++ elpa/cider-20160914.2335/cider-scratch.el | 75 + elpa/cider-20160914.2335/cider-selector.el | 167 ++ elpa/cider-20160914.2335/cider-stacktrace.el | 716 ++++++ elpa/cider-20160914.2335/cider-test.el | 690 ++++++ elpa/cider-20160914.2335/cider-util.el | 691 ++++++ elpa/cider-20160914.2335/cider.el | 790 +++++++ elpa/cider-20160914.2335/nrepl-client.el | 1227 ++++++++++ elpa/cider-20160914.2335/nrepl-dict.el | 187 ++ .../clojure-mode-autoloads.el | 126 ++ .../clojure-mode-pkg.el | 1 + .../clojure-mode-20160803.140/clojure-mode.el | 2004 +++++++++++++++++ .../clojure-quick-repls-autoloads.el | 22 + .../clojure-quick-repls-pkg.el | 1 + .../clojure-quick-repls.el | 155 ++ .../flycheck-clojure-autoloads.el | 29 + .../flycheck-clojure-pkg.el | 1 + .../flycheck-clojure.el | 221 ++ .../flycheck-pkg-config-autoloads.el | 23 + .../flycheck-pkg-config-pkg.el | 1 + .../flycheck-pkg-config.el | 85 + elpa/focus-20160131.1418/focus-autoloads.el | 26 + elpa/focus-20160131.1418/focus-pkg.el | 1 + elpa/focus-20160131.1418/focus.el | 306 +++ .../git-messenger-autoloads.el | 22 + .../git-messenger-pkg.el | 1 + .../git-messenger.el | 406 ++++ .../gitconfig-autoloads.el | 15 + elpa/gitconfig-20130718.235/gitconfig-pkg.el | 1 + elpa/gitconfig-20130718.235/gitconfig.el | 228 ++ .../github-notifier-autoloads.el | 36 + .../github-notifier-pkg.el | 1 + .../github-notifier.el | 243 ++ elpa/queue-0.1.1.signed | 1 + elpa/queue-0.1.1/queue-autoloads.el | 19 + elpa/queue-0.1.1/queue-pkg.el | 1 + elpa/queue-0.1.1/queue.el | 173 ++ elpa/spinner-1.7.1.signed | 1 + elpa/spinner-1.7.1/spinner-autoloads.el | 67 + elpa/spinner-1.7.1/spinner-pkg.el | 1 + elpa/spinner-1.7.1/spinner.el | 394 ++++ 60 files changed, 18449 insertions(+) create mode 100644 elpa/cider-20160914.2335/cider-apropos.el create mode 100644 elpa/cider-20160914.2335/cider-autoloads.el create mode 100644 elpa/cider-20160914.2335/cider-browse-ns.el create mode 100644 elpa/cider-20160914.2335/cider-classpath.el create mode 100644 elpa/cider-20160914.2335/cider-client.el create mode 100644 elpa/cider-20160914.2335/cider-common.el create mode 100644 elpa/cider-20160914.2335/cider-compat.el create mode 100644 elpa/cider-20160914.2335/cider-debug.el create mode 100644 elpa/cider-20160914.2335/cider-doc.el create mode 100644 elpa/cider-20160914.2335/cider-eldoc.el create mode 100644 elpa/cider-20160914.2335/cider-grimoire.el create mode 100644 elpa/cider-20160914.2335/cider-inspector.el create mode 100644 elpa/cider-20160914.2335/cider-interaction.el create mode 100644 elpa/cider-20160914.2335/cider-macroexpansion.el create mode 100644 elpa/cider-20160914.2335/cider-mode.el create mode 100644 elpa/cider-20160914.2335/cider-overlays.el create mode 100644 elpa/cider-20160914.2335/cider-pkg.el create mode 100644 elpa/cider-20160914.2335/cider-popup.el create mode 100644 elpa/cider-20160914.2335/cider-repl.el create mode 100644 elpa/cider-20160914.2335/cider-resolve.el create mode 100644 elpa/cider-20160914.2335/cider-scratch.el create mode 100644 elpa/cider-20160914.2335/cider-selector.el create mode 100644 elpa/cider-20160914.2335/cider-stacktrace.el create mode 100644 elpa/cider-20160914.2335/cider-test.el create mode 100644 elpa/cider-20160914.2335/cider-util.el create mode 100644 elpa/cider-20160914.2335/cider.el create mode 100644 elpa/cider-20160914.2335/nrepl-client.el create mode 100644 elpa/cider-20160914.2335/nrepl-dict.el create mode 100644 elpa/clojure-mode-20160803.140/clojure-mode-autoloads.el create mode 100644 elpa/clojure-mode-20160803.140/clojure-mode-pkg.el create mode 100644 elpa/clojure-mode-20160803.140/clojure-mode.el create mode 100644 elpa/clojure-quick-repls-20150814.36/clojure-quick-repls-autoloads.el create mode 100644 elpa/clojure-quick-repls-20150814.36/clojure-quick-repls-pkg.el create mode 100644 elpa/clojure-quick-repls-20150814.36/clojure-quick-repls.el create mode 100644 elpa/flycheck-clojure-20160704.1221/flycheck-clojure-autoloads.el create mode 100644 elpa/flycheck-clojure-20160704.1221/flycheck-clojure-pkg.el create mode 100644 elpa/flycheck-clojure-20160704.1221/flycheck-clojure.el create mode 100644 elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config-autoloads.el create mode 100644 elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config-pkg.el create mode 100644 elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config.el create mode 100644 elpa/focus-20160131.1418/focus-autoloads.el create mode 100644 elpa/focus-20160131.1418/focus-pkg.el create mode 100644 elpa/focus-20160131.1418/focus.el create mode 100644 elpa/git-messenger-20160815.1952/git-messenger-autoloads.el create mode 100644 elpa/git-messenger-20160815.1952/git-messenger-pkg.el create mode 100644 elpa/git-messenger-20160815.1952/git-messenger.el create mode 100644 elpa/gitconfig-20130718.235/gitconfig-autoloads.el create mode 100644 elpa/gitconfig-20130718.235/gitconfig-pkg.el create mode 100644 elpa/gitconfig-20130718.235/gitconfig.el create mode 100644 elpa/github-notifier-20160702.2112/github-notifier-autoloads.el create mode 100644 elpa/github-notifier-20160702.2112/github-notifier-pkg.el create mode 100644 elpa/github-notifier-20160702.2112/github-notifier.el create mode 100644 elpa/queue-0.1.1.signed create mode 100644 elpa/queue-0.1.1/queue-autoloads.el create mode 100644 elpa/queue-0.1.1/queue-pkg.el create mode 100644 elpa/queue-0.1.1/queue.el create mode 100644 elpa/spinner-1.7.1.signed create mode 100644 elpa/spinner-1.7.1/spinner-autoloads.el create mode 100644 elpa/spinner-1.7.1/spinner-pkg.el create mode 100644 elpa/spinner-1.7.1/spinner.el diff --git a/elpa/cider-20160914.2335/cider-apropos.el b/elpa/cider-20160914.2335/cider-apropos.el new file mode 100644 index 0000000..43b4e19 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-apropos.el @@ -0,0 +1,202 @@ +;;; cider-apropos.el --- Apropos functionality for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2014-2016 Jeff Valk, Bozhidar Batsov and CIDER contributors +;; +;; Author: Jeff Valk + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Apropos functionality for Clojure. + +;;; Code: + +(require 'cider-doc) +(require 'cider-util) +(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 nil t)." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "apropos") + (cider-apropos (read-string "Search for Clojure documentation (a regular expression): ") nil t)) + +(defun cider-apropos-act-on-symbol (symbol) + "Apply selected action on SYMBOL." + (let* ((first-action-key (car (car cider-apropos-actions))) + (action-key (if (= 1 (length cider-apropos-actions)) + first-action-key + (completing-read (format "Choose action to apply to `%s` (default %s): " + symbol first-action-key) + cider-apropos-actions nil nil nil nil first-action-key))) + (action-fn (cdr (assoc action-key cider-apropos-actions)))) + (if action-fn + (funcall action-fn symbol) + (user-error "Unknown action `%s`" action-key)))) + +;;;###autoload +(defun cider-apropos-select (query &optional ns docs-p privates-p case-sensitive-p) + "Similar to `cider-apropos', but presents the results in a completing read. + +Show all symbols whose names match QUERY, a regular expression. +QUERY can also be a list of space-separated words (e.g. take while) which +will be converted to a regular expression (like take.+while) automatically +behind the scenes. The search may be limited to the namespace NS, and may +optionally search doc strings (based on DOCS-P), include private vars +\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P)." + (interactive + (cons (read-string "Search for Clojure symbol (a regular expression): ") + (when current-prefix-arg + (list (let ((ns (completing-read "Namespace (default is all): " (cider-sync-request:ns-list)))) + (if (string= ns "") nil ns)) + (y-or-n-p "Search doc strings? ") + (y-or-n-p "Include private symbols? ") + (y-or-n-p "Case-sensitive? "))))) + (cider-ensure-connected) + (cider-ensure-op-supported "apropos") + (if-let ((summary (cider-apropos-summary + query ns docs-p privates-p case-sensitive-p)) + (results (mapcar (lambda (r) (nrepl-dict-get r "name")) + (cider-sync-request:apropos query ns docs-p privates-p case-sensitive-p)))) + (cider-apropos-act-on-symbol (completing-read (concat summary ": ") results)) + (message "No apropos matches for %S" query))) + +;;;###autoload +(defun cider-apropos-documentation-select () + "Shortcut for (cider-apropos-select nil t)." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "apropos") + (cider-apropos-select (read-string "Search for Clojure documentation (a regular expression): ") nil t)) + +(provide 'cider-apropos) + +;;; cider-apropos.el ends here diff --git a/elpa/cider-20160914.2335/cider-autoloads.el b/elpa/cider-20160914.2335/cider-autoloads.el new file mode 100644 index 0000000..cc10013 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-autoloads.el @@ -0,0 +1,314 @@ +;;; cider-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil "cider" "cider.el" (22500 1819 348200 658000)) +;;; 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))) + +;;;*** + +;;;### (autoloads nil "cider-apropos" "cider-apropos.el" (22500 1819 +;;;;;; 244200 101000)) +;;; Generated autoloads from cider-apropos.el + +(autoload 'cider-apropos "cider-apropos" "\ +Show all symbols whose names match QUERY, a regular expression. +QUERY can also be a list of space-separated words (e.g. take while) which +will be converted to a regular expression (like take.+while) automatically +behind the scenes. The search may be limited to the namespace NS, and may +optionally search doc strings (based on DOCS-P), include private vars +\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P). + +\(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t nil) + +(autoload 'cider-apropos-documentation "cider-apropos" "\ +Shortcut for (cider-apropos nil t). + +\(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 nil t). + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-browse-ns" "cider-browse-ns.el" (22500 +;;;;;; 1819 228200 15000)) +;;; 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) + +;;;*** + +;;;### (autoloads nil "cider-classpath" "cider-classpath.el" (22500 +;;;;;; 1819 360200 722000)) +;;; 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) + +;;;*** + +;;;### (autoloads nil "cider-debug" "cider-debug.el" (22500 1819 +;;;;;; 236200 58000)) +;;; 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) + +;;;*** + +;;;### (autoloads nil "cider-grimoire" "cider-grimoire.el" (22500 +;;;;;; 1819 296200 380000)) +;;; 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) + +;;;*** + +;;;### (autoloads nil "cider-inspector" "cider-inspector.el" (22500 +;;;;;; 1819 288200 336000)) +;;; 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") + +;;;*** + +;;;### (autoloads nil "cider-macroexpansion" "cider-macroexpansion.el" +;;;;;; (22500 1819 336200 594000)) +;;; 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) + +;;;*** + +;;;### (autoloads nil "cider-mode" "cider-mode.el" (22500 1819 260200 +;;;;;; 186000)) +;;; 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' 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) + +;;;*** + +;;;### (autoloads nil "cider-scratch" "cider-scratch.el" (22500 1819 +;;;;;; 272200 251000)) +;;; Generated autoloads from cider-scratch.el + +(autoload 'cider-scratch "cider-scratch" "\ +Go to the scratch buffer named `cider-scratch-buffer-name'. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-selector" "cider-selector.el" (22500 +;;;;;; 1819 352200 679000)) +;;; 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) + +;;;*** + +;;;### (autoloads nil "cider-test" "cider-test.el" (22500 1819 332200 +;;;;;; 572000)) +;;; Generated autoloads from cider-test.el + +(defvar cider-auto-test-mode nil "\ +Non-nil if Cider-Auto-Test mode is enabled. +See the command `cider-auto-test-mode' 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) + +;;;*** + +;;;### (autoloads nil "cider-util" "cider-util.el" (22500 1819 340200 +;;;;;; 615000)) +;;; Generated autoloads from cider-util.el + +(autoload 'cider-view-manual "cider-util" "\ +View the manual in your default browser. + +\(fn)" t nil) + +;;;*** + +;;;### (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") +;;;;;; (22500 1819 381194 228000)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; cider-autoloads.el ends here diff --git a/elpa/cider-20160914.2335/cider-browse-ns.el b/elpa/cider-20160914.2335/cider-browse-ns.el new file mode 100644 index 0000000..aae46bc --- /dev/null +++ b/elpa/cider-20160914.2335/cider-browse-ns.el @@ -0,0 +1,219 @@ +;;; cider-browse-ns.el --- CIDER namespace browser + +;; Copyright © 2014-2016 John Andrews, Bozhidar Batsov and CIDER contributors + +;; Author: John Andrews + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; M-x cider-browse-ns +;; +;; Display a list of all vars in a namespace. +;; Pressing will take you to the cider-doc buffer for that var. +;; Pressing ^ will take you to a list of all namespaces (akin to `dired-mode'). + +;; M-x cider-browse-ns-all +;; +;; Explore Clojure namespaces by browsing a list of all namespaces. +;; Pressing expands into a list of that namespace's vars as if by +;; executing the command (cider-browse-ns "my.ns"). + +;;; Code: + +(require 'cider-interaction) +(require 'cider-client) +(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 [return] #'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) + (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 (cider-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 diff --git a/elpa/cider-20160914.2335/cider-classpath.el b/elpa/cider-20160914.2335/cider-classpath.el new file mode 100644 index 0000000..edc0bfb --- /dev/null +++ b/elpa/cider-20160914.2335/cider-classpath.el @@ -0,0 +1,112 @@ +;;; cider-classpath.el --- Basic Java classpath browser + +;; Copyright © 2014-2016 Bozhidar Batsov and CIDER contributors + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Basic Java classpath browser for CIDER. + +;;; Code: + +(require 'cider-client) +(require 'cider-popup) +(require '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 [return] #'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) + (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 diff --git a/elpa/cider-20160914.2335/cider-client.el b/elpa/cider-20160914.2335/cider-client.el new file mode 100644 index 0000000..c0da631 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-client.el @@ -0,0 +1,1119 @@ +;;; cider-client.el --- A layer of abstraction above the actual client code. -*- lexical-binding: t -*- + +;; Copyright © 2013-2016 Bozhidar Batsov +;; +;; Author: Bozhidar Batsov + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; A layer of abstraction above the actual client code. + +;;; Code: + +(require 'spinner) +(require 'ewoc) +(require 'nrepl-client) +(require 'cider-common) +(require 'cider-util) +(require 'clojure-mode) + +(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))))) + + +;;; 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-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-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)))))) + + +;;; 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}" + (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) + + +;;; 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))) + + +;;; 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 + (cider-current-session) + 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) + (cider-current-session) + 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) + (cider-current-tooling-session) + ns)) + +(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) + (cider-current-session)))))) + +(defun cider-current-session () + "The REPL session to use for this buffer." + (with-current-buffer (cider-current-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 current tooling session." + (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)))) + + +;;; 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" + "session" (cider-current-session) + "file" file-contents + "file-path" file-path + "file-name" file-name) + (or callback + (cider-load-file-handler (current-buffer))) + connection)) + + +;;; Sync Requests + +(defcustom cider-filtered-namespaces-regexps + '("^cider.nrepl" "^refactor-nrepl" "^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" + "session" ,(cider-current-session) + "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" + "session" (cider-current-session)) + (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" + "session" (cider-current-session) + "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" + "session" ,(cider-current-session) + "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" + "session" ,(cider-current-session) + "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 + "session" (cider-current-session)) + (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" + "session" (cider-current-session) + "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" + "session" (cider-current-session) + "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" + "session" (cider-current-session)) + (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" + "session" (cider-current-session) + "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" + "session" (cider-current-session)) + (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" + "session" (cider-current-session) + "code" code) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "formatted-code"))) + +(defun cider-sync-request:format-edn (edn &optional right-margin) + "Perform \"format-edn\" op with EDN and RIGHT-MARGIN." + (let* ((response (thread-first (list "op" "format-edn" + "session" (cider-current-session) + "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"))) + + +;;; 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) "") + (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) ""))) + +(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 diff --git a/elpa/cider-20160914.2335/cider-common.el b/elpa/cider-20160914.2335/cider-common.el new file mode 100644 index 0000000..d6166d4 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-common.el @@ -0,0 +1,257 @@ +;;; cider-common.el --- Common use functions -*- lexical-binding: t; -*- + +;; Copyright © 2015-2016 Artur Malabarba + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Common functions that are useful in both Clojure buffers and REPL +;; buffers. + +;;; Code: + +(require '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")) + +(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 diff --git a/elpa/cider-20160914.2335/cider-compat.el b/elpa/cider-20160914.2335/cider-compat.el new file mode 100644 index 0000000..9585a52 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-compat.el @@ -0,0 +1,157 @@ +;;; cider-compat.el --- Functions from newer Emacs versions for compatibility -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2016 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 . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Pretty much everything here's copied from subr-x for compatibility with +;; Emacs 24.3 and 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 diff --git a/elpa/cider-20160914.2335/cider-debug.el b/elpa/cider-20160914.2335/cider-debug.el new file mode 100644 index 0000000..c7856d8 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-debug.el @@ -0,0 +1,752 @@ +;;; cider-debug.el --- CIDER interaction with the cider.debug nREPL middleware -*- lexical-binding: t; -*- + +;; Copyright © 2015-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Instrument code with `cider-debug-defun-at-point', and when the code is +;; executed cider-debug will kick in. See this function's doc for more +;; information. + +;;; Code: + +(require '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 'cider-compat) +(require 'seq) +(require 'spinner) + + +;;; 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")) + + +;;; 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)) + + +;;; Debugging overlays +(defconst cider--fringe-arrow-string + #("." 0 1 (display (left-fringe right-triangle))) + "Used as an overlay's before-string prop to place a fringe arrow.") + +(defun cider--debug-display-result-overlay (value) + "Place an overlay at point displaying VALUE." + (when cider-debug-use-overlays + ;; This is cosmetic, let's ensure it doesn't break the session no matter what. + (ignore-errors + ;; Result + (cider--make-result-overlay (cider-font-lock-as-clojure value) + :where (point-marker) + :type 'debug-result + 'before-string cider--fringe-arrow-string) + ;; Code + (cider--make-overlay (save-excursion (clojure-backward-logical-sexp 1) (point)) + (point) 'debug-code + 'face 'cider-debug-code-overlay-face + ;; Higher priority than `show-paren'. + 'priority 2000)))) + + +;;; Minor mode +(defvar-local cider--debug-mode-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) + (cider-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"))) + + +;;; 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)))))))) + + +;;; 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")))))) + + +;;; User commands +;;;###autoload +(defun cider-debug-defun-at-point () + "Instrument the \"top-level\" expression at point. +If it is a defn, dispatch the instrumented definition. Otherwise, +immediately evaluate the instrumented expression. + +While debugged code is being evaluated, the user is taken through the +source code and displayed the value of various expressions. At each step, +a number of keys will be prompted to the user." + (interactive) + (cider-eval-defun-at-point 'debug-it)) + +(provide 'cider-debug) +;;; cider-debug.el ends here diff --git a/elpa/cider-20160914.2335/cider-doc.el b/elpa/cider-20160914.2335/cider-doc.el new file mode 100644 index 0000000..667aab4 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-doc.el @@ -0,0 +1,522 @@ +;;; cider-doc.el --- CIDER documentation functionality -*- lexical-binding: t -*- + +;; Copyright © 2014-2016 Bozhidar Batsov, Jeff Valk and CIDER contributors + +;; Author: Jeff Valk + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Mode for formatting and presenting documentation + +;;; Code: + +(require 'cider-common) +(require 'cider-compat) +(require 'cider-util) +(require 'cider-popup) +(require 'cider-client) +(require 'cider-grimoire) +(require 'nrepl-dict) +(require 'org-table) +(require 'button) +(require 'easymenu) + + +;;; 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.") + + +;;; cider-docview-mode + +(defgroup cider-docview-mode nil + "Formatting/fontifying documentation viewer." + :prefix "cider-docview-" + :group 'cider) + +(defcustom cider-docview-fill-column fill-column + "Fill column for docstrings in doc buffer." + :type 'list + :group 'cider-docview-mode + :package-version '(cider . "0.7.0")) + + + +;; Faces + +(defface cider-docview-emphasis-face + '((t (:inherit default :underline t))) + "Face for emphasized text" + :group 'cider-docview-mode + :package-version '(cider . "0.7.0")) + +(defface cider-docview-strong-face + '((t (:inherit default :underline t :weight bold))) + "Face for strongly emphasized text" + :group 'cider-docview-mode + :package-version '(cider . "0.7.0")) + +(defface cider-docview-literal-face + '((t (:inherit font-lock-string-face))) + "Face for literal text" + :group 'cider-docview-mode + :package-version '(cider . "0.7.0")) + +(defface cider-docview-table-border-face + '((t (:inherit shadow))) + "Face for table borders" + :group 'cider-docview-mode + :package-version '(cider . "0.7.0")) + + +;; Colors & Theme Support + +(defvar cider-docview-code-background-color + (cider-scale-background-color) + "Background color for code blocks.") + +(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))) + + +;; 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 "") #'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 truncate-lines t) + (setq-local electric-indent-chars nil) + (setq-local cider-docview-symbol nil) + (setq-local cider-docview-javadoc-url nil) + (setq-local cider-docview-file nil) + (setq-local cider-docview-line nil)) + + +;;; Interactive functions + +(defun cider-docview-javadoc () + "Open the Javadoc for the current class, if available." + (interactive) + (if cider-docview-javadoc-url + (browse-url cider-docview-javadoc-url) + (error "No Javadoc available for %s" cider-docview-symbol))) + +(defun cider-javadoc-handler (symbol-name) + "Invoke the nREPL \"info\" op on SYMBOL-NAME if available." + (when symbol-name + (let* ((info (cider-var-info symbol-name)) + (url (nrepl-dict-get info "javadoc"))) + (if url + (browse-url url) + (user-error "No Javadoc available for %s" symbol-name))))) + +(defun cider-javadoc (arg) + "Open Javadoc documentation in a popup buffer. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates." + (interactive "P") + (cider-ensure-connected) + (cider-ensure-op-supported "info") + (funcall (cider-prompt-for-symbol-function arg) + "Javadoc for" + #'cider-javadoc-handler)) + +(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)) + + +;;; 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))))) + + +;;; 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 diff --git a/elpa/cider-20160914.2335/cider-eldoc.el b/elpa/cider-20160914.2335/cider-eldoc.el new file mode 100644 index 0000000..5b66d15 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-eldoc.el @@ -0,0 +1,430 @@ +;;; cider-eldoc.el --- eldoc support for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; eldoc support for Clojure. + +;;; Code: + +(require 'cider-client) +(require 'cider-common) ; for cider-symbol-at-point +(require 'cider-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.") + +(defvar cider-eldoc-max-num-sexps-to-skip 30 + "The maximum number of sexps to skip while searching the beginning of current sexp.") + +(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) + (cider-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 + (cider-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 () + "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)))) + (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 diff --git a/elpa/cider-20160914.2335/cider-grimoire.el b/elpa/cider-20160914.2335/cider-grimoire.el new file mode 100644 index 0000000..0616b20 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-grimoire.el @@ -0,0 +1,118 @@ +;;; cider-grimoire.el --- Grimoire integration -*- lexical-binding: t -*- + +;; Copyright © 2014-2016 Bozhidar Batsov and CIDER contributors +;; +;; Author: Bozhidar Batsov + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; A few commands for Grimoire documentation lookup. + +;;; Code: + +(require 'cider-client) +(require 'cider-common) +(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 diff --git a/elpa/cider-20160914.2335/cider-inspector.el b/elpa/cider-20160914.2335/cider-inspector.el new file mode 100644 index 0000000..8547c71 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-inspector.el @@ -0,0 +1,390 @@ +;;; cider-inspector.el --- Object inspector -*- lexical-binding: t -*- + +;; Copyright © 2013-2016 Vital Reactor, LLC +;; Copyright © 2014-2016 Bozhidar Batsov and CIDER contributors + +;; Author: Ian Eslick +;; Bozhidar Batsov + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Clojure object inspector inspired by SLIME. + +;;; Code: + +(require 'cl-lib) +(require '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")) + +(defvar cider-inspector-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map cider-popup-buffer-mode-map) + (define-key map [return] #'cider-inspector-operate-on-point) + (define-key map "\C-m" #'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) + (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" + "session" (cider-current-session)) + (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 + "session" (cider-current-session)) + (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" + "session" (cider-current-session)) + (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" + "session" (cider-current-session)) + (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" + "session" (cider-current-session)) + (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 + "session" (cider-current-session)) + (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 (cider-current-session) 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) + (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 diff --git a/elpa/cider-20160914.2335/cider-interaction.el b/elpa/cider-20160914.2335/cider-interaction.el new file mode 100644 index 0000000..7742e82 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-interaction.el @@ -0,0 +1,1787 @@ +;;; cider-interaction.el --- IDE for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Provides 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 '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.") + +(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)))) + + +;;; 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))))) + +(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" "session" (cider-current-session)) + (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) + (cider-current-session)))) + +(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)))) + + +;;; 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-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)) + (right-margin (max fill-column + (1- (window-width (get-buffer-window result-buffer)))))) + (cider-interactive-eval (when (stringp form) form) + handler + (when (consp form) form) + (cider--nrepl-pprint-request-plist (or right-margin fill-column))))) + +(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))) + + +;; 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))) + + +;;; Completion + +(defun cider-sync-request:toggle-trace-var (symbol) + "Toggle var tracing for SYMBOL." + (thread-first (list "op" "toggle-trace-var" + "session" (cider-current-session) + "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" + "session" (cider-current-session) + "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" + "session" (cider-current-session) + "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)) + + (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." + (interactive "p") + (cider-ensure-connected) + (cider-ensure-op-supported "refresh") + (let ((clear? (member mode '(clear 16))) + (refresh-all? (member mode '(refresh-all 4)))) + (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 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 cider-refresh-before-fn (list "before" cider-refresh-before-fn)) + (when 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 fill-column)))) + +(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 (- fill-column 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) selected-session)) + (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) + (let ((selected-session (completing-read "Close nREPL session: " (nrepl-sessions (cider-current-connection))))) + (when selected-session + (nrepl-sync-request:close (cider-current-connection) selected-session) + (message "Closed nREPL session %s" selected-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 nrepl-session + (nrepl-sync-request:close buffer nrepl-session)) + (when nrepl-tooling-session + (nrepl-sync-request:close buffer nrepl-tooling-session))) + (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))) + (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) + (if project-dir + (let ((default-directory project-dir)) + (cider-jack-in)) + (error "Can't restart CIDER connection for unknown project")))) + +(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" + "session" (cider-current-session) + "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 diff --git a/elpa/cider-20160914.2335/cider-macroexpansion.el b/elpa/cider-20160914.2335/cider-macroexpansion.el new file mode 100644 index 0000000..63f3335 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-macroexpansion.el @@ -0,0 +1,207 @@ +;;; cider-macroexpansion.el --- Macro expansion support -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Macro expansion support. + +;;; Code: + +(require 'cider-mode) +(require '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 diff --git a/elpa/cider-20160914.2335/cider-mode.el b/elpa/cider-20160914.2335/cider-mode.el new file mode 100644 index 0000000..df7d7d8 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-mode.el @@ -0,0 +1,750 @@ +;;; cider-mode.el --- Minor mode for REPL interactions -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Minor mode for REPL interactions. + +;;; Code: + +(require 'clojure-mode) +(require 'cider-interaction) +(require 'cider-test) +(require 'cider-eldoc) +(require 'cider-resolve) +(require 'cider-doc) +(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) "") + (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")) + + +;;; 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))) + + +;;; 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-lein-repl' to change the ClojureScript REPL to use."] + ["Create a ClojureScript REPL from a Clojure REPL" cider-create-sibling-cljs-repl] + ["Configure the ClojureScript REPL to use" (customize-variable 'cider-cljs-lein-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])) + "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] + ["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 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' 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)))))) + + +;;; 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")) + +(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")) + +(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))) + + +;;; 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))) + + +;;; 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-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-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 diff --git a/elpa/cider-20160914.2335/cider-overlays.el b/elpa/cider-20160914.2335/cider-overlays.el new file mode 100644 index 0000000..b64dce5 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-overlays.el @@ -0,0 +1,311 @@ +;;; cider-overlays.el --- Managing CIDER overlays -*- lexical-binding: t; -*- + +;; Copyright © 2015-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Use `cider--make-overlay' to place a generic overlay at point. Or use +;; `cider--make-result-overlay' to place an interactive eval result overlay at +;; the end of a specified line. + +;;; Code: + +(require 'cider-common) +(require 'cider-compat) +(require 'cl-lib) + + +;;; Customization +(defface cider-result-overlay-face + '((((class color) (background light)) + :background "grey90" :box (:line-width -1 :color "yellow")) + (((class color) (background dark)) + :background "grey10" :box (:line-width -1 :color "black"))) + "Face used to display evaluation results at the end of line. +If `cider-overlays-use-font-lock' is non-nil, this face is +applied with lower priority than the syntax highlighting." + :group 'cider + :package-version '(cider "0.9.1")) + +(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")) + + +;;; 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))))))) + + +;;; 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))))))) + + +;;; Fragile buttons +(defface cider-fragile-button-face + '((((type graphic)) + :box (:line-width 3 :style released-button) + :inherit font-lock-warning-face) + (t :inverse-video t)) + "Face for buttons that vanish when clicked." + :package-version '(cider . "0.12.0") + :group 'cider) + +(define-button-type 'cider-fragile + 'action 'cider--overlay-destroy + 'follow-link t + 'face nil + 'modification-hooks '(cider--overlay-destroy) + 'help-echo "RET: delete this.") + +(defun cider--overlay-destroy (ov &rest r) + "Delete overlay OV and its underlying text. +If any other arguments are given (collected in R), only actually do anything +if the first one is non-nil. This is so it works in `modification-hooks'." + (unless (and r (not (car r))) + (let ((inhibit-modification-hooks t) + (beg (copy-marker (overlay-start ov))) + (end (copy-marker (overlay-end ov)))) + (delete-overlay ov) + (delete-region beg end) + (goto-char beg) + (when (= (char-after) (char-before) ?\n) + (delete-char 1))))) + +(provide 'cider-overlays) +;;; cider-overlays.el ends here diff --git a/elpa/cider-20160914.2335/cider-pkg.el b/elpa/cider-20160914.2335/cider-pkg.el new file mode 100644 index 0000000..975f0ed --- /dev/null +++ b/elpa/cider-20160914.2335/cider-pkg.el @@ -0,0 +1,12 @@ +(define-package "cider" "20160914.2335" "Clojure Interactive Development Environment that Rocks" + '((emacs "24.3") + (clojure-mode "5.5.2") + (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: diff --git a/elpa/cider-20160914.2335/cider-popup.el b/elpa/cider-20160914.2335/cider-popup.el new file mode 100644 index 0000000..7c235f8 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-popup.el @@ -0,0 +1,129 @@ +;;; cider-popup.el --- Creating and quitting popup buffers -*- lexical-binding: t; -*- + +;; Copyright © 2015-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Common functionality for dealing with popup buffers. + +;;; Code: + +(require '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 diff --git a/elpa/cider-20160914.2335/cider-repl.el b/elpa/cider-20160914.2335/cider-repl.el new file mode 100644 index 0000000..1199f3f --- /dev/null +++ b/elpa/cider-20160914.2335/cider-repl.el @@ -0,0 +1,1377 @@ +;;; cider-repl.el --- REPL interactions -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; REPL interactions. + +;;; Code: + +(require 'cider-client) +(require 'cider-doc) +(require 'cider-test) +(require 'cider-eldoc) ; for cider-eldoc-setup +(require 'cider-common) +(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)) + + +(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." + :type 'boolean + :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-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")) + + +;;;; REPL buffer local variables +(defvar-local cider-repl-input-start-mark nil) + +(defvar-local cider-repl-prompt-start-mark nil) + +(defvar-local cider-repl-old-input-counter 0 + "Counter used to generate unique `cider-old-input' properties. +This property value must be unique to avoid having adjacent inputs be +joined together.") + +(defvar-local cider-repl-input-history '() + "History list of strings read from the REPL buffer.") + +(defvar-local cider-repl-input-history-items-added 0 + "Variable counting the items added in the current session.") + +(defvar-local cider-repl-output-start nil + "Marker for the start of output. +Currently its only purpose is to facilitate `cider-repl-clear-buffer'.") + +(defvar-local cider-repl-output-end nil + "Marker for the end of output. +Currently its only purpose is to facilitate `cider-repl-clear-buffer'.") + +(defun cider-repl-tab () + "Invoked on TAB keystrokes in `cider-repl-mode' buffers." + (interactive) + (funcall cider-repl-tab-command)) + +(defun cider-repl-reset-markers () + "Reset all REPL markers." + (dolist (markname '(cider-repl-output-start + cider-repl-output-end + cider-repl-prompt-start-mark + cider-repl-input-start-mark)) + (set markname (make-marker)) + (set-marker (symbol-value markname) (point)))) + + +;;; REPL init + +(defvar-local cider-repl-ns-cache nil + "A dict holding information about all currently loaded namespaces. +This cache is stored in the connection buffer. 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))) + (when cider-repl-pop-to-buffer-on-connect + (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: +;; 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 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 to +;; get a feel for this. If you’re thirsty for knowledge you should try +;; . +;; +;; If you think you’ve encountered a bug (or have some suggestions for +;; improvements) use to report it. +;; +;; Above all else - don’t panic! In case of an emergency - procure +;; some (hard) cider and enjoy it responsibly! +;; +;; You can remove this message with the `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))) + + +;;; 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 (1- (window-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-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)) + + +;;;;; 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)) + + +;;; 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-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 "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"))))) + + +;;;;; 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-") #'cider-repl-closing-return) + (define-key map (kbd "C-j") #'cider-repl-newline-and-indent) + (define-key map (kbd "C-c C-o") #'cider-repl-clear-output) + (define-key map (kbd "C-c M-n") #'cider-repl-set-ns) + (define-key map (kbd "C-c C-u") #'cider-repl-kill-input) + (define-key map (kbd "C-S-a") #'cider-repl-bol-mark) + (define-key map [S-home] #'cider-repl-bol-mark) + (define-key map (kbd "C-") #'cider-repl-backward-input) + (define-key map (kbd "C-") #'cider-repl-forward-input) + (define-key map (kbd "M-p") #'cider-repl-previous-input) + (define-key map (kbd "M-n") #'cider-repl-next-input) + (define-key map (kbd "M-r") #'cider-repl-previous-matching-input) + (define-key map (kbd "M-s") #'cider-repl-next-matching-input) + (define-key map (kbd "C-c C-n") #'cider-repl-next-prompt) + (define-key map (kbd "C-c C-p") #'cider-repl-previous-prompt) + (define-key map (kbd "C-c C-b") #'cider-interrupt) + (define-key map (kbd "C-c C-c") #'cider-interrupt) + (define-key map (kbd "C-c C-m") #'cider-macroexpand-1) + (define-key map (kbd "C-c M-m") #'cider-macroexpand-all) + (define-key map (kbd "C-c C-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-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 diff --git a/elpa/cider-20160914.2335/cider-resolve.el b/elpa/cider-20160914.2335/cider-resolve.el new file mode 100644 index 0000000..b8094a9 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-resolve.el @@ -0,0 +1,129 @@ +;;; cider-resolve.el --- Resolve clojure symbols according to current nREPL connection + +;; Copyright © 2015-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; The ns cache is a dict of namespaces stored in the connection buffer. This +;; file offers functions to easily get information about variables from this +;; cache, given the variable's name and the file's namespace. This +;; functionality is similar to that offered by the `cider-var-info' function +;; (and others). The difference is that all functions in this file operate +;; without contacting the server (they still rely on an active connection +;; buffer, but no messages are actually exchanged). + +;; For this reason, the functions here are well suited for very +;; performance-sentitive operations, such as font-locking or +;; indentation. Meanwhile, operations like code-jumping are better off +;; communicating with the middleware, just in the off chance that the cache is +;; outdated. + +;; Below is a typical entry on this cache dict. Note that clojure.core symbols +;; are excluded from the refers to save space. + +;; "cider.nrepl.middleware.track-state" +;; (dict "aliases" +;; (dict "cljs" "cider.nrepl.middleware.util.cljs" +;; "misc" "cider.nrepl.middleware.util.misc" +;; "set" "clojure.set") +;; "interns" (dict a +;; "assoc-state" (dict "arglists" +;; (("response" +;; (dict "as" "msg" "keys" +;; ("session"))))) +;; "filter-core" (dict "arglists" +;; (("refers"))) +;; "make-transport" (dict "arglists" +;; (((dict "as" "msg" "keys" +;; ("transport"))))) +;; "ns-as-map" (dict "arglists" +;; (("ns"))) +;; "ns-cache" (dict) +;; "relevant-meta" (dict "arglists" +;; (("var"))) +;; "update-vals" (dict "arglists" +;; (("m" "f"))) +;; "wrap-tracker" (dict "arglists" +;; (("handler")))) +;; "refers" (dict "set-descriptor!" "#'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 diff --git a/elpa/cider-20160914.2335/cider-scratch.el b/elpa/cider-20160914.2335/cider-scratch.el new file mode 100644 index 0000000..e794afd --- /dev/null +++ b/elpa/cider-20160914.2335/cider-scratch.el @@ -0,0 +1,75 @@ +;;; cider-scratch.el --- *scratch* buffer for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2014-2016 Bozhidar Batsov and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Imitate Emacs's *scratch* buffer. + +;;; Code: + +(require 'cider-interaction) +(require 'clojure-mode) + +(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) + 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-create-scratch-buffer () + "Create a new scratch buffer." + (with-current-buffer (get-buffer-create cider-scratch-buffer-name) + (cider-clojure-interaction-mode) + (insert ";; This buffer is for Clojure experiments and evaluation.\n" + ";; Press C-j to evaluate the last expression.\n\n") + (current-buffer))) + +(provide 'cider-scratch) + +;;; cider-scratch.el ends here diff --git a/elpa/cider-20160914.2335/cider-selector.el b/elpa/cider-20160914.2335/cider-selector.el new file mode 100644 index 0000000..9b771d6 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-selector.el @@ -0,0 +1,167 @@ +;;; 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-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Buffer selection command inspired by SLIME's selector. + +;;; Code: + +(require 'cider-client) +(require 'cider-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 diff --git a/elpa/cider-20160914.2335/cider-stacktrace.el b/elpa/cider-20160914.2335/cider-stacktrace.el new file mode 100644 index 0000000..3d31243 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-stacktrace.el @@ -0,0 +1,716 @@ +;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*- + +;; Copyright © 2014-2016 Jeff Valk, Bozhidar Batsov and CIDER contributors + +;; Author: Jeff Valk + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Stacktrace filtering and stack frame source navigation + +;;; Code: + +(require 'cl-lib) +(require 'cider-popup) +(require 'button) +(require 'easymenu) +(require 'cider-common) +(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 [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) + (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 diff --git a/elpa/cider-20160914.2335/cider-test.el b/elpa/cider-20160914.2335/cider-test.el new file mode 100644 index 0000000..1ef963c --- /dev/null +++ b/elpa/cider-20160914.2335/cider-test.el @@ -0,0 +1,690 @@ +;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*- + +;; Copyright © 2014-2016 Jeff Valk, Bozhidar Batsov and CIDER contributors + +;; Author: Jeff Valk + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; This provides execution, reporting, and navigation support for Clojure tests, +;; specifically using the `clojure.test' machinery. This functionality replaces +;; the venerable `clojure-test-mode' (deprecated in June 2014), and relies on +;; nREPL middleware for report running and session support. + +;;; Code: + +(require 'cider-common) +(require 'cider-client) +(require 'cider-popup) +(require 'cider-stacktrace) +(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")) + +(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-tests) + (define-key map (kbd "C-t") #'cider-test-run-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-tests) + (define-key map (kbd "t") #'cider-test-run-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-tests] + ["Show test report" cider-test-show-report] + "--" + ["Configure testing" (customize-group 'cider-test)]) + "CIDER test submenu.") + +(defvar cider-test-report-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c ,") 'cider-test-commands-map) + (define-key map (kbd "C-c C-t") 'cider-test-commands-map) + (define-key map (kbd "M-p") #'cider-test-previous-result) + (define-key map (kbd "M-n") #'cider-test-next-result) + (define-key map (kbd "M-.") #'cider-test-jump) + (define-key map (kbd "") #'cider-test-previous-result) + (define-key map (kbd "TAB") #'cider-test-next-result) + (define-key map (kbd "RET") #'cider-test-jump) + (define-key map (kbd "t") #'cider-test-jump) + (define-key map (kbd "d") #'cider-test-ediff) + (define-key map (kbd "e") #'cider-test-stacktrace) + ;; `f' for "run failed". + (define-key map "f" #'cider-test-rerun-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-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) + (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" "session" (cider-current-session) + "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") + "session" (cider-current-session)) + (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-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-tests)) + (unless silent + (message "No namespace to test in current context"))))) + +(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) + (cider-test-execute ns (list var)) + (let ((ns (clojure-find-ns)) + (def (clojure-find-def))) + (if (and ns (member (car def) '("deftest" "defspec"))) + (cider-test-execute ns (cdr def)) + (message "No test at point")))))) + +;;; 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 diff --git a/elpa/cider-20160914.2335/cider-util.el b/elpa/cider-20160914.2335/cider-util.el new file mode 100644 index 0000000..59cb3d6 --- /dev/null +++ b/elpa/cider-20160914.2335/cider-util.el @@ -0,0 +1,691 @@ +;;; 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-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Common utility functions that don't belong anywhere else. + +;;; Code: + +(require 'seq) +(require 'cl-lib) +(require 'clojure-mode) +(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)))) + + +;;; 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))))) + + +;;; 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)))) + + +;;; 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"))) + + +;;; 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)))) + + +;;; Strings + +(defun cider-string-trim-left (string) + "Remove leading whitespace from STRING." + (if (string-match "\\`[ \t\n\r]+" string) + (replace-match "" t t string) + string)) + +(defun cider-string-trim-right (string) + "Remove trailing whitespace from STRING." + (if (string-match "[ \t\n\r]+\\'" string) + (replace-match "" t t string) + string)) + +(defun cider-string-trim (string) + "Remove leading and trailing whitespace from STRING." + (cider-string-trim-left (cider-string-trim-right string))) + +(defun cider-string-join (strings &optional separator) + "Join all STRINGS using SEPARATOR." + (mapconcat #'identity strings separator)) + +(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 (cider-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"))) + + +;;; 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-macroexpand-1]> to expand the preceding macro." + "Press <\\[cider-inspect]> to inspect the preceding expression's result." + "Press to inspect the defun at point's result." + "Press to read Clojure code from the minibuffer and inspect its result." + "Press <\\[cider-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 to see every possible setting you can customize." + "Use to see every possible REPL setting you can customize." + "Enable `eldoc-mode' to display function & method signatures in the minibuffer." + "Enable `cider-enlighten-mode' to display the locals of a function when it's executed." + "Use <\\[cider-close-ancillary-buffers]> to close all ancillary buffers created by CIDER (e.g. *cider-doc*)." + "Exploring CIDER's menu-bar entries is a great way to discover features." + "Keep in mind that some commands don't have a keybinding by default. Explore CIDER!" + "Tweak `cider-repl-prompt-function' to customize your REPL prompt." + "Tweak `cider-eldoc-ns-function' to customize the way namespaces are displayed by eldoc.") + "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) (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 diff --git a/elpa/cider-20160914.2335/cider.el b/elpa/cider-20160914.2335/cider.el new file mode 100644 index 0000000..04a2556 --- /dev/null +++ b/elpa/cider-20160914.2335/cider.el @@ -0,0 +1,790 @@ +;;; cider.el --- Clojure Interactive Development Environment that Rocks -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell +;; Maintainer: Bozhidar Batsov +;; URL: http://www.github.com/clojure-emacs/cider +;; Version: 0.14.0-cvs +;; Package-Requires: ((emacs "24.3") (clojure-mode "5.5.2") (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 . + +;; 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 'cider-compat) +(require 'cider-debug) +(require 'tramp-sh) + +(require 'seq) + +(defconst cider-version "0.14.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 "Berlin" + "Codename used to denote stable releases.") + +(defcustom cider-lein-command + "lein" + "The command used to execute Leiningen." + :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-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-parameters + "--no-daemon 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-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-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)))) + + +;;; 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-command-prefix (dependencies) + "Return a list of boot artifact strings created from DEPENDENCIES." + (concat (mapconcat #'cider--list-as-boot-artifact dependencies " ") + " ")) + +(defun cider-boot-repl-task-params (params middlewares) + (if (string-match "\\_" params) + (replace-match (concat "repl " + (mapconcat (lambda (middleware) + (format "-m %s" (shell-quote-argument middleware))) + middlewares + " ")) + 'fixed 'literal params) + (message "Warning: `cider-boot-parameters' doesn't call the \"repl\" task, jacking-in might not work") + params)) + +(defun cider-boot-jack-in-dependencies (params dependencies plugins middlewares) + (concat (cider-boot-command-prefix (append dependencies plugins)) + (cider-boot-repl-task-params 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 (params dependencies dependencies-exclusions lein-plugins) + (concat + (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 (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 + 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 + params + (cider-add-clojure-dependencies-maybe + cider-jack-in-dependencies) + cider-jack-in-lein-plugins + cider-jack-in-nrepl-middlewares)) + ("gradle" params) + (_ (error "Unsupported project type `%s'" project-type)))) + + +;;; 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 Readme for additional configuration)"))) + +(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)) + :group 'cider) + +(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))) + (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 cider-cljs-lein-repl 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) + "session" nrepl-session + "code" cider-cljs-lein-repl) + (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-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 params project-type) + params)) + + (cmd (format "%s %s" command-resolved params))) + (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 "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)))) + (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 (file-remote-p default-directory) + (executable-find cider-lein-command) + (executable-find (concat cider-lein-command ".bat"))))) + (shell-quote-argument command))) + +(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 (file-remote-p default-directory) + (executable-find cider-boot-command) + (executable-find (concat cider-boot-command ".exe"))))) + (shell-quote-argument command))) + +(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 (file-remote-p default-directory) + (executable-find cider-gradle-command) + (executable-find (concat cider-gradle-command ".exe"))))) + (shell-quote-argument command))) + + +;;; 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" + "Clojure version information could not be determined. Requires a minimum version %s." + 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 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 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 diff --git a/elpa/cider-20160914.2335/nrepl-client.el b/elpa/cider-20160914.2335/nrepl-client.el new file mode 100644 index 0000000..fc26d3a --- /dev/null +++ b/elpa/cider-20160914.2335/nrepl-client.el @@ -0,0 +1,1227 @@ +;;; nrepl-client.el --- Client for Clojure nREPL -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . +;; +;; This file is not part of GNU Emacs. +;; +;;; Commentary: +;; +;; Provides 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 'cider-compat) +(require 'cl-lib) +(require 'nrepl-dict) +(require 'queue) +(require 'tramp) + + +;;; Custom + +(defgroup nrepl nil + "Interaction with the Clojure nREPL Server." + :prefix "nrepl-" + :group 'applications) + +(defcustom nrepl-buffer-name-separator " " + "Used in constructing the REPL buffer name. +The `nrepl-buffer-name-separator' separates cider-repl from the project name." + :type '(string) + :group 'nrepl) + +(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-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.") + + +;;; 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.") + + +;;; 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))) + + +;;; 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)))) + + +;;; 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)))) + + +;;; 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)))))) + + +;;; 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, 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) + (or (and host (not nrepl-force-ssh-for-remote-hosts) + (nrepl--direct-connect host port 'no-error)) + (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))))))))) + + +;;; 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))) + (nrepl-dbind-response response-main (new-session err) + (if new-session + (with-current-buffer client-conn + (setq nrepl-session new-session)) + (error "Could not create new session (%s)" err))) + (nrepl-dbind-response response-tooling (new-session err) + (if new-session + (with-current-buffer client-conn + (setq nrepl-tooling-session new-session)) + (error "Could not create new tooling session (%s)" err))))) + +(defun nrepl--init-capabilities (conn-buffer) + "Store locally in CONN-BUFFER the capabilities of nREPL server." + (let ((description (nrepl-sync-request:describe conn-buffer))) + (nrepl-dbind-response description (ops versions aux) + (with-current-buffer conn-buffer + (setq nrepl-ops ops) + (setq nrepl-versions versions) + (setq nrepl-aux aux))))) + +(defun nrepl--clear-client-sessions (conn-buffer) + "Clear information about nREPL sessions in CONN-BUFFER. +CONN-BUFFER refers to a (presumably) dead connection, which we can eventually reuse." + (with-current-buffer conn-buffer + (setq nrepl-session nil) + (setq nrepl-tooling-session nil))) + + +;;; Client: Response Handling +;; After being decoded, responses (aka, messages from the server) are dispatched +;; to handlers. Handlers are constructed with `nrepl-make-response-handler'. + +(defvar nrepl-err-handler nil + "Evaluation error handler.") + +(defun nrepl--mark-id-completed (id) + "Move ID from `nrepl-pending-requests' to `nrepl-completed-requests'. +It is safe to call this function multiple times on the same ID." + ;; FIXME: This should go away eventually when we get rid of + ;; pending-request hash table + (when-let ((handler (gethash id nrepl-pending-requests))) + (puthash id handler nrepl-completed-requests) + (remhash id nrepl-pending-requests))) + +(defvar cider-buffer-ns) +(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)))))))) + + +;;; 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) + "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. +Return the ID of the sent message." + (with-current-buffer connection + (when (and (not (lax-plist-get request "session")) + nrepl-session) + (setq request (append request (list "session" nrepl-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) + "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." + (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) + (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 session) + "Send a :stdin request with INPUT using CONNECTION and SESSION. +Register CALLBACK as the response handler." + (nrepl-send-request (list "op" "stdin" + "stdin" input + "session" session) + callback + connection)) + +(defun nrepl-request:interrupt (pending-request-id callback connection session) + "Send an :interrupt request for PENDING-REQUEST-ID. +The request is dispatched using CONNECTION and SESSION. +Register CALLBACK as the response handler." + (nrepl-send-request (list "op" "interrupt" + "session" session + "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 session &optional ns line column) + "Prepare :eval request message for INPUT. +SESSION and NS provide 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" + "session" session + "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 session ns line column additional-params) + "Send the request INPUT and register the CALLBACK as the response handler. +The request is dispatched via CONNECTION and SESSION. 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." + (nrepl-send-request (append (nrepl--eval-request input session ns line column) additional-params) + callback + connection)) + +(defun nrepl-sync-request:clone (connection) + "Sent a :clone request to create a new client session. +The request is dispatched via CONNECTION." + (nrepl-send-sync-request '("op" "clone") + connection)) + +(defun nrepl-sync-request:close (connection session) + "Sent a :close request to close CONNECTION's SESSION." + (nrepl-send-sync-request (list "op" "close" "session" session) + connection)) + +(defun nrepl-sync-request:describe (connection &optional session) + "Perform :describe request for CONNECTION and SESSION." + (if session + (nrepl-send-sync-request (list "session" session "op" "describe") + connection) + (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 session &optional ns) + "Send the INPUT to the nREPL server synchronously. +The request is dispatched via CONNECTION and SESSION. +If NS is non-nil, include it in the request." + (nrepl-send-sync-request + (nrepl--eval-request input session 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")) + + +;;; 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 3 arguments. Once the +client process is started, the function is called with the server process, +the port, and 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))))) + + +;;; Messages + +(defcustom nrepl-log-messages t + "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." + :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 "") #'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) + (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--pp (nrepl-decorate-msg msg type) + (nrepl--message-color (lax-plist-get (cdr msg) "id"))) + (when-let ((win (get-buffer-window))) + (set-window-point win (point-max))) + (setq buffer-read-only t)))) + +(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--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)))) + +(defcustom nrepl-dict-max-message-size 5 + "Max number of lines a dict can have before being truncated. +Set this to nil to prevent truncation." + :type 'integer) + +(defun nrepl--expand-button (button) + "Expand the text hidden under overlay BUTTON." + (delete-overlay button)) + +(defun nrepl--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--expand-button (button-at point)))))) + +(define-button-type 'nrepl--collapsed-dict + 'display "..." + 'action #'nrepl--expand-button + 'face 'link + 'help-echo "RET: Expand dict.") + +(defun nrepl--pp (object &optional foreground) + "Pretty print nREPL OBJECT, delimited using FOREGROUND." + (if (not (and (listp object) + (memq (car object) '(<-- --> dict)))) + (progn (when (stringp object) + (setq object (substring-no-properties object))) + (pp object (current-buffer)) + (unless (listp object) (insert "\n"))) + (let ((head (format "(%s" (car object)))) + (cl-flet ((color (str) + (propertize str 'face (append '(:weight ultra-bold) + (when foreground `(:foreground ,foreground)))))) + (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--pp (cadr l)))) + (when (eq (car object) 'dict) + (delete-char -1) + (let ((truncate-lines t)) + (when (and nrepl-dict-max-message-size + (> (count-screen-lines l (point) t) + nrepl-dict-max-message-size)) + (make-button (1+ l) (point) + :type 'nrepl--collapsed-dict + ;; Workaround for bug#1568. + 'local-map '(keymap (mouse-1 . nrepl--expand-button-mouse)))))) + (insert (color ")\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 diff --git a/elpa/cider-20160914.2335/nrepl-dict.el b/elpa/cider-20160914.2335/nrepl-dict.el new file mode 100644 index 0000000..b6c77bb --- /dev/null +++ b/elpa/cider-20160914.2335/nrepl-dict.el @@ -0,0 +1,187 @@ +;;; nrepl-dict.el --- Dictionary functions for Clojure nREPL -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2016 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . +;; +;; This file is not part of GNU Emacs. +;; +;;; Commentary: +;; +;; Provides functions to interact with and create `nrepl-dict's. These are +;; simply plists with an extra element at the head. + +;;; Code: +(require 'cl-lib) + + +(defun nrepl-dict (&rest key-vals) + "Create nREPL dict from KEY-VALS." + (cons 'dict key-vals)) + +(defun nrepl-dict-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)))) + + +;;; 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))))) + + +;;; Dbind +(defmacro nrepl-dbind-response (response keys &rest body) + "Destructure an nREPL RESPONSE dict. +Bind the value of the provided KEYS and execute BODY." + (declare (debug (form (&rest symbolp) body))) + `(let ,(cl-loop for key in keys + collect `(,key (nrepl-dict-get ,response ,(format "%s" key)))) + ,@body)) +(put 'nrepl-dbind-response 'lisp-indent-function 2) + +(provide 'nrepl-dict) + +;;; nrepl-dict.el ends here diff --git a/elpa/clojure-mode-20160803.140/clojure-mode-autoloads.el b/elpa/clojure-mode-20160803.140/clojure-mode-autoloads.el new file mode 100644 index 0000000..7699933 --- /dev/null +++ b/elpa/clojure-mode-20160803.140/clojure-mode-autoloads.el @@ -0,0 +1,126 @@ +;;; clojure-mode-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil "clojure-mode" "clojure-mode.el" (22500 1824 +;;;;;; 812229 917000)) +;;; Generated autoloads from clojure-mode.el + +(autoload 'clojure-mode "clojure-mode" "\ +Major mode for editing Clojure code. + +\\{clojure-mode-map} + +\(fn)" t nil) + +(autoload 'clojure-unwind "clojure-mode" "\ +Unwind thread at point or above point by one level. +Return nil if there are no more levels to unwind. + +\(fn)" t nil) + +(autoload 'clojure-unwind-all "clojure-mode" "\ +Fully unwind thread at point or above point. + +\(fn)" t nil) + +(autoload 'clojure-thread "clojure-mode" "\ +Thread by one more level an existing threading macro. + +\(fn)" t nil) + +(autoload 'clojure-thread-first-all "clojure-mode" "\ +Fully thread the form at point using ->. +When BUT-LAST is passed the last expression is not threaded. + +\(fn BUT-LAST)" t nil) + +(autoload 'clojure-thread-last-all "clojure-mode" "\ +Fully thread the form at point using ->>. +When BUT-LAST is passed the last expression is not threaded. + +\(fn BUT-LAST)" t nil) + +(autoload 'clojure-cycle-privacy "clojure-mode" "\ +Make public the current private def, or vice-versa. +See: https://github.com/clojure-emacs/clj-refactor.el/wiki/cljr-cycle-privacy + +\(fn)" t nil) + +(autoload 'clojure-convert-collection-to-list "clojure-mode" "\ +Convert collection at (point) to list. + +\(fn)" t nil) + +(autoload 'clojure-convert-collection-to-quoted-list "clojure-mode" "\ +Convert collection at (point) to quoted list. + +\(fn)" t nil) + +(autoload 'clojure-convert-collection-to-map "clojure-mode" "\ +Convert collection at (point) to map. + +\(fn)" t nil) + +(autoload 'clojure-convert-collection-to-vector "clojure-mode" "\ +Convert collection at (point) to vector. + +\(fn)" t nil) + +(autoload 'clojure-convert-collection-to-set "clojure-mode" "\ +Convert collection at (point) to set. + +\(fn)" t nil) + +(autoload 'clojure-cycle-if "clojure-mode" "\ +Change a surrounding if to if-not, or vice-versa. + +See: https://github.com/clojure-emacs/clj-refactor.el/wiki/cljr-cycle-if + +\(fn)" t nil) + +(autoload 'clojurescript-mode "clojure-mode" "\ +Major mode for editing ClojureScript code. + +\\{clojurescript-mode-map} + +\(fn)" t nil) + +(autoload 'clojurec-mode "clojure-mode" "\ +Major mode for editing ClojureC code. + +\\{clojurec-mode-map} + +\(fn)" t nil) + +(autoload 'clojurex-mode "clojure-mode" "\ +Major mode for editing ClojureX code. + +\\{clojurex-mode-map} + +\(fn)" t nil) + +(add-to-list 'auto-mode-alist '("\\.\\(clj\\|dtm\\|edn\\)\\'" . clojure-mode)) + +(add-to-list 'auto-mode-alist '("\\.cljc\\'" . clojurec-mode)) + +(add-to-list 'auto-mode-alist '("\\.cljx\\'" . clojurex-mode)) + +(add-to-list 'auto-mode-alist '("\\.cljs\\'" . clojurescript-mode)) + +(add-to-list 'auto-mode-alist '("\\(?:build\\|profile\\)\\.boot\\'" . clojure-mode)) + +;;;*** + +;;;### (autoloads nil nil ("clojure-mode-pkg.el") (22500 1824 819441 +;;;;;; 379000)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; clojure-mode-autoloads.el ends here diff --git a/elpa/clojure-mode-20160803.140/clojure-mode-pkg.el b/elpa/clojure-mode-20160803.140/clojure-mode-pkg.el new file mode 100644 index 0000000..e0f2459 --- /dev/null +++ b/elpa/clojure-mode-20160803.140/clojure-mode-pkg.el @@ -0,0 +1 @@ +(define-package "clojure-mode" "20160803.140" "Major mode for Clojure code" '((emacs "24.3")) :url "http://github.com/clojure-emacs/clojure-mode" :keywords '("languages" "clojure" "clojurescript" "lisp")) diff --git a/elpa/clojure-mode-20160803.140/clojure-mode.el b/elpa/clojure-mode-20160803.140/clojure-mode.el new file mode 100644 index 0000000..684cb89 --- /dev/null +++ b/elpa/clojure-mode-20160803.140/clojure-mode.el @@ -0,0 +1,2004 @@ +;;; clojure-mode.el --- Major mode for Clojure code -*- lexical-binding: t; -*- + +;; Copyright © 2007-2016 Jeffrey Chu, Lennart Staflin, Phil Hagelberg +;; Copyright © 2013-2016 Bozhidar Batsov, Artur Malabarba +;; +;; Authors: Jeffrey Chu +;; Lennart Staflin +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; URL: http://github.com/clojure-emacs/clojure-mode +;; Package-Version: 20160803.140 +;; Keywords: languages clojure clojurescript lisp +;; Version: 5.5.2 +;; Package-Requires: ((emacs "24.3")) + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Provides font-lock, indentation, navigation and basic refactoring for the +;; Clojure programming language (http://clojure.org). + +;; Using clojure-mode with paredit or smartparens is highly recommended. + +;; Here are some example configurations: + +;; ;; require or autoload paredit-mode +;; (add-hook 'clojure-mode-hook #'paredit-mode) + +;; ;; require or autoload smartparens +;; (add-hook 'clojure-mode-hook #'smartparens-strict-mode) + +;; See inf-clojure (http://github.com/clojure-emacs/inf-clojure) for +;; basic interaction with Clojure subprocesses. + +;; See CIDER (http://github.com/clojure-emacs/cider) for +;; better interaction with subprocesses via nREPL. + +;;; License: + +;; 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Code: + + +(eval-when-compile + (defvar calculate-lisp-indent-last-sexp) + (defvar font-lock-beg) + (defvar font-lock-end) + (defvar paredit-space-for-delimiter-predicates) + (defvar paredit-version) + (defvar paredit-mode)) + +(require 'cl-lib) +(require 'imenu) +(require 'newcomment) +(require 'align) + +(declare-function lisp-fill-paragraph "lisp-mode" (&optional justify)) + +(defgroup clojure nil + "Major mode for editing Clojure code." + :prefix "clojure-" + :group 'languages + :link '(url-link :tag "Github" "https://github.com/clojure-emacs/clojure-mode") + :link '(emacs-commentary-link :tag "Commentary" "clojure-mode")) + +(defconst clojure-mode-version "5.5.2" + "The current version of `clojure-mode'.") + +(defface clojure-keyword-face + '((t (:inherit font-lock-constant-face))) + "Face used to font-lock Clojure keywords (:something)." + :package-version '(clojure-mode . "3.0.0")) + +(defface clojure-character-face + '((t (:inherit font-lock-string-face))) + "Face used to font-lock Clojure character literals." + :package-version '(clojure-mode . "3.0.0")) + +(defface clojure-interop-method-face + '((t (:inherit font-lock-preprocessor-face))) + "Face used to font-lock interop method names (camelCase)." + :package-version '(clojure-mode . "3.0.0")) + +(defcustom clojure-indent-style :always-align + "Indentation style to use for function forms and macro forms. +There are two cases of interest configured by this variable. + +- Case (A) is when at least one function argument is on the same + line as the function name. +- Case (B) is the opposite (no arguments are on the same line as + the function name). Note that the body of macros is not + affected by this variable, it is always indented by + `lisp-body-indent' (default 2) spaces. + +Note that this variable configures the indentation of function +forms (and function-like macros), it does not affect macros that +already use special indentation rules. + +The possible values for this variable are keywords indicating how +to indent function forms. + + `:always-align' - Follow the same rules as `lisp-mode'. All + args are vertically aligned with the first arg in case (A), + and vertically aligned with the function name in case (B). + For instance: + (reduce merge + some-coll) + (reduce + merge + some-coll) + + `:always-indent' - All args are indented like a macro body. + (reduce merge + some-coll) + (reduce + merge + some-coll) + + `:align-arguments' - Case (A) is indented like `lisp', and + case (B) is indented like a macro body. + (reduce merge + some-coll) + (reduce + merge + some-coll)" + :safe #'keywordp + :type '(choice (const :tag "Same as `lisp-mode'" :always-align) + (const :tag "Indent like a macro body" :always-indent) + (const :tag "Indent like a macro body unless first arg is on the same line" + :align-arguments)) + :package-version '(clojure-mode . "5.2.0")) + +(define-obsolete-variable-alias 'clojure-defun-style-default-indent + 'clojure-indent-style "5.2.0") + +(defcustom clojure-use-backtracking-indent t + "When non-nil, enable context sensitive indentation." + :type 'boolean + :safe 'booleanp) + +(defcustom clojure-max-backtracking 3 + "Maximum amount to backtrack up a list to check for context." + :type 'integer + :safe 'integerp) + +(defcustom clojure-docstring-fill-column fill-column + "Value of `fill-column' to use when filling a docstring." + :type 'integer + :safe 'integerp) + +(defcustom clojure-docstring-fill-prefix-width 2 + "Width of `fill-prefix' when filling a docstring. +The default value conforms with the de facto convention for +Clojure docstrings, aligning the second line with the opening +double quotes on the third column." + :type 'integer + :safe 'integerp) + +(defcustom clojure-omit-space-between-tag-and-delimiters '(?\[ ?\{) + "Allowed opening delimiter characters after a reader literal tag. +For example, \[ is allowed in :db/id[:db.part/user]." + :type '(set (const :tag "[" ?\[) + (const :tag "{" ?\{) + (const :tag "(" ?\() + (const :tag "\"" ?\")) + :safe (lambda (value) + (and (listp value) + (cl-every 'characterp value)))) + +(defcustom clojure-build-tool-files '("project.clj" "build.boot" "build.gradle") + "A list of files, which identify a Clojure project's root. +Out-of-the box clojure-mode understands lein, boot and gradle." + :type '(repeat string) + :package-version '(clojure-mode . "5.0.0") + :safe (lambda (value) + (and (listp value) + (cl-every 'stringp value)))) + +(defvar clojure-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-:") #'clojure-toggle-keyword-string) + (define-key map (kbd "C-c SPC") #'clojure-align) + (define-key map (kbd "C-c C-r C-t") #'clojure-thread) + (define-key map (kbd "C-c C-r t") #'clojure-thread) + (define-key map (kbd "C-c C-r C-u") #'clojure-unwind) + (define-key map (kbd "C-c C-r u") #'clojure-unwind) + (define-key map (kbd "C-c C-r C-f") #'clojure-thread-first-all) + (define-key map (kbd "C-c C-r f") #'clojure-thread-first-all) + (define-key map (kbd "C-c C-r C-l") #'clojure-thread-last-all) + (define-key map (kbd "C-c C-r l") #'clojure-thread-last-all) + (define-key map (kbd "C-c C-r C-a") #'clojure-unwind-all) + (define-key map (kbd "C-c C-r a") #'clojure-unwind-all) + (define-key map (kbd "C-c C-r C-p") #'clojure-cycle-privacy) + (define-key map (kbd "C-c C-r p") #'clojure-cycle-privacy) + (define-key map (kbd "C-c C-r C-(") #'clojure-convert-collection-to-list) + (define-key map (kbd "C-c C-r (") #'clojure-convert-collection-to-list) + (define-key map (kbd "C-c C-r C-'") #'clojure-convert-collection-to-quoted-list) + (define-key map (kbd "C-c C-r '") #'clojure-convert-collection-to-quoted-list) + (define-key map (kbd "C-c C-r C-{") #'clojure-convert-collection-to-map) + (define-key map (kbd "C-c C-r {") #'clojure-convert-collection-to-map) + (define-key map (kbd "C-c C-r C-[") #'clojure-convert-collection-to-vector) + (define-key map (kbd "C-c C-r [") #'clojure-convert-collection-to-vector) + (define-key map (kbd "C-c C-r C-#") #'clojure-convert-collection-to-set) + (define-key map (kbd "C-c C-r #") #'clojure-convert-collection-to-set) + (define-key map (kbd "C-c C-r C-i") #'clojure-cycle-if) + (define-key map (kbd "C-c C-r i") #'clojure-cycle-if) + (define-key map (kbd "C-c C-r n i") #'clojure-insert-ns-form) + (define-key map (kbd "C-c C-r n h") #'clojure-insert-ns-form-at-point) + (define-key map (kbd "C-c C-r n u") #'clojure-update-ns) + (define-key map (kbd "C-c C-r n s") #'clojure-sort-ns) + (easy-menu-define clojure-mode-menu map "Clojure Mode Menu" + '("Clojure" + ["Toggle between string & keyword" clojure-toggle-keyword-string] + ["Align expression" clojure-align] + ["Cycle privacy" clojure-cycle-privacy] + ["Cycle if, if-not" clojure-cycle-if] + ("ns forms" + ["Insert ns form at the top" clojure-insert-ns-form] + ["Insert ns form here" clojure-insert-ns-form-at-point] + ["Update ns form" clojure-update-ns] + ["Sort ns form" clojure-sort-ns]) + ("Convert collection" + ["Convert to list" clojure-convert-collection-to-list] + ["Convert to quoted list" clojure-convert-collection-to-quoted-list] + ["Convert to map" clojure-convert-collection-to-map] + ["Convert to vector" clojure-convert-collection-to-vector] + ["Convert to set" clojure-convert-collection-to-set]) + ("Refactor -> and ->>" + ["Thread once more" clojure-thread] + ["Fully thread a form with ->" clojure-thread-first-all] + ["Fully thread a form with ->>" clojure-thread-last-all] + "--" + ["Unwind once" clojure-unwind] + ["Fully unwind a threading macro" clojure-unwind-all]) + "--" + ["Clojure-mode version" clojure-mode-display-version])) + map) + "Keymap for Clojure mode.") + +(defvar clojure-mode-syntax-table + (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) + (modify-syntax-entry ?\{ "(}" table) + (modify-syntax-entry ?\} "){" table) + (modify-syntax-entry ?\[ "(]" table) + (modify-syntax-entry ?\] ")[" table) + (modify-syntax-entry ?? "_ p" table) ; ? is a prefix outside symbols + (modify-syntax-entry ?# "_ p" table) ; # is allowed inside keywords (#399) + (modify-syntax-entry ?~ "'" table) + (modify-syntax-entry ?^ "'" table) + (modify-syntax-entry ?@ "'" table) + table) + "Syntax table for Clojure mode. +Inherits from `emacs-lisp-mode-syntax-table'.") + +(defconst clojure--prettify-symbols-alist + '(("fn" . ?λ))) + +(defvar-local clojure-expected-ns-function nil + "The function used to determine the expected namespace of a file. +`clojure-mode' ships a basic function named `clojure-expected-ns' +that does basic heuristics to figure this out. +CIDER provides a more complex version which does classpath analysis.") + +(defun clojure-mode-display-version () + "Display the current `clojure-mode-version' in the minibuffer." + (interactive) + (message "clojure-mode (version %s)" clojure-mode-version)) + +(defun clojure-space-for-delimiter-p (endp delim) + "Prevent paredit from inserting useless spaces. +See `paredit-space-for-delimiter-predicates' for the meaning of +ENDP and DELIM." + (or endp + (not (memq delim '(?\" ?{ ?\( ))) + (not (or (derived-mode-p 'clojure-mode) + (derived-mode-p 'cider-repl-mode))) + (save-excursion + (backward-char) + (cond ((eq (char-after) ?#) + (and (not (bobp)) + (or (char-equal ?w (char-syntax (char-before))) + (char-equal ?_ (char-syntax (char-before)))))) + ((and (eq delim ?\() + (eq (char-after) ??) + (eq (char-before) ?#)) + nil) + (t))))) + +(defun clojure-no-space-after-tag (endp delimiter) + "Prevent inserting a space after a reader-literal tag? + +When a reader-literal tag is followed be an opening delimiter +listed in `clojure-omit-space-between-tag-and-delimiters', this +function returns t. + +This allows you to write things like #db/id[:db.part/user] +without inserting a space between the tag and the opening +bracket. + +See `paredit-space-for-delimiter-predicates' for the meaning of +ENDP and DELIMITER." + (if endp + t + (or (not (member delimiter clojure-omit-space-between-tag-and-delimiters)) + (save-excursion + (let ((orig-point (point))) + (not (and (re-search-backward + "#\\([a-zA-Z0-9._-]+/\\)?[a-zA-Z0-9._-]+" + (line-beginning-position) + t) + (= orig-point (match-end 0))))))))) + +(declare-function paredit-open-curly "ext:paredit") +(declare-function paredit-close-curly "ext:paredit") + +(defun clojure-paredit-setup (&optional keymap) + "Make \"paredit-mode\" play nice with `clojure-mode'. + +If an optional KEYMAP is passed the changes are applied to it, +instead of to `clojure-mode-map'." + (when (>= paredit-version 21) + (let ((keymap (or keymap clojure-mode-map))) + (define-key keymap "{" #'paredit-open-curly) + (define-key keymap "}" #'paredit-close-curly)) + (add-to-list 'paredit-space-for-delimiter-predicates + #'clojure-space-for-delimiter-p) + (add-to-list 'paredit-space-for-delimiter-predicates + #'clojure-no-space-after-tag))) + +(defun clojure-mode-variables () + "Set up initial buffer-local variables for Clojure mode." + (add-to-list 'imenu-generic-expression '(nil clojure-match-next-def 0)) + (setq-local indent-tabs-mode nil) + (setq-local paragraph-ignore-fill-prefix t) + (setq-local outline-regexp ";;;\\(;* [^ \t\n]\\)\\|(") + (setq-local outline-level 'lisp-outline-level) + (setq-local comment-start ";") + (setq-local comment-start-skip ";+ *") + (setq-local comment-add 1) ; default to `;;' in comment-region + (setq-local comment-column 40) + (setq-local comment-use-syntax t) + (setq-local multibyte-syntax-as-symbol t) + (setq-local electric-pair-skip-whitespace 'chomp) + (setq-local electric-pair-open-newline-between-pairs nil) + (setq-local fill-paragraph-function #'clojure-fill-paragraph) + (setq-local adaptive-fill-function #'clojure-adaptive-fill-function) + (setq-local normal-auto-fill-function #'clojure-auto-fill-function) + (setq-local comment-start-skip + "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") + (setq-local indent-line-function #'clojure-indent-line) + (setq-local indent-region-function #'clojure-indent-region) + (setq-local lisp-indent-function #'clojure-indent-function) + (setq-local lisp-doc-string-elt-property 'clojure-doc-string-elt) + (setq-local clojure-expected-ns-function #'clojure-expected-ns) + (setq-local parse-sexp-ignore-comments t) + (setq-local prettify-symbols-alist clojure--prettify-symbols-alist) + (setq-local open-paren-in-column-0-is-defun-start nil)) + +;;;###autoload +(define-derived-mode clojure-mode prog-mode "Clojure" + "Major mode for editing Clojure code. + +\\{clojure-mode-map}" + (clojure-mode-variables) + (clojure-font-lock-setup) + (add-hook 'paredit-mode-hook #'clojure-paredit-setup)) + +(defcustom clojure-verify-major-mode t + "If non-nil, warn when activating the wrong major-mode." + :type 'boolean + :safe #'booleanp + :package-version '(clojure-mode "5.3.0")) + +(defun clojure--check-wrong-major-mode () + "Check if the current major-mode matches the file extension. +If it doesn't, issue a warning if `clojure-verify-major-mode' is +non-nil." + (when (and clojure-verify-major-mode + (stringp (buffer-file-name))) + (let* ((case-fold-search t) + (problem (cond ((and (string-match "\\.clj\\'" (buffer-file-name)) + (not (eq major-mode 'clojure-mode))) + 'clojure-mode) + ((and (string-match "\\.cljs\\'" (buffer-file-name)) + (not (eq major-mode 'clojurescript-mode))) + 'clojurescript-mode) + ((and (string-match "\\.cljc\\'" (buffer-file-name)) + (not (eq major-mode 'clojurec-mode))) + 'clojurec-mode) + ((and (string-match "\\.cljx\\'" (buffer-file-name)) + (not (eq major-mode 'clojurex-mode))) + 'clojurex-mode)))) + (when problem + (message "[WARNING] %s activated `%s' instead of `%s' in this buffer. +This could cause problems. +\(See `clojure-verify-major-mode' to disable this message.)" + (if (eq major-mode real-this-command) + "You have" + "Something in your configuration") + major-mode + problem))))) + +(add-hook 'clojure-mode-hook #'clojure--check-wrong-major-mode) + +(defsubst clojure-in-docstring-p () + "Check whether point is in a docstring." + (eq (get-text-property (point) 'face) 'font-lock-doc-face)) + +(defsubst clojure-docstring-fill-prefix () + "The prefix string used by `clojure-fill-paragraph'. + +It is simply `clojure-docstring-fill-prefix-width' number of spaces." + (make-string clojure-docstring-fill-prefix-width ? )) + +(defun clojure-adaptive-fill-function () + "Clojure adaptive fill function. +This only takes care of filling docstring correctly." + (when (clojure-in-docstring-p) + (clojure-docstring-fill-prefix))) + +(defun clojure-fill-paragraph (&optional justify) + "Like `fill-paragraph', but can handle Clojure docstrings. + +If JUSTIFY is non-nil, justify as well as fill the paragraph." + (if (clojure-in-docstring-p) + (let ((paragraph-start + (concat paragraph-start + "\\|\\s-*\\([(;:\"[]\\|~@\\|`(\\|#'(\\)")) + (paragraph-separate + (concat paragraph-separate "\\|\\s-*\".*[,\\.]$")) + (fill-column (or clojure-docstring-fill-column fill-column)) + (fill-prefix (clojure-docstring-fill-prefix))) + (fill-paragraph justify)) + (let ((paragraph-start (concat paragraph-start + "\\|\\s-*\\([(;:\"[]\\|`(\\|#'(\\)")) + (paragraph-separate + (concat paragraph-separate "\\|\\s-*\".*[,\\.[]$"))) + (or (fill-comment-paragraph justify) + (fill-paragraph justify)) + ;; Always return `t' + t))) + +(defun clojure-auto-fill-function () + "Clojure auto-fill function." + ;; Check if auto-filling is meaningful. + (let ((fc (current-fill-column))) + (when (and fc (> (current-column) fc)) + (let ((fill-column (if (clojure-in-docstring-p) + clojure-docstring-fill-column + fill-column)) + (fill-prefix (clojure-adaptive-fill-function))) + (do-auto-fill))))) + + +;;; #_ comments font-locking +;; Code heavily borrowed from Slime. +;; https://github.com/slime/slime/blob/master/contrib/slime-fontifying-fu.el#L186 +(defvar clojure--comment-macro-regexp + (rx "#_" (* " ") (group-n 1 (not (any " ")))) + "Regexp matching the start of a comment sexp. +The beginning of match-group 1 should be before the sexp to be +marked as a comment. The end of sexp is found with +`clojure-forward-logical-sexp'. + +By default, this only applies to code after the `#_' reader +macro. In order to also font-lock the `(comment ...)' macro as a +comment, you can set the value to: + \"#_ *\\\\(?1:[^ ]\\\\)\\\\|\\\\(?1:(comment\\\\_>\\\\)\"") + +(defun clojure--search-comment-macro-internal (limit) + (when (search-forward-regexp clojure--comment-macro-regexp limit t) + (let* ((md (match-data)) + (start (match-beginning 1)) + (state (syntax-ppss start))) + ;; inside string or comment? + (if (or (nth 3 state) + (nth 4 state)) + (clojure--search-comment-macro-internal limit) + (goto-char start) + (clojure-forward-logical-sexp 1) + ;; Data for (match-end 1). + (setf (elt md 3) (point)) + (set-match-data md) + t)))) + +(defun clojure--search-comment-macro (limit) + "Find comment macros and set the match data. +Search from point up to LIMIT. The region that should be +considered a comment is between `(match-beginning 1)' +and `(match-end 1)'." + (let ((result 'retry)) + (while (and (eq result 'retry) (<= (point) limit)) + (condition-case nil + (setq result (clojure--search-comment-macro-internal limit)) + (end-of-file (setq result nil)) + (scan-error (setq result 'retry)))) + result)) + + +;;; General font-locking +(defun clojure-match-next-def () + "Scans the buffer backwards for the next \"top-level\" definition. +Called by `imenu--generic-function'." + ;; we have to take into account namespace-definition forms + ;; e.g. s/defn + (when (re-search-backward "^(\\([a-z0-9.-]+/\\)?def\\sw*" nil t) + (save-excursion + (let (found? + (start (point))) + (down-list) + (forward-sexp) + (while (not found?) + (forward-sexp) + (or (if (char-equal ?[ (char-after (point))) + (backward-sexp)) + (if (char-equal ?) (char-after (point))) + (backward-sexp))) + (cl-destructuring-bind (def-beg . def-end) (bounds-of-thing-at-point 'sexp) + (if (char-equal ?^ (char-after def-beg)) + (progn (forward-sexp) (backward-sexp)) + (setq found? t) + (set-match-data (list def-beg def-end))))) + (goto-char start))))) + +(eval-and-compile + (defconst clojure--sym-forbidden-rest-chars "][\";\'@\\^`~\(\)\{\}\\,\s\t\n\r" + "A list of chars that a Clojure symbol cannot contain. +See definition of 'macros': URL `http://git.io/vRGLD'.") + (defconst clojure--sym-forbidden-1st-chars (concat clojure--sym-forbidden-rest-chars "0-9:") + "A list of chars that a Clojure symbol cannot start with. +See the for-loop: URL `http://git.io/vRGTj' lines: URL +`http://git.io/vRGIh', URL `http://git.io/vRGLE' and value +definition of 'macros': URL `http://git.io/vRGLD'.") + (defconst clojure--sym-regexp + (concat "[^" clojure--sym-forbidden-1st-chars "][^" clojure--sym-forbidden-rest-chars "]*") + "A regexp matching a Clojure symbol or namespace alias. +Matches the rule `clojure--sym-forbidden-1st-chars' followed by +any number of matches of `clojure--sym-forbidden-rest-chars'.")) + +(defconst clojure-font-lock-keywords + (eval-when-compile + `( ;; Top-level variable definition + (,(concat "(\\(?:clojure.core/\\)?\\(" + (regexp-opt '("def" "defonce")) + ;; variable declarations + "\\)\\>" + ;; Any whitespace + "[ \r\n\t]*" + ;; Possibly type or metadata + "\\(?:#?^\\(?:{[^}]*}\\|\\sw+\\)[ \r\n\t]*\\)*" + "\\(\\sw+\\)?") + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face nil t)) + ;; Type definition + (,(concat "(\\(?:clojure.core/\\)?\\(" + (regexp-opt '("defstruct" "deftype" "defprotocol" + "defrecord")) + ;; type declarations + "\\)\\>" + ;; Any whitespace + "[ \r\n\t]*" + ;; Possibly type or metadata + "\\(?:#?^\\(?:{[^}]*}\\|\\sw+\\)[ \r\n\t]*\\)*" + "\\(\\sw+\\)?") + (1 font-lock-keyword-face) + (2 font-lock-type-face nil t)) + ;; Function definition (anything that starts with def and is not + ;; listed above) + (,(concat "(\\(?:" clojure--sym-regexp "/\\)?" + "\\(def[^ \r\n\t]*\\)" + ;; Function declarations + "\\>" + ;; Any whitespace + "[ \r\n\t]*" + ;; Possibly type or metadata + "\\(?:#?^\\(?:{[^}]*}\\|\\sw+\\)[ \r\n\t]*\\)*" + "\\(\\sw+\\)?") + (1 font-lock-keyword-face) + (2 font-lock-function-name-face nil t)) + ;; (fn name? args ...) + (,(concat "(\\(?:clojure.core/\\)?\\(fn\\)[ \t]+" + ;; Possibly type + "\\(?:#?^\\sw+[ \t]*\\)?" + ;; Possibly name + "\\(\\sw+\\)?" ) + (1 font-lock-keyword-face) + (2 font-lock-function-name-face nil t)) + ;; lambda arguments - %, %&, %1, %2, etc + ("\\<%[&1-9]?" (0 font-lock-variable-name-face)) + ;; Special forms + (,(concat + "(" + (regexp-opt + '("def" "do" "if" "let" "let*" "var" "fn" "fn*" "loop" "loop*" + "recur" "throw" "try" "catch" "finally" + "set!" "new" "." + "monitor-enter" "monitor-exit" "quote") t) + "\\>") + 1 font-lock-keyword-face) + ;; Built-in binding and flow of control forms + (,(concat + "(\\(?:clojure.core/\\)?" + (regexp-opt + '("letfn" "case" "cond" "cond->" "cond->>" "condp" + "for" "when" "when-not" "when-let" "when-first" "when-some" + "if-let" "if-not" "if-some" + ".." "->" "->>" "as->" "doto" "and" "or" + "dosync" "doseq" "dotimes" "dorun" "doall" + "ns" "in-ns" + "with-open" "with-local-vars" "binding" + "with-redefs" "with-redefs-fn" + "declare") t) + "\\>") + 1 font-lock-keyword-face) + ;; Macros similar to let, when, and while + (,(rx symbol-start + (or "let" "when" "while") "-" + (1+ (or (syntax word) (syntax symbol))) + symbol-end) + 0 font-lock-keyword-face) + (,(concat + "\\<" + (regexp-opt + '("*1" "*2" "*3" "*agent*" + "*allow-unresolved-vars*" "*assert*" "*clojure-version*" + "*command-line-args*" "*compile-files*" + "*compile-path*" "*data-readers*" "*default-data-reader-fn*" + "*e" "*err*" "*file*" "*flush-on-newline*" + "*in*" "*macro-meta*" "*math-context*" "*ns*" "*out*" + "*print-dup*" "*print-length*" "*print-level*" + "*print-meta*" "*print-readably*" + "*read-eval*" "*source-path*" + "*unchecked-math*" + "*use-context-classloader*" "*warn-on-reflection*") + t) + "\\>") + 0 font-lock-builtin-face) + ;; Dynamic variables - *something* or @*something* + ("\\(?:\\<\\|/\\)@?\\(\\*[a-z-]*\\*\\)\\>" 1 font-lock-variable-name-face) + ;; Global constants - nil, true, false + (,(concat + "\\<" + (regexp-opt + '("true" "false" "nil") t) + "\\>") + 0 font-lock-constant-face) + ;; Character literals - \1, \a, \newline, \u0000 + ("\\\\\\([[:punct:]]\\|[a-z0-9]+\\>\\)" 0 'clojure-character-face) + ;; foo/ Foo/ @Foo/ /FooBar + (,(concat "\\(?:\\<:?\\|\\.\\)@?\\(" clojure--sym-regexp "\\)\\(/\\)") + (1 font-lock-type-face) (2 'default)) + ;; Constant values (keywords), including as metadata e.g. ^:static + ("\\<^?\\(:\\(\\sw\\|\\s_\\)+\\(\\>\\|\\_>\\)\\)" 1 'clojure-keyword-face append) + ;; Java interop highlighting + ;; CONST SOME_CONST (optionally prefixed by /) + ("\\(?:\\<\\|/\\)\\([A-Z]+\\|\\([A-Z]+_[A-Z1-9_]+\\)\\)\\>" 1 font-lock-constant-face) + ;; .foo .barBaz .qux01 .-flibble .-flibbleWobble + ("\\<\\.-?[a-z][a-zA-Z0-9]*\\>" 0 'clojure-interop-method-face) + ;; Foo Bar$Baz Qux_ World_OpenUDP Foo. Babylon15. + ("\\(?:\\<\\|\\.\\|/\\|#?^\\)\\([A-Z][a-zA-Z0-9_]*[a-zA-Z0-9$_]+\\.?\\>\\)" 1 font-lock-type-face) + ;; foo.bar.baz + ("\\<^?\\([a-z][a-z0-9_-]+\\.\\([a-z][a-z0-9_-]*\\.?\\)+\\)" 1 font-lock-type-face) + ;; (ns namespace) - special handling for single segment namespaces + (,(concat "(\\[ \r\n\t]*" + ;; Possibly metadata + "\\(?:\\^?{[^}]+}[ \r\n\t]*\\)*" + ;; namespace + "\\([a-z0-9-]+\\)") + (1 font-lock-type-face nil t)) + ;; fooBar + ("\\(?:\\<\\|/\\)\\([a-z]+[A-Z]+[a-zA-Z0-9$]*\\>\\)" 1 'clojure-interop-method-face) + ;; #_ and (comment ...) macros. + (clojure--search-comment-macro 1 font-lock-comment-face t) + ;; Highlight `code` marks, just like `elisp'. + (,(rx "`" (group-n 1 (optional "#'") + (+ (or (syntax symbol) (syntax word)))) "`") + (1 'font-lock-constant-face prepend)) + ;; Highlight escaped characters in strings. + (clojure-font-lock-escaped-chars 0 'bold prepend) + ;; Highlight grouping constructs in regular expressions + (clojure-font-lock-regexp-groups + (1 'font-lock-regexp-grouping-construct prepend)))) + "Default expressions to highlight in Clojure mode.") + +(defun clojure-font-lock-syntactic-face-function (state) + "Find and highlight text with a Clojure-friendly syntax table. + +This function is passed to `font-lock-syntactic-face-function', +which is called with a single parameter, STATE (which is, in +turn, returned by `parse-partial-sexp' at the beginning of the +highlighted region)." + (if (nth 3 state) + ;; This might be a (doc)string or a |...| symbol. + (let ((startpos (nth 8 state))) + (if (eq (char-after startpos) ?|) + ;; This is not a string, but a |...| symbol. + nil + (let* ((listbeg (nth 1 state)) + (firstsym (and listbeg + (save-excursion + (goto-char listbeg) + (and (looking-at "([ \t\n]*\\(\\(\\sw\\|\\s_\\)+\\)") + (match-string 1))))) + (docelt (and firstsym + (function-get (intern-soft firstsym) + lisp-doc-string-elt-property)))) + (if (and docelt + ;; It's a string in a form that can have a docstring. + ;; Check whether it's in docstring position. + (save-excursion + (when (functionp docelt) + (goto-char (match-end 1)) + (setq docelt (funcall docelt))) + (goto-char listbeg) + (forward-char 1) + (condition-case nil + (while (and (> docelt 0) (< (point) startpos) + (progn (forward-sexp 1) t)) + ;; ignore metadata and type hints + (unless (looking-at "[ \n\t]*\\(\\^[A-Z:].+\\|\\^?{.+\\)") + (setq docelt (1- docelt)))) + (error nil)) + (and (zerop docelt) (<= (point) startpos) + (progn (forward-comment (point-max)) t) + (= (point) (nth 8 state))))) + font-lock-doc-face + font-lock-string-face)))) + font-lock-comment-face)) + +(defun clojure-font-lock-setup () + "Configures font-lock for editing Clojure code." + (setq-local font-lock-multiline t) + (add-to-list 'font-lock-extend-region-functions + #'clojure-font-lock-extend-region-def t) + (setq font-lock-defaults + '(clojure-font-lock-keywords ; keywords + nil nil + (("+-*/.<>=!?$%_&:" . "w")) ; syntax alist + nil + (font-lock-mark-block-function . mark-defun) + (font-lock-syntactic-face-function + . clojure-font-lock-syntactic-face-function)))) + +(defun clojure-font-lock-def-at-point (point) + "Range between the top-most def* and the fourth element after POINT. +Note that this means that there is no guarantee of proper font +locking in def* forms that are not at top level." + (goto-char point) + (condition-case nil + (beginning-of-defun) + (error nil)) + + (let ((beg-def (point))) + (when (and (not (= point beg-def)) + (looking-at "(def")) + (condition-case nil + (progn + ;; move forward as much as possible until failure (or success) + (forward-char) + (dotimes (_ 4) + (forward-sexp))) + (error nil)) + (cons beg-def (point))))) + +(defun clojure-font-lock-extend-region-def () + "Set region boundaries to include the first four elements of def* forms." + (let ((changed nil)) + (let ((def (clojure-font-lock-def-at-point font-lock-beg))) + (when def + (cl-destructuring-bind (def-beg . def-end) def + (when (and (< def-beg font-lock-beg) + (< font-lock-beg def-end)) + (setq font-lock-beg def-beg + changed t))))) + (let ((def (clojure-font-lock-def-at-point font-lock-end))) + (when def + (cl-destructuring-bind (def-beg . def-end) def + (when (and (< def-beg font-lock-end) + (< font-lock-end def-end)) + (setq font-lock-end def-end + changed t))))) + changed)) + +(defun clojure--font-locked-as-string-p (&optional regexp) + "Non-nil if the char before point is font-locked as a string. +If REGEXP is non-nil, also check whether current string is +preceeded by a #." + (let ((face (get-text-property (1- (point)) 'face))) + (and (or (and (listp face) + (memq 'font-lock-string-face face)) + (eq 'font-lock-string-face face)) + (or (clojure-string-start t) + (unless regexp + (clojure-string-start nil)))))) + +(defun clojure-font-lock-escaped-chars (bound) + "Highlight \escaped chars in strings. +BOUND denotes a buffer position to limit the search." + (let ((found nil)) + (while (and (not found) + (re-search-forward "\\\\." bound t)) + + (setq found (clojure--font-locked-as-string-p))) + found)) + +(defun clojure-font-lock-regexp-groups (bound) + "Highlight grouping constructs in regular expression. + +BOUND denotes the maximum number of characters (relative to the +point) to check." + (let ((found nil)) + (while (and (not found) + (re-search-forward (eval-when-compile + (concat + ;; A group may start using several alternatives: + "\\(\\(?:" + ;; 1. (? special groups + "(\\?\\(?:" + ;; a) non-capturing group (?:X) + ;; b) independent non-capturing group (?>X) + ;; c) zero-width positive lookahead (?=X) + ;; d) zero-width negative lookahead (?!X) + "[:=!>]\\|" + ;; e) zero-width positive lookbehind (?<=X) + ;; f) zero-width negative lookbehind (?X) + "<[[:alnum:]]+>" + "\\)\\|" ;; end of special groups + ;; 2. normal capturing groups ( + ;; 3. we also highlight alternative + ;; separarators |, and closing parens ) + "[|()]" + "\\)\\)")) + bound t)) + (setq found (clojure--font-locked-as-string-p 'regexp))) + found)) + +;; Docstring positions +(put 'ns 'clojure-doc-string-elt 2) +(put 'def 'clojure-doc-string-elt 2) +(put 'defn 'clojure-doc-string-elt 2) +(put 'defn- 'clojure-doc-string-elt 2) +(put 'defmulti 'clojure-doc-string-elt 2) +(put 'defmacro 'clojure-doc-string-elt 2) +(put 'definline 'clojure-doc-string-elt 2) +(put 'defprotocol 'clojure-doc-string-elt 2) + +;;; Vertical alignment +(defcustom clojure-align-forms-automatically nil + "If non-nil, vertically align some forms automatically. +Automatically means it is done as part of indenting code. This +applies to binding forms (`clojure-align-binding-forms'), to cond +forms (`clojure-align-cond-forms') and to map literals. For +instance, selecting a map a hitting \\`\\[indent-for-tab-command]' +will align the values like this: + {:some-key 10 + :key2 20}" + :package-version '(clojure-mode . "5.1") + :safe #'booleanp + :type 'boolean) + +(defcustom clojure-align-binding-forms + '("let" "when-let" "when-some" "if-let" "if-some" "binding" "loop" + "doseq" "for" "with-open" "with-local-vars" "with-redefs") + "List of strings matching forms that have binding forms." + :package-version '(clojure-mode . "5.1") + :safe #'listp + :type '(repeat string)) + +(defcustom clojure-align-cond-forms '("condp" "cond" "cond->" "cond->>" "case" "are") + "List of strings identifying cond-like forms." + :package-version '(clojure-mode . "5.1") + :safe #'listp + :type '(repeat string)) + +(defun clojure--position-for-alignment () + "Non-nil if the sexp around point should be automatically aligned. +This function expects to be called immediately after an +open-brace or after the function symbol in a function call. + +First check if the sexp around point is a map literal, or is a +call to one of the vars listed in `clojure-align-cond-forms'. If +it isn't, return nil. If it is, return non-nil and place point +immediately before the forms that should be aligned. + +For instance, in a map literal point is left immediately before +the first key; while, in a let-binding, point is left inside the +binding vector and immediately before the first binding +construct." + ;; Are we in a map? + (or (and (eq (char-before) ?{) + (not (eq (char-before (1- (point))) ?\#))) + ;; Are we in a cond form? + (let* ((fun (car (member (thing-at-point 'symbol) clojure-align-cond-forms))) + (method (and fun (clojure--get-indent-method fun))) + ;; The number of special arguments in the cond form is + ;; the number of sexps we skip before aligning. + (skip (cond ((numberp method) method) + ((null method) 0) + ((sequencep method) (elt method 0))))) + (when (and fun (numberp skip)) + (clojure-forward-logical-sexp skip) + (comment-forward (point-max)) + fun)) ; Return non-nil (the var name). + ;; Are we in a let-like form? + (when (member (thing-at-point 'symbol) + clojure-align-binding-forms) + ;; Position inside the binding vector. + (clojure-forward-logical-sexp) + (backward-sexp) + (when (eq (char-after) ?\[) + (forward-char 1) + (comment-forward (point-max)) + ;; Return non-nil. + t)))) + +(defun clojure--find-sexp-to-align (end) + "Non-nil if there's a sexp ahead to be aligned before END. +Place point as in `clojure--position-for-alignment'." + ;; Look for a relevant sexp. + (let ((found)) + (while (and (not found) + (search-forward-regexp + (concat "{\\|(" (regexp-opt + (append clojure-align-binding-forms + clojure-align-cond-forms) + 'symbols)) + end 'noerror)) + + (let ((ppss (syntax-ppss))) + ;; If we're in a string or comment. + (unless (or (elt ppss 3) + (elt ppss 4)) + ;; Only stop looking if we successfully position + ;; the point. + (setq found (clojure--position-for-alignment))))) + found)) + +(defun clojure--search-whitespace-after-next-sexp (&optional bound _noerror) + "Move point after all whitespace after the next sexp. +Set the match data group 1 to be this region of whitespace and +return point." + (unwind-protect + (ignore-errors + (clojure-forward-logical-sexp 1) + (search-forward-regexp "\\([,\s\t]*\\)" bound) + (pcase (syntax-after (point)) + ;; End-of-line, try again on next line. + (`(12) (clojure--search-whitespace-after-next-sexp bound)) + ;; Closing paren, stop here. + (`(5 . ,_) nil) + ;; Anything else is something to align. + (_ (point)))) + (when (and bound (> (point) bound)) + (goto-char bound)))) + +(defun clojure-align (beg end) + "Vertically align the contents of the sexp around point. +If region is active, align it. Otherwise, align everything in the +current \"top-level\" sexp. +When called from lisp code align everything between BEG and END." + (interactive (if (use-region-p) + (list (region-beginning) (region-end)) + (save-excursion + (let ((end (progn (end-of-defun) + (point)))) + (clojure-backward-logical-sexp) + (list (point) end))))) + (setq end (copy-marker end)) + (save-excursion + (goto-char beg) + (while (clojure--find-sexp-to-align end) + (let ((sexp-end (save-excursion + (backward-up-list) + (forward-sexp 1) + (point-marker))) + (clojure-align-forms-automatically nil) + (count 1)) + ;; For some bizarre reason, we need to `align-region' once for each + ;; group. + (save-excursion + (while (search-forward-regexp "^ *\n" sexp-end 'noerror) + (cl-incf count))) + (dotimes (_ count) + (align-region (point) sexp-end nil + '((clojure-align (regexp . clojure--search-whitespace-after-next-sexp) + (group . 1) + (separate . "^ *$") + (repeat . t))) + nil)) + ;; Reindent after aligning because of #360. + (indent-region (point) sexp-end))))) + +;;; Indentation +(defun clojure-indent-region (beg end) + "Like `indent-region', but also maybe align forms. +Forms between BEG and END are aligned according to +`clojure-align-forms-automatically'." + (prog1 (let ((indent-region-function nil)) + (indent-region beg end)) + (when clojure-align-forms-automatically + (condition-case nil + (clojure-align beg end) + (scan-error nil))))) + +(defun clojure-indent-line () + "Indent current line as Clojure code." + (if (clojure-in-docstring-p) + (save-excursion + (beginning-of-line) + (when (and (looking-at "^\\s-*") + (<= (string-width (match-string-no-properties 0)) + (string-width (clojure-docstring-fill-prefix)))) + (replace-match (clojure-docstring-fill-prefix)))) + (lisp-indent-line))) + +(defvar clojure-get-indent-function nil + "Function to get the indent spec of a symbol. +This function should take one argument, the name of the symbol as +a string. This name will be exactly as it appears in the buffer, +so it might start with a namespace alias. + +This function is analogous to the `clojure-indent-function' +symbol property, and its return value should match one of the +allowed values of this property. See `clojure-indent-function' +for more information.") + +(defun clojure--get-indent-method (function-name) + "Return the indent spec for the symbol named FUNCTION-NAME. +FUNCTION-NAME is a string. If it contains a `/', also try only +the part after the `/'. + +Look for a spec using `clojure-get-indent-function', then try the +`clojure-indent-function' and `clojure-backtracking-indent' +symbol properties." + (or (when (functionp clojure-get-indent-function) + (funcall clojure-get-indent-function function-name)) + (get (intern-soft function-name) 'clojure-indent-function) + (get (intern-soft function-name) 'clojure-backtracking-indent) + (when (string-match "/\\([^/]+\\)\\'" function-name) + (or (get (intern-soft (match-string 1 function-name)) + 'clojure-indent-function) + (get (intern-soft (match-string 1 function-name)) + 'clojure-backtracking-indent))) + (when (string-match (rx (or "let" "when" "while") (syntax symbol)) + function-name) + (clojure--get-indent-method (substring (match-string 0 function-name) 0 -1))))) + +(defvar clojure--current-backtracking-depth 0) + +(defun clojure--find-indent-spec-backtracking () + "Return the indent sexp that applies to the sexp at point. +Implementation function for `clojure--find-indent-spec'." + (when (and (>= clojure-max-backtracking clojure--current-backtracking-depth) + (not (looking-at "^"))) + (let ((clojure--current-backtracking-depth (1+ clojure--current-backtracking-depth)) + (pos 0)) + ;; Count how far we are from the start of the sexp. + (while (ignore-errors (clojure-backward-logical-sexp 1) + (not (or (bobp) + (eq (char-before) ?\n)))) + (cl-incf pos)) + (let* ((function (thing-at-point 'symbol)) + (method (or (when function ;; Is there a spec here? + (clojure--get-indent-method function)) + (ignore-errors + ;; Otherwise look higher up. + (pcase (syntax-ppss) + (`(,(pred (< 0)) ,start . ,_) + (goto-char start) + (clojure--find-indent-spec-backtracking))))))) + (when (numberp method) + (setq method (list method))) + (pcase method + ((pred functionp) + (when (= pos 0) + method)) + ((pred sequencep) + (pcase (length method) + (`0 nil) + (`1 (let ((head (elt method 0))) + (when (or (= pos 0) (sequencep head)) + head))) + (l (if (>= pos l) + (elt method (1- l)) + (elt method pos))))) + ((or `defun `:defn) + (when (= pos 0) + :defn)) + (_ + (message "Invalid indent spec for `%s': %s" function method) + nil)))))) + +(defun clojure--find-indent-spec () + "Return the indent spec that applies to current sexp. +If `clojure-use-backtracking-indent' is non-nil, also do +backtracking up to a higher-level sexp in order to find the +spec." + (if clojure-use-backtracking-indent + (save-excursion + (clojure--find-indent-spec-backtracking)) + (let ((function (thing-at-point 'symbol))) + (clojure--get-indent-method function)))) + +(defun clojure--normal-indent (last-sexp indent-mode) + "Return the normal indentation column for a sexp. +Point should be after the open paren of the _enclosing_ sexp, and +LAST-SEXP is the start of the previous sexp (immediately before +the sexp being indented). INDENT-MODE is any of the values +accepted by `clojure-indent-style'." + (goto-char last-sexp) + (forward-sexp 1) + (clojure-backward-logical-sexp 1) + (let ((last-sexp-start nil)) + (if (ignore-errors + ;; `backward-sexp' until we reach the start of a sexp that is the + ;; first of its line (the start of the enclosing sexp). + (while (string-match + "[^[:blank:]]" + (buffer-substring (line-beginning-position) (point))) + (setq last-sexp-start (prog1 (point) + (forward-sexp -1)))) + t) + ;; Here we have found an arg before the arg we're indenting which is at + ;; the start of a line. Every mode simply aligns on this case. + (current-column) + ;; Here we have reached the start of the enclosing sexp (point is now at + ;; the function name), so the behaviour depends on INDENT-MODE and on + ;; whether there's also an argument on this line (case A or B). + (let ((case-a ; The meaning of case-a is explained in `clojure-indent-style'. + (and last-sexp-start + (< last-sexp-start (line-end-position))))) + (cond + ;; For compatibility with the old `clojure-defun-style-default-indent', any + ;; value other than these 3 is equivalent to `always-body'. + ((not (memq indent-mode '(:always-align :align-arguments nil))) + (+ (current-column) lisp-body-indent -1)) + ;; There's an arg after the function name, so align with it. + (case-a (goto-char last-sexp-start) + (current-column)) + ;; Not same line. + ((eq indent-mode :align-arguments) + (+ (current-column) lisp-body-indent -1)) + ;; Finally, just align with the function name. + (t (current-column))))))) + +(defun clojure--not-function-form-p () + "Non-nil if form at point doesn't represent a function call." + (or (member (char-after) '(?\[ ?\{)) + (save-excursion ;; Catch #?@ (:cljs ...) + (skip-chars-backward "\r\n[:blank:]") + (when (eq (char-before) ?@) + (forward-char -1)) + (and (eq (char-before) ?\?) + (eq (char-before (1- (point))) ?\#))) + ;; Car of form is not a symbol. + (not (looking-at ".\\(?:\\sw\\|\\s_\\)")))) + +;; Check the general context, and provide indentation for data structures and +;; special macros. If current form is a function (or non-special macro), +;; delegate indentation to `clojure--normal-indent'. +(defun clojure-indent-function (indent-point state) + "When indenting a line within a function call, indent properly. + +INDENT-POINT is the position where the user typed TAB, or equivalent. +Point is located at the point to indent under (for default indentation); +STATE is the `parse-partial-sexp' state for that position. + +If the current line is in a call to a Clojure function with a +non-nil property `clojure-indent-function', that specifies how to do +the indentation. + +The property value can be + +- `defun', meaning indent `defun'-style; +- an integer N, meaning indent the first N arguments specially + like ordinary function arguments and then indent any further + arguments like a body; +- a function to call just as this function was called. + If that function returns nil, that means it doesn't specify + the indentation. +- a list, which is used by `clojure-backtracking-indent'. + +This function also returns nil meaning don't specify the indentation." + ;; Goto to the open-paren. + (goto-char (elt state 1)) + ;; Maps, sets, vectors and reader conditionals. + (if (clojure--not-function-form-p) + (1+ (current-column)) + ;; Function or macro call. + (forward-char 1) + (let ((method (clojure--find-indent-spec)) + (last-sexp calculate-lisp-indent-last-sexp) + (containing-form-column (1- (current-column)))) + (pcase method + ((or (pred integerp) `(,method)) + (let ((pos -1)) + (condition-case nil + (while (and (<= (point) indent-point) + (not (eobp))) + (clojure-forward-logical-sexp 1) + (cl-incf pos)) + ;; If indent-point is _after_ the last sexp in the + ;; current sexp, we detect that by catching the + ;; `scan-error'. In that case, we should return the + ;; indentation as if there were an extra sexp at point. + (scan-error (cl-incf pos))) + (cond + ;; The first non-special arg. Rigidly reduce indentation. + ((= pos (1+ method)) + (+ lisp-body-indent containing-form-column)) + ;; Further non-special args, align with the arg above. + ((> pos (1+ method)) + (clojure--normal-indent last-sexp :always-align)) + ;; Special arg. Rigidly indent with a large indentation. + (t + (+ (* 2 lisp-body-indent) containing-form-column))))) + (`:defn + (+ lisp-body-indent containing-form-column)) + ((pred functionp) + (funcall method indent-point state)) + ;; No indent spec, do the default. + (`nil + (let ((function (thing-at-point 'symbol))) + (cond + ;; Preserve useful alignment of :require (and friends) in `ns' forms. + ((and function (string-match "^:" function)) + (clojure--normal-indent last-sexp :always-align)) + ;; This is should be identical to the :defn above. + ((and function + (string-match "\\`\\(?:\\S +/\\)?\\(def[a-z]*\\|with-\\)" + function) + (not (string-match "\\`default" (match-string 1 function)))) + (+ lisp-body-indent containing-form-column)) + ;; Finally, nothing special here, just respect the user's + ;; preference. + (t (clojure--normal-indent last-sexp clojure-indent-style))))))))) + +;;; Setting indentation +(defun put-clojure-indent (sym indent) + "Instruct `clojure-indent-function' to indent the body of SYM by INDENT." + (put sym 'clojure-indent-function indent)) + +(defmacro define-clojure-indent (&rest kvs) + "Call `put-clojure-indent' on a series, KVS." + `(progn + ,@(mapcar (lambda (x) `(put-clojure-indent + (quote ,(car x)) ,(cadr x))) + kvs))) + +(defun add-custom-clojure-indents (name value) + "Allow `clojure-defun-indents' to indent user-specified macros. + +Requires the macro's NAME and a VALUE." + (custom-set-default name value) + (mapcar (lambda (x) + (put-clojure-indent x 'defun)) + value)) + +(defcustom clojure-defun-indents nil + "List of additional symbols with defun-style indentation in Clojure. + +You can use this to let Emacs indent your own macros the same way +that it indents built-in macros like with-open. This variable +only works when set via the customize interface (`setq' won't +work). To set it from Lisp code, use + (put-clojure-indent \\='some-symbol :defn)." + :type '(repeat symbol) + :set 'add-custom-clojure-indents) + +(define-clojure-indent + ;; built-ins + (ns 1) + (fn :defn) + (def :defn) + (defn :defn) + (bound-fn :defn) + (if 1) + (if-not 1) + (case 1) + (cond 0) + (condp 2) + (cond-> 1) + (cond->> 1) + (when 1) + (while 1) + (when-not 1) + (when-first 1) + (do 0) + (future 0) + (comment 0) + (doto 1) + (locking 1) + (proxy '(2 nil nil (:defn))) + (as-> 2) + + (reify '(:defn (1))) + (deftype '(2 nil nil (:defn))) + (defrecord '(2 nil nil (:defn))) + (defprotocol '(1 (:defn))) + (definterface '(1 (:defn))) + (extend 1) + (extend-protocol '(1 :defn)) + (extend-type '(1 :defn)) + ;; specify and specify! are from ClojureScript + (specify '(1 :defn)) + (specify! '(1 :defn)) + (try 0) + (catch 2) + (finally 0) + + ;; binding forms + (let 1) + (letfn '(1 ((:defn)) nil)) + (binding 1) + (loop 1) + (for 1) + (doseq 1) + (dotimes 1) + (when-let 1) + (if-let 1) + (when-some 1) + (if-some 1) + (this-as 1) ; ClojureScript + + (defmethod :defn) + + ;; clojure.test + (testing 1) + (deftest :defn) + (are 2) + (use-fixtures :defn) + + ;; core.logic + (run :defn) + (run* :defn) + (fresh :defn) + + ;; core.async + (alt! 0) + (alt!! 0) + (go 0) + (go-loop 1) + (thread 0)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Better docstring filling for clojure-mode +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun clojure-string-start (&optional regex) + "Return the position of the \" that begins the string at point. +If REGEX is non-nil, return the position of the # that begins the +regex at point. If point is not inside a string or regex, return +nil." + (when (nth 3 (syntax-ppss)) ;; Are we really in a string? + (save-excursion + (save-match-data + ;; Find a quote that appears immediately after whitespace, + ;; beginning of line, hash, or an open paren, brace, or bracket + (re-search-backward "\\(\\s-\\|^\\|#\\|(\\|\\[\\|{\\)\\(\"\\)") + (let ((beg (match-beginning 2))) + (when beg + (if regex + (and (char-before beg) (eq ?# (char-before beg)) (1- beg)) + (when (not (eq ?# (char-before beg))) + beg)))))))) + +(defun clojure-char-at-point () + "Return the char at point or nil if at buffer end." + (when (not (= (point) (point-max))) + (buffer-substring-no-properties (point) (1+ (point))))) + +(defun clojure-char-before-point () + "Return the char before point or nil if at buffer beginning." + (when (not (= (point) (point-min))) + (buffer-substring-no-properties (point) (1- (point))))) + +(defun clojure-toggle-keyword-string () + "Convert the string or keyword at point to keyword or string." + (interactive) + (let ((original-point (point))) + (while (and (> (point) 1) + (not (equal "\"" (buffer-substring-no-properties (point) (+ 1 (point))))) + (not (equal ":" (buffer-substring-no-properties (point) (+ 1 (point)))))) + (backward-char)) + (cond + ((equal 1 (point)) + (error "Beginning of file reached, this was probably a mistake")) + ((equal "\"" (buffer-substring-no-properties (point) (+ 1 (point)))) + (insert ":" (substring (clojure-delete-and-extract-sexp) 1 -1))) + ((equal ":" (buffer-substring-no-properties (point) (+ 1 (point)))) + (insert "\"" (substring (clojure-delete-and-extract-sexp) 1) "\""))) + (goto-char original-point))) + +(defun clojure-delete-and-extract-sexp () + "Delete the surrounding sexp and return it." + (let ((begin (point))) + (forward-sexp) + (let ((result (buffer-substring begin (point)))) + (delete-region begin (point)) + result))) + + + +(defun clojure-project-dir (&optional dir-name) + "Return the absolute path to the project's root directory. + +Use `default-directory' if DIR-NAME is nil. +Return nil if not inside a project." + (let* ((dir-name (or dir-name default-directory)) + (choices (delq nil + (mapcar (lambda (fname) + (locate-dominating-file dir-name fname)) + clojure-build-tool-files)))) + (when (> (length choices) 0) + (car (sort choices #'file-in-directory-p))))) + +(defun clojure-project-relative-path (path) + "Denormalize PATH by making it relative to the project root." + (file-relative-name path (clojure-project-dir))) + + +;;; ns manipulation +(defun clojure-expected-ns (&optional path) + "Return the namespace matching PATH. + +PATH is expected to be an absolute file path. + +If PATH is nil, use the path to the file backing the current buffer." + (let* ((path (or path (file-truename (buffer-file-name)))) + (relative (clojure-project-relative-path path)) + (sans-file-type (substring relative 0 (- (length (file-name-extension path t))))) + (sans-file-sep (mapconcat 'identity (cdr (split-string sans-file-type "/")) ".")) + (sans-underscores (replace-regexp-in-string "_" "-" sans-file-sep))) + ;; Drop prefix from ns for projects with structure src/{clj,cljs,cljc} + (replace-regexp-in-string "\\`clj[scx]?\\." "" sans-underscores))) + +(defun clojure-insert-ns-form-at-point () + "Insert a namespace form at point." + (interactive) + (insert (format "(ns %s)" (funcall clojure-expected-ns-function)))) + +(defun clojure-insert-ns-form () + "Insert a namespace form at the beginning of the buffer." + (interactive) + (widen) + (goto-char (point-min)) + (clojure-insert-ns-form-at-point)) + +(defun clojure-update-ns () + "Update the namespace of the current buffer. +Useful if a file has been renamed." + (interactive) + (let ((nsname (funcall clojure-expected-ns-function))) + (when nsname + (save-excursion + (save-match-data + (if (clojure-find-ns) + (progn (replace-match nsname nil nil nil 4) + (message "ns form updated")) + (error "Namespace not found"))))))) + +(defun clojure--sort-following-sexps () + "Sort sexps between point and end of current sexp. +Comments at the start of a line are considered part of the +following sexp. Comments at the end of a line (after some other +content) are considered part of the preceding sexp." + ;; Here we're after the :require/:import symbol. + (save-restriction + (narrow-to-region (point) (save-excursion + (up-list) + (1- (point)))) + (skip-chars-forward "\r\n[:blank:]") + (sort-subr nil + (lambda () (skip-chars-forward "\r\n[:blank:]")) + ;; Move to end of current top-level thing. + (lambda () + (condition-case nil + (while t (up-list)) + (scan-error nil)) + ;; We could be inside a symbol instead of a sexp. + (unless (looking-at "\\s-\\|$") + (clojure-forward-logical-sexp)) + ;; move past comments at the end of the line. + (search-forward-regexp "$")) + ;; Move to start of ns name. + (lambda () + (comment-forward) + (skip-chars-forward "[:blank:]\n\r[(") + (clojure-forward-logical-sexp) + (forward-sexp -1) + nil) + ;; Move to end of ns name. + (lambda () + (clojure-forward-logical-sexp))) + (goto-char (point-max)) + ;; Does the last line now end in a comment? + (when (nth 4 (parse-partial-sexp (point-min) (point))) + (insert "\n")))) + +(defun clojure-sort-ns () + "Internally sort each sexp inside the ns form." + (interactive) + (comment-normalize-vars) + (if (clojure-find-ns) + (save-excursion + (goto-char (match-beginning 0)) + (redisplay) + (let ((beg (point)) + (ns)) + (forward-sexp 1) + (setq ns (buffer-substring beg (point))) + (forward-char -1) + (while (progn (forward-sexp -1) + (looking-at "(:[a-z]")) + (save-excursion + (forward-char 1) + (forward-sexp 1) + (clojure--sort-following-sexps))) + (goto-char beg) + (if (looking-at (regexp-quote ns)) + (message "ns form is already sorted") + (sleep-for 0.1) + (redisplay) + (message "ns form has been sorted") + (sleep-for 0.1)))) + (user-error "Namespace not found"))) + +(defconst clojure-namespace-name-regex + (rx line-start + "(" + (zero-or-one (group (regexp "clojure.core/"))) + (zero-or-one (submatch "in-")) + "ns" + (zero-or-one "+") + (one-or-more (any whitespace "\n")) + (zero-or-more (or (submatch (zero-or-one "#") + "^{" + (zero-or-more (not (any "}"))) + "}") + (zero-or-more "^:" + (one-or-more (not (any whitespace))))) + (one-or-more (any whitespace "\n"))) + (zero-or-one (any ":'")) ;; (in-ns 'foo) or (ns+ :user) + (group (one-or-more (not (any "()\"" whitespace))) symbol-end))) + +(defun clojure-find-ns () + "Return the namespace of the current Clojure buffer. +Return the namespace closest to point and above it. If there are +no namespaces above point, return the first one in the buffer." + (save-excursion + (save-restriction + (widen) + ;; The closest ns form above point. + (when (or (re-search-backward clojure-namespace-name-regex nil t) + ;; Or any form at all. + (and (goto-char (point-min)) + (re-search-forward clojure-namespace-name-regex nil t))) + (match-string-no-properties 4))))) + +(defconst clojure-def-type-and-name-regex + (concat "(\\(?:\\(?:\\sw\\|\\s_\\)+/\\)?" + ;; Declaration + "\\(def\\(?:\\sw\\|\\s_\\)*\\)\\>" + ;; Any whitespace + "[ \r\n\t]*" + ;; Possibly type or metadata + "\\(?:#?^\\(?:{[^}]*}\\|\\(?:\\sw\\|\\s_\\)+\\)[ \r\n\t]*\\)*" + ;; Symbol name + "\\(\\(?:\\sw\\|\\s_\\)+\\)")) + +(defun clojure-find-def () + "Find the var declaration macro and symbol name of the current form. +Returns a list pair, e.g. (\"defn\" \"abc\") or (\"deftest\" \"some-test\")." + (save-excursion + (unless (looking-at clojure-def-type-and-name-regex) + (beginning-of-defun)) + (when (search-forward-regexp clojure-def-type-and-name-regex nil t) + (list (match-string-no-properties 1) + (match-string-no-properties 2))))) + + +;;; Sexp navigation +(defun clojure--looking-at-non-logical-sexp () + "Return non-nil if sexp after point represents code. +Sexps that don't represent code are ^metadata or #reader.macros." + (comment-normalize-vars) + (comment-forward (point-max)) + (looking-at-p "\\^\\|#[?[:alpha:]]")) + +(defun clojure-forward-logical-sexp (&optional n) + "Move forward N logical sexps. +This will skip over sexps that don't represent objects, so that ^hints and +#reader.macros are considered part of the following sexp." + (interactive "p") + (unless n (setq n 1)) + (if (< n 0) + (clojure-backward-logical-sexp (- n)) + (let ((forward-sexp-function nil)) + (while (> n 0) + (while (clojure--looking-at-non-logical-sexp) + (forward-sexp 1)) + ;; The actual sexp + (forward-sexp 1) + (skip-chars-forward ",") + (setq n (1- n)))))) + +(defun clojure-backward-logical-sexp (&optional n) + "Move backward N logical sexps. +This will skip over sexps that don't represent objects, so that ^hints and +#reader.macros are considered part of the following sexp." + (interactive "p") + (unless n (setq n 1)) + (if (< n 0) + (clojure-forward-logical-sexp (- n)) + (let ((forward-sexp-function nil)) + (while (> n 0) + ;; The actual sexp + (backward-sexp 1) + ;; Non-logical sexps. + (while (and (not (bobp)) + (ignore-errors + (save-excursion + (backward-sexp 1) + (clojure--looking-at-non-logical-sexp)))) + (backward-sexp 1)) + (setq n (1- n)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Refactoring support +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Threading macros related +(defcustom clojure-thread-all-but-last nil + "Non-nil means do not thread the last expression. +This means that `clojure-thread-first-all' and +`clojure-thread-last-all' not thread the deepest sexp inside the +current sexp." + :package-version '(clojure-mode . "5.4.0") + :safe #'booleanp + :type 'boolean) + +(defun clojure--maybe-unjoin-line () + "Undo a `join-line' done by a threading command." + (when (get-text-property (point) 'clojure-thread-line-joined) + (remove-text-properties (point) (1+ (point)) '(clojure-thread-line-joined t)) + (insert "\n"))) + +(defun clojure--unwind-last () + (forward-sexp) + (save-excursion + (let ((beg (point)) + (contents (clojure-delete-and-extract-sexp))) + (when (looking-at " *\n") + (join-line 'following)) + (clojure--ensure-parens-around-function-names) + (let* ((sexp-beg-line (line-number-at-pos)) + (sexp-end-line (progn (forward-sexp) + (line-number-at-pos))) + (multiline-sexp-p (not (= sexp-beg-line sexp-end-line)))) + (down-list -1) + (if multiline-sexp-p + (insert "\n") + ;; `clojure--maybe-unjoin-line' only works when unwinding sexps that were + ;; threaded in the same Emacs session, but it also catches cases that + ;; `multiline-sexp-p' doesn't. + (clojure--maybe-unjoin-line)) + (insert contents)))) + (forward-char)) + +(defun clojure--ensure-parens-around-function-names () + (clojure--looking-at-non-logical-sexp) + (unless (looking-at "(") + (insert-parentheses 1) + (backward-up-list))) + +(defun clojure--unwind-first () + "Unwind a thread first macro once. +Point must be between the opening paren and the -> symbol." + (forward-sexp) + (save-excursion + (let ((contents (clojure-delete-and-extract-sexp))) + (when (looking-at " *\n") + (join-line 'following)) + (clojure--ensure-parens-around-function-names) + (down-list) + (forward-sexp) + (insert contents) + (forward-sexp -1) + (clojure--maybe-unjoin-line))) + (forward-char)) + +(defun clojure--pop-out-of-threading () + (save-excursion + (down-list 2) + (backward-up-list) + (raise-sexp))) + +(defun clojure--nothing-more-to-unwind () + (save-excursion + (let ((beg (point))) + (forward-sexp) + (down-list -1) + (backward-sexp 2) ;; the last sexp, the threading macro + (when (looking-back "(\\s-*" (line-beginning-position)) + (backward-up-list)) ;; and the paren + (= beg (point))))) + +(defun clojure--fix-sexp-whitespace (&optional move-out) + (save-excursion + (when move-out (backward-up-list)) + (let ((sexp (bounds-of-thing-at-point 'sexp))) + (clojure-indent-region (car sexp) (cdr sexp)) + (delete-trailing-whitespace (car sexp) (cdr sexp))))) + +;;;###autoload +(defun clojure-unwind () + "Unwind thread at point or above point by one level. +Return nil if there are no more levels to unwind." + (interactive) + (save-excursion + (let ((limit (save-excursion + (beginning-of-defun) + (point)))) + (ignore-errors + (when (looking-at "(") + (forward-char 1) + (forward-sexp 1))) + (search-backward-regexp "([^-]*->" limit) + (if (clojure--nothing-more-to-unwind) + (progn (clojure--pop-out-of-threading) + (clojure--fix-sexp-whitespace) + nil) + (down-list) + (prog1 (cond + ((looking-at "[^-]*->\\_>") (clojure--unwind-first)) + ((looking-at "[^-]*->>\\_>") (clojure--unwind-last))) + (clojure--fix-sexp-whitespace 'move-out)) + t)))) + +;;;###autoload +(defun clojure-unwind-all () + "Fully unwind thread at point or above point." + (interactive) + (while (clojure-unwind))) + +(defun clojure--remove-superfluous-parens () + (when (looking-at "([^ )]+)") + (delete-pair))) + +(defun clojure--thread-first () + (down-list) + (forward-symbol 1) + (unless (looking-at ")") + (let ((contents (clojure-delete-and-extract-sexp))) + (backward-up-list) + (just-one-space 0) + (save-excursion + (insert contents "\n") + (clojure--remove-superfluous-parens)) + (when (looking-at "\\s-*\n") + (join-line 'following) + (forward-char 1) + (put-text-property (point) (1+ (point)) + 'clojure-thread-line-joined t)) + t))) + +(defun clojure--thread-last () + (forward-sexp 2) + (down-list -1) + (backward-sexp) + (unless (eq (char-before) ?\() + (let ((contents (clojure-delete-and-extract-sexp))) + (just-one-space 0) + (backward-up-list) + (insert contents "\n") + (clojure--remove-superfluous-parens) + ;; cljr #255 Fix dangling parens + (forward-sexp) + (when (looking-back "^\\s-*\\()+\\)\\s-*" (line-beginning-position)) + (let ((pos (match-beginning 1))) + (put-text-property pos (1+ pos) 'clojure-thread-line-joined t)) + (join-line)) + t))) + +(defun clojure--threadable-p () + (save-excursion + (forward-symbol 1) + (looking-at "[\n\r\t ]*("))) + +;;;###autoload +(defun clojure-thread () + "Thread by one more level an existing threading macro." + (interactive) + (ignore-errors + (when (looking-at "(") + (forward-char 1) + (forward-sexp 1))) + (search-backward-regexp "([^-]*->") + (down-list) + (when (clojure--threadable-p) + (prog1 (cond + ((looking-at "[^-]*->\\_>") (clojure--thread-first)) + ((looking-at "[^-]*->>\\_>") (clojure--thread-last))) + (clojure--fix-sexp-whitespace 'move-out)))) + +(defun clojure--thread-all (first-or-last-thread but-last) + (save-excursion + (insert-parentheses 1) + (insert first-or-last-thread)) + (while (save-excursion (clojure-thread))) + (when (or but-last clojure-thread-all-but-last) + (clojure-unwind))) + +;;;###autoload +(defun clojure-thread-first-all (but-last) + "Fully thread the form at point using ->. +When BUT-LAST is passed the last expression is not threaded." + (interactive "P") + (clojure--thread-all "-> " but-last)) + +;;;###autoload +(defun clojure-thread-last-all (but-last) + "Fully thread the form at point using ->>. +When BUT-LAST is passed the last expression is not threaded." + (interactive "P") + (clojure--thread-all "->> " but-last)) + +;;; Cycling stuff + +(defcustom clojure-use-metadata-for-privacy nil + "If nil, `clojure-cycle-privacy' will use (defn- f []). +If t, it will use (defn ^:private f [])." + :package-version '(clojure-mode . "5.5.0") + :safe #'booleanp + :type 'boolean) + +;;;###autoload +(defun clojure-cycle-privacy () + "Make public the current private def, or vice-versa. +See: https://github.com/clojure-emacs/clj-refactor.el/wiki/cljr-cycle-privacy" + (interactive) + (save-excursion + (ignore-errors (forward-char 7)) + (search-backward-regexp "(defn?\\(-\\| ^:private\\)?\\_>") + (if (match-string 1) + (replace-match "" nil nil nil 1) + (goto-char (match-end 0)) + (insert (if (or clojure-use-metadata-for-privacy + (equal (match-string 0) "(def")) + " ^:private" + "-"))))) + +(defun clojure--convert-collection (coll-open coll-close) + "Convert the collection at (point) by unwrapping it an wrapping it between COLL-OPEN and COLL-CLOSE." + (save-excursion + (while (and + (not (bobp)) + (not (looking-at "(\\|{\\|\\["))) + (backward-char)) + (when (or (eq ?\# (char-before)) + (eq ?\' (char-before))) + (delete-char -1)) + (when (and (bobp) + (not (memq (char-after) '(?\{ ?\( ?\[)))) + (user-error "Beginning of file reached, collection is not found")) + (insert coll-open (substring (clojure-delete-and-extract-sexp) 1 -1) coll-close))) + +;;;###autoload +(defun clojure-convert-collection-to-list () + "Convert collection at (point) to list." + (interactive) + (clojure--convert-collection "(" ")")) + +;;;###autoload +(defun clojure-convert-collection-to-quoted-list () + "Convert collection at (point) to quoted list." + (interactive) + (clojure--convert-collection "'(" ")")) + +;;;###autoload +(defun clojure-convert-collection-to-map () + "Convert collection at (point) to map." + (interactive) + (clojure--convert-collection "{" "}")) + +;;;###autoload +(defun clojure-convert-collection-to-vector () + "Convert collection at (point) to vector." + (interactive) + (clojure--convert-collection "[" "]")) + +;;;###autoload +(defun clojure-convert-collection-to-set () + "Convert collection at (point) to set." + (interactive) + (clojure--convert-collection "#{" "}")) + +(defun clojure--goto-if () + (when (in-string-p) + (while (or (not (looking-at "(")) + (in-string-p)) + (backward-char))) + (while (not (looking-at "\\((if \\)\\|\\((if-not \\)")) + (condition-case nil + (backward-up-list) + (scan-error (user-error "No if or if-not found"))))) + +;;;###autoload +(defun clojure-cycle-if () + "Change a surrounding if to if-not, or vice-versa. + +See: https://github.com/clojure-emacs/clj-refactor.el/wiki/cljr-cycle-if" + (interactive) + (save-excursion + (clojure--goto-if) + (cond + ((looking-at "(if-not") + (forward-char 3) + (delete-char 4) + (forward-sexp 2) + (transpose-sexps 1)) + ((looking-at "(if") + (forward-char 3) + (insert "-not") + (forward-sexp 2) + (transpose-sexps 1))))) + + +;;; ClojureScript +(defconst clojurescript-font-lock-keywords + (eval-when-compile + `(;; ClojureScript built-ins + (,(concat "(\\(?:\.*/\\)?" + (regexp-opt '("js-obj" "js-delete" "clj->js" "js->clj")) + "\\>") + 0 font-lock-builtin-face))) + "Additional font-locking for `clojurescrip-mode'.") + +;;;###autoload +(define-derived-mode clojurescript-mode clojure-mode "ClojureScript" + "Major mode for editing ClojureScript code. + +\\{clojurescript-mode-map}" + (font-lock-add-keywords nil clojurescript-font-lock-keywords)) + +;;;###autoload +(define-derived-mode clojurec-mode clojure-mode "ClojureC" + "Major mode for editing ClojureC code. + +\\{clojurec-mode-map}") + +(defconst clojurex-font-lock-keywords + ;; cljx annotations (#+clj and #+cljs) + '(("#\\+cljs?\\>" 0 font-lock-preprocessor-face)) + "Additional font-locking for `clojurex-mode'.") + +;;;###autoload +(define-derived-mode clojurex-mode clojure-mode "ClojureX" + "Major mode for editing ClojureX code. + +\\{clojurex-mode-map}" + (font-lock-add-keywords nil clojurex-font-lock-keywords)) + +;;;###autoload +(progn + (add-to-list 'auto-mode-alist + '("\\.\\(clj\\|dtm\\|edn\\)\\'" . clojure-mode)) + (add-to-list 'auto-mode-alist '("\\.cljc\\'" . clojurec-mode)) + (add-to-list 'auto-mode-alist '("\\.cljx\\'" . clojurex-mode)) + (add-to-list 'auto-mode-alist '("\\.cljs\\'" . clojurescript-mode)) + ;; boot build scripts are Clojure source files + (add-to-list 'auto-mode-alist '("\\(?:build\\|profile\\)\\.boot\\'" . clojure-mode))) + +(provide 'clojure-mode) + +;; Local Variables: +;; coding: utf-8 +;; End: + +;;; clojure-mode.el ends here diff --git a/elpa/clojure-quick-repls-20150814.36/clojure-quick-repls-autoloads.el b/elpa/clojure-quick-repls-20150814.36/clojure-quick-repls-autoloads.el new file mode 100644 index 0000000..41c37b9 --- /dev/null +++ b/elpa/clojure-quick-repls-20150814.36/clojure-quick-repls-autoloads.el @@ -0,0 +1,22 @@ +;;; clojure-quick-repls-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil "clojure-quick-repls" "clojure-quick-repls.el" +;;;;;; (22500 1822 828219 293000)) +;;; Generated autoloads from clojure-quick-repls.el + +(autoload 'clojure-quick-repls-connect "clojure-quick-repls" "\ +Launch Clojure and ClojureScript repls for the current project + +\(fn)" t nil) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; clojure-quick-repls-autoloads.el ends here diff --git a/elpa/clojure-quick-repls-20150814.36/clojure-quick-repls-pkg.el b/elpa/clojure-quick-repls-20150814.36/clojure-quick-repls-pkg.el new file mode 100644 index 0000000..85a7a95 --- /dev/null +++ b/elpa/clojure-quick-repls-20150814.36/clojure-quick-repls-pkg.el @@ -0,0 +1 @@ +(define-package "clojure-quick-repls" "20150814.36" "Quickly create Clojure and ClojureScript repls for a project." '((cider "0.8.1") (dash "2.9.0")) :url "https://github.com/symfrog/clojure-quick-repls" :keywords '("languages" "clojure" "cider" "clojurescript")) diff --git a/elpa/clojure-quick-repls-20150814.36/clojure-quick-repls.el b/elpa/clojure-quick-repls-20150814.36/clojure-quick-repls.el new file mode 100644 index 0000000..50e4778 --- /dev/null +++ b/elpa/clojure-quick-repls-20150814.36/clojure-quick-repls.el @@ -0,0 +1,155 @@ +;;; clojure-quick-repls.el --- Quickly create Clojure and ClojureScript repls for a project. + +;; Copyright (C) 2014 symfrog + +;; URL: https://github.com/symfrog/clojure-quick-repls +;; Package-Version: 20150814.36 +;; Keywords: languages, clojure, cider, clojurescript +;; Version: 0.2.0-cvs +;; Package-Requires: ((cider "0.8.1") (dash "2.9.0")) + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Quickly create Clojure and ClojureScript repls for a project. +;; Once the repls are created the usual CIDER commands can be used in either a clj/cljs buffer and the forms will be routed automatically via the correct connection. +;; So no need to manually switch connections! + +;;; Installation: + +;; Available as a package in melpa.org. +;; M-x package-install clojure-quick-repls + +;;; Usage: + +;; (require 'clojure-quick-repls) + +;;; Code: + +(require 'cider) +(require 'dash) + +(defcustom clojure-quick-repls-cljs-setup + "(require 'cljs.repl.browser) + (cemerick.piggieback/cljs-repl + :repl-env (cljs.repl.browser/repl-env :port 9000))" + "Default form to initialize ClojureScript REPL" + :type '(string) + :group 'clojure-quick-repls) + +(defvar clojure-quick-repls-nrepl-connected-fn nil) + +(defvar clojure-quick-repls-current-buffer nil) +(defvar clojure-quick-repls-nrepl-connect-done nil) + +(defvar clojure-quick-repls-clj-con-buf nil) +(defvar clojure-quick-repls-cljs-con-buf nil) + +(defun clojure-quick-repls-noop-nrepl-connected-fn () + (fset 'clojure-quick-repls-nrepl-connected-fn (lambda (buf) nil))) + +(clojure-quick-repls-noop-nrepl-connected-fn) + +(defun clojure-quick-repls-clear-con-bufs () + (setq clojure-quick-repls-clj-con-buf nil) + (setq clojure-quick-repls-cljs-con-buf nil)) + +(add-hook 'nrepl-connected-hook (lambda () + (clojure-quick-repls-nrepl-connected-fn clojure-quick-repls-current-buffer))) + +(add-hook 'nrepl-disconnected-hook #'clojure-quick-repls-clear-con-bufs) + +;;;###autoload +(defun clojure-quick-repls-connect () + "Launch Clojure and ClojureScript repls for the current project" + (interactive) + (setq clojure-quick-repls-current-buffer (current-buffer)) + (clojure-quick-repls-noop-nrepl-connected-fn) + (cider-jack-in) + + (clojure-quick-repls-clear-con-bufs) + + (lexical-let* ((cljs-fn (lambda (buf) + (with-current-buffer buf + (clojure-quick-repls-noop-nrepl-connected-fn) + (if (string= "ex" (cadr (nrepl-sync-request:eval clojure-quick-repls-cljs-setup))) + (message "Failed to initialize cljs connection with form %s" clojure-quick-repls-cljs-setup) + (progn + (setq clojure-quick-repls-cljs-con-buf (nrepl-current-connection-buffer)) + (message "Clj connection buffer: %s Cljs connection buffer %s" clojure-quick-repls-clj-con-buf clojure-quick-repls-cljs-con-buf) + (message "Cljs browser repl ready") + ; Make the clj buf default after completion + (nrepl-make-connection-default clojure-quick-repls-clj-con-buf)))))) + (clj-fn (lambda (buf) + (with-current-buffer buf + (clojure-quick-repls-noop-nrepl-connected-fn ) + (fset 'clojure-quick-repls-nrepl-connected-fn cljs-fn) + (setq clojure-quick-repls-clj-con-buf (nrepl-current-connection-buffer)) + (message "Creating nrepl connection for cljs") + (clojure-quick-repls-new-repl-connection))))) + (fset 'clojure-quick-repls-nrepl-connected-fn clj-fn))) + +(defun clojure-quick-repls-new-repl-connection () + (let* ((host (nrepl-current-host)) + (port (nrepl-extract-port))) + (message "Creating repl connection to nrepl server on port %s, host %s" host port) + (cider-connect host port))) + +(defun clojure-quick-repls-bound-truthy-p (s) + (and (boundp s) (symbol-value s))) + +(defun clojure-quick-repls-buffer-extension (buffer) + (let ((name (buffer-name buffer))) + (-when-let (p-loc (string-match-p "\\." name)) + (substring name (1+ p-loc) nil))) ) + +(defun clojure-quick-repls-set-connection (f h) + (let ((ext (clojure-quick-repls-buffer-extension (current-buffer)))) + (if (and (clojure-quick-repls-bound-truthy-p 'clojure-quick-repls-clj-con-buf) + (clojure-quick-repls-bound-truthy-p 'clojure-quick-repls-cljs-con-buf) + ext + (or (string= ext "clj") (string= ext "boot") (string= ext "cljs"))) + (progn + (if (string= ext "cljs") + (nrepl-make-connection-default clojure-quick-repls-cljs-con-buf) + (nrepl-make-connection-default clojure-quick-repls-clj-con-buf)) + (when f + (funcall f))) + (when h + (funcall h))))) + +(defun clojure-quick-repls-switch-to-relevant-repl (arg) + (interactive) + (lexical-let ((a arg)) + (clojure-quick-repls-set-connection (lambda () (cider-switch-to-current-repl-buffer a)) + (lambda () (cider-switch-to-relevant-repl-buffer a))))) + +(if (version< emacs-version "24.4") + (progn + (defadvice cider-interactive-eval (before clojure-quick-repls-nrepl-current-session activate) + (clojure-quick-repls-set-connection nil nil)) + (defadvice cider-tooling-eval (before clojure-quick-repls-nrepl-current-session activate) + (clojure-quick-repls-set-connection nil nil)) + (defadvice cider-complete-at-point (before clojure-quick-repls-nrepl-current-session activate) + (clojure-quick-repls-set-connection nil nil))) + (defun clojure-quick-repls-nrepl-current-session (&optional arg1 arg2 arg3) + (clojure-quick-repls-set-connection nil nil)) + (advice-add 'cider-interactive-eval :before #'clojure-quick-repls-nrepl-current-session) + (advice-add 'cider-tooling-eval :before #'clojure-quick-repls-nrepl-current-session) + (advice-add 'cider-complete-at-point :before #'clojure-quick-repls-nrepl-current-session)) + +(provide 'clojure-quick-repls) + +;;; clojure-quick-repls.el ends here diff --git a/elpa/flycheck-clojure-20160704.1221/flycheck-clojure-autoloads.el b/elpa/flycheck-clojure-20160704.1221/flycheck-clojure-autoloads.el new file mode 100644 index 0000000..640d409 --- /dev/null +++ b/elpa/flycheck-clojure-20160704.1221/flycheck-clojure-autoloads.el @@ -0,0 +1,29 @@ +;;; flycheck-clojure-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil "flycheck-clojure" "flycheck-clojure.el" (22500 +;;;;;; 1821 852214 67000)) +;;; Generated autoloads from flycheck-clojure.el + +(autoload 'flycheck-clojure-parse-cider-errors "flycheck-clojure" "\ +Parse cider errors from JSON VALUE from CHECKER. + +Return a list of parsed `flycheck-error' objects. + +\(fn VALUE CHECKER)" nil nil) + +(autoload 'flycheck-clojure-setup "flycheck-clojure" "\ +Setup Flycheck for Clojure. + +\(fn)" t nil) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; flycheck-clojure-autoloads.el ends here diff --git a/elpa/flycheck-clojure-20160704.1221/flycheck-clojure-pkg.el b/elpa/flycheck-clojure-20160704.1221/flycheck-clojure-pkg.el new file mode 100644 index 0000000..72d1866 --- /dev/null +++ b/elpa/flycheck-clojure-20160704.1221/flycheck-clojure-pkg.el @@ -0,0 +1 @@ +(define-package "flycheck-clojure" "20160704.1221" "Flycheck: Clojure support" '((cider "0.8.1") (flycheck "0.22alpha1") (let-alist "1.0.1") (emacs "24")) :url "https://github.com/clojure-emacs/squiggly-clojure") diff --git a/elpa/flycheck-clojure-20160704.1221/flycheck-clojure.el b/elpa/flycheck-clojure-20160704.1221/flycheck-clojure.el new file mode 100644 index 0000000..c24645b --- /dev/null +++ b/elpa/flycheck-clojure-20160704.1221/flycheck-clojure.el @@ -0,0 +1,221 @@ +;;; flycheck-clojure.el --- Flycheck: Clojure support -*- lexical-binding: t; -*- + +;; Copyright © 2014 Peter Fraenkel +;; Copyright (C) 2014 Sebastian Wiesner +;; +;; Author: Peter Fraenkel +;; Sebastian Wiesner +;; Maintainer: Peter Fraenkel +;; URL: https://github.com/clojure-emacs/squiggly-clojure +;; Package-Version: 20160704.1221 +;; Version: 1.1.0 +;; Package-Requires: ((cider "0.8.1") (flycheck "0.22-cvs1") (let-alist "1.0.1") (emacs "24")) + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Add Clojure support to Flycheck. +;; +;; Provide syntax checkers to check Clojure code using a running Cider repl. +;; +;; Installation: +;; +;; (eval-after-load 'flycheck '(flycheck-clojure-setup)) + +;;; Code: + +(require 'cider-client) +(require 'flycheck) +(require 'json) +(require 'url-parse) +(eval-when-compile (require 'let-alist)) + +(defcustom flycheck-clojure-inject-dependencies-at-jack-in t + "When nil, do not inject repl dependencies (i.e. the linters/checkers) at `cider-jack-in' time." + :group 'flycheck-clojure + :type 'boolean) + +(defvar flycheck-clojure-dep-version "0.1.6" + "Version of `acyclic/squiggly-clojure' compatible with this version of flycheck-clojure.") + +;;;###autoload +(defun flycheck-clojure-parse-cider-errors (value checker) + "Parse cider errors from JSON VALUE from CHECKER. + +Return a list of parsed `flycheck-error' objects." + ;; Parse the nested JSON from Cider. The outer JSON contains the return value + ;; from Cider, and the inner JSON the errors returned by the individual + ;; checker. + (let ((error-objects (json-read-from-string (json-read-from-string value)))) + (mapcar (lambda (o) + (let-alist o + ;; Use the file name reported by the syntax checker, but only if + ;; its absolute, because typed reports relative file names that + ;; are hard to expand correctly, since they are relative to the + ;; source directory (not the project directory). + (let* ((parsed-file (when .file + (url-filename + (url-generic-parse-url .file)))) + (filename (if (and parsed-file + (file-name-absolute-p parsed-file)) + parsed-file + (buffer-file-name)))) + (flycheck-error-new-at .line .column (intern .level) .msg + :checker checker + :filename filename)))) + error-objects))) + +(defun cider-flycheck-eval (input callback) + "Send the request INPUT and register the CALLBACK as the response handler. +Uses the tooling session, with no specified namespace." + (cider-tooling-eval input callback)) + +(defun flycheck-clojure-may-use-cider-checker () + "Determine whether a cider checker may be used. + +Checks for `cider-mode', and a current nREPL connection. + +Standard predicate for cider checkers." + (let ((connection-buffer (cider-default-connection :no-error))) + (and (bound-and-true-p cider-mode) + connection-buffer + (buffer-live-p (get-buffer connection-buffer)) + (clojure-find-ns)))) + +(defun flycheck-clojure-start-cider (checker callback) + "Start a cider syntax CHECKER with CALLBACK." + (let ((ns (clojure-find-ns)) + (form (get checker 'flycheck-clojure-form))) + (cider-flycheck-eval + (funcall form ns) + (nrepl-make-response-handler + (current-buffer) + (lambda (buffer value) + (funcall callback 'finished + (with-current-buffer buffer + (flycheck-clojure-parse-cider-errors value checker)))) + nil ; stdout + nil ; stderr + (lambda (_) + ;; If the evaluation completes without returning any value, there has + ;; gone something wrong. Ideally, we'd report *what* was wrong, but + ;; `nrepl-make-response-handler' is close to useless for this :(, + ;; because it just `message's for many status codes that are errors for + ;; us :( + (funcall callback 'errored "Done with no errors")) + (lambda (_buffer ex _rootex _sess) + (funcall callback 'errored + (format "Form %s of checker %s failed: %s" + form checker ex)))))) +) + +(defun flycheck-clojure-define-cider-checker (name docstring &rest properties) + "Define a Cider syntax checker with NAME, DOCSTRING and PROPERTIES. + +NAME, DOCSTRING, and PROPERTIES are like for +`flycheck-define-generic-checker', except that `:start' and +`:modes' are invalid PROPERTIES. A syntax checker defined with +this function will always check in `clojure-mode', and only if +`cider-mode' is enabled. + +Instead of `:start', this syntax checker requires a `:form +FUNCTION' property. FUNCTION takes the current Clojure namespace +as single argument, and shall return a string containing a +Clojure form to be sent to Cider to check the current buffer." + (declare (indent 1) + (doc-string 2)) + (let* ((form (plist-get properties :form)) + (orig-predicate (plist-get properties :predicate))) + + (when (plist-get :start properties) + (error "Checker %s may not have :start" name)) + (when (plist-get :modes properties) + (error "Checker %s may not have :modes" name)) + (unless (functionp form) + (error ":form %s of %s not a valid function" form name)) + (apply #'flycheck-define-generic-checker + name docstring + :start #'flycheck-clojure-start-cider + :modes '(clojure-mode) + :predicate (if orig-predicate + (lambda () + (and (flycheck-clojure-may-use-cider-checker) + (funcall orig-predicate))) + #'flycheck-clojure-may-use-cider-checker) + properties) + + (put name 'flycheck-clojure-form form))) + +(flycheck-clojure-define-cider-checker 'clojure-cider-eastwood + "A syntax checker for Clojure, using Eastwood in Cider. + +See URL `https://github.com/jonase/eastwood' and URL +`https://github.com/clojure-emacs/cider/' for more information." + :form (lambda (ns) + (format "(do (require 'squiggly-clojure.core) (squiggly-clojure.core/check-ew '%s))" + ns)) + :next-checkers '(clojure-cider-kibit clojure-cider-typed)) + +(flycheck-clojure-define-cider-checker 'clojure-cider-kibit + "A syntax checker for Clojure, using Kibit in Cider. + +See URL `https://github.com/jonase/kibit' and URL +`https://github.com/clojure-emacs/cider/' for more information." + :form (lambda (ns) + (format + "(do (require 'squiggly-clojure.core) (squiggly-clojure.core/check-kb '%s %s))" + ns + ;; Escape file name for Clojure + (flycheck-sexp-to-string (buffer-file-name)))) + :predicate (lambda () (buffer-file-name)) + :next-checkers '(clojure-cider-typed)) + +(flycheck-clojure-define-cider-checker 'clojure-cider-typed + "A syntax checker for Clojure, using Typed Clojure in Cider. + +See URL `https://github.com/clojure-emacs/cider/' and URL +`https://github.com/clojure/core.typed' for more information." + :form (lambda (ns) + (format + "(do (require 'squiggly-clojure.core) (squiggly-clojure.core/check-tc '%s))" + ns))) + +(defun flycheck-clojure-inject-jack-in-dependencies () + "Inject the REPL dependencies of flycheck-clojure at `cider-jack-in'. +If injecting the dependencies is not preferred set `flycheck-clojure-inject-dependencies-at-jack-in' to nil." + (when (and flycheck-clojure-inject-dependencies-at-jack-in + (boundp 'cider-jack-in-dependencies)) + (add-to-list 'cider-jack-in-dependencies `("acyclic/squiggly-clojure" ,flycheck-clojure-dep-version)))) + +;;;###autoload +(defun flycheck-clojure-setup () + "Setup Flycheck for Clojure." + (interactive) + ;; Add checkers in reverse order, because `add-to-list' adds to front. + (dolist (checker '(clojure-cider-typed + clojure-cider-kibit + clojure-cider-eastwood)) + (add-to-list 'flycheck-checkers checker)) + (flycheck-clojure-inject-jack-in-dependencies)) + +(provide 'flycheck-clojure) + +;; Local Variables: +;; indent-tabs-mode: nil +;; End: + +;;; flycheck-clojure.el ends here diff --git a/elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config-autoloads.el b/elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config-autoloads.el new file mode 100644 index 0000000..6c5e77b --- /dev/null +++ b/elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config-autoloads.el @@ -0,0 +1,23 @@ +;;; flycheck-pkg-config-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil "flycheck-pkg-config" "flycheck-pkg-config.el" +;;;;;; (22500 1790 332045 278000)) +;;; Generated autoloads from flycheck-pkg-config.el + +(autoload 'flycheck-pkg-config "flycheck-pkg-config" "\ +Configure flycheck to use additional includes +when checking the current buffer. + +\(fn)" t nil) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; flycheck-pkg-config-autoloads.el ends here diff --git a/elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config-pkg.el b/elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config-pkg.el new file mode 100644 index 0000000..3b6c4c0 --- /dev/null +++ b/elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config-pkg.el @@ -0,0 +1 @@ +(define-package "flycheck-pkg-config" "20160610.1335" "configure flycheck using pkg-config" '((dash "2.8.0") (s "1.9.0") (cl-lib "0.5")) :keywords '("flycheck")) diff --git a/elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config.el b/elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config.el new file mode 100644 index 0000000..7343ea7 --- /dev/null +++ b/elpa/flycheck-pkg-config-20160610.1335/flycheck-pkg-config.el @@ -0,0 +1,85 @@ +;;; flycheck-pkg-config.el --- configure flycheck using pkg-config -*- lexical-binding: t; -*- + +;; Copyright (C) 2016 + +;; Author: Wilfred Hughes +;; Keywords: flycheck +;; Package-Version: 20160610.1335 +;; Version: 0.1 +;; Package-Requires: ((dash "2.8.0") (s "1.9.0") (cl-lib "0.5")) + +;; 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 2 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Flycheck defines a `flycheck-clang-include-path' variable that it +;; searches for headers when checking C/C++ code. +;; +;; This package provides a convenient way of adding libraries to that +;; list, using pkg-config and completion. + +;;; Code: + +(require 's) +(require 'dash) +(require 'flycheck) + +(defvar flycheck-pkg-config--libs nil) + +(defun flycheck-pkg-config--ignore-case-less-p (s1 s2) + (string< (downcase s1) (downcase s2))) + +(defun flycheck-pkg-config--set-libs () + "Set `flycheck-pkg-config--libs' by calling pkg-config." + (let* ((all-libs-with-names + (shell-command-to-string "pkg-config --list-all")) + (lines (s-split "\n" (s-trim all-libs-with-names))) + (libs (--map (-first-item (s-split " " it)) lines))) + (setq flycheck-pkg-config--libs (-sort #'flycheck-pkg-config--ignore-case-less-p libs)))) + +(defun flycheck-pkg-config--include-paths (library-name) + "Get a list of include paths for LIBRARY-NAME. +Raises an error if pkg-config can't find any paths for this library." + (let* (;; Find the include flags, e.g. "-I/usr/lib/foo" + (pkgconfig-cmd (format "pkg-config --cflags %s" library-name)) + (cc-args (s-trim (shell-command-to-string pkgconfig-cmd)))) + (if (s-contains? "-I" cc-args) + ;; pkg-config has found a library with this name. + (let (ret) + (dolist (x (s-split " " cc-args) ret) + (if (s-starts-with? "-I" x) (setq ret (cons (s-chop-prefix "-I" x) ret))))) + (user-error cc-args)))) + +;;;###autoload +(defun flycheck-pkg-config () + "Configure flycheck to use additional includes +when checking the current buffer." + (interactive) + ;; Find out all the libraries installed on this system. + (unless flycheck-pkg-config--libs + (flycheck-pkg-config--set-libs)) + (let* ((lib-name (completing-read "Library name: " flycheck-pkg-config--libs)) + ;; Find the include paths, e.g. "-I/usr/lib/foo" + (include-paths (flycheck-pkg-config--include-paths lib-name))) + ;; Only set in this buffer. + (make-local-variable 'flycheck-clang-include-path) + ;; Add include paths to `flycheck-clang-include-path' unless + ;; already present. + (setq flycheck-clang-include-path + (-union flycheck-clang-include-path include-paths)) + (message "flycheck-clang-include-path: %s" + flycheck-clang-include-path))) + +(provide 'flycheck-pkg-config) +;;; flycheck-pkg-config.el ends here diff --git a/elpa/focus-20160131.1418/focus-autoloads.el b/elpa/focus-20160131.1418/focus-autoloads.el new file mode 100644 index 0000000..e1f3048 --- /dev/null +++ b/elpa/focus-20160131.1418/focus-autoloads.el @@ -0,0 +1,26 @@ +;;; focus-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil "focus" "focus.el" (22500 1789 464040 629000)) +;;; Generated autoloads from focus.el + +(autoload 'focus-mode "focus" "\ +Dim the font color of text in surrounding sections. + +\(fn &optional ARG)" t nil) + +(autoload 'focus-read-only-mode "focus" "\ +A read-only mode optimized for `focus-mode'. + +\(fn &optional ARG)" t nil) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; focus-autoloads.el ends here diff --git a/elpa/focus-20160131.1418/focus-pkg.el b/elpa/focus-20160131.1418/focus-pkg.el new file mode 100644 index 0000000..063b363 --- /dev/null +++ b/elpa/focus-20160131.1418/focus-pkg.el @@ -0,0 +1 @@ +(define-package "focus" "20160131.1418" "Dim the font color of text in surrounding sections" '((emacs "24") (cl-lib "0.5")) :url "http://github.com/larstvei/Focus") diff --git a/elpa/focus-20160131.1418/focus.el b/elpa/focus-20160131.1418/focus.el new file mode 100644 index 0000000..5521939 --- /dev/null +++ b/elpa/focus-20160131.1418/focus.el @@ -0,0 +1,306 @@ +;;; focus.el --- Dim the font color of text in surrounding sections -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Lars Tveito + +;; Author: Lars Tveito +;; URL: http://github.com/larstvei/Focus +;; Package-Version: 20160131.1418 +;; Created: 11th May 2015 +;; Version: 0.1.0 +;; Package-Requires: ((emacs "24") (cl-lib "0.5")) + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Focus provides `focus-mode` that dims the text of surrounding sections, +;; similar to [iA Writer's](https://ia.net/writer) Focus Mode. +;; +;; Enable the mode with `M-x focus-mode'. + +;;; Code: + +(require 'cl-lib) +(require 'thingatpt) + +(defgroup focus () + "Dim the font color of text in surrounding sections." + :group 'font-lock + :prefix "focus-") + +(defcustom focus-dimness 0 + "Amount of dimness in out of focus sections is determined by this integer. + +A positive value increases the dimness of the sections. +A negative value decreases the dimness. + +The default is 0 which means a 50/50 mixture of the background +and foreground color." + :type '(integer) + :group 'focus) + +(defcustom focus-mode-to-thing '((prog-mode . defun) (text-mode . sentence)) + "An associated list between mode and thing. + +A thing is defined in thingatpt.el; the thing determines the +narrowness of the focused section. + +Note that the order of the list matters. The first mode that the +current mode is derived from is used, so more modes that have +many derivatives should be placed by the end of the list. + +Things that are defined include `symbol', `list', `sexp', +`defun', `filename', `url', `email', `word', `sentence', +`whitespace', `line', and `page'." + :type '(repeat symbol) + :group 'focus) + +(defcustom focus-read-only-blink-seconds 1 + "The duration of a cursor blink in `focus-read-only-mode'." + :type '(float) + :group 'focus) + +(defvar focus-current-thing nil + "Overrides the choice of thing dictated by `focus-mode-to-thing' if set.") + +(defvar focus-pre-overlay nil + "The overlay that dims the text prior to the current-point.") + +(defvar focus-post-overlay nil + "The overlay that dims the text past the current-point.") + +(defvar focus-read-only-blink-timer nil + "Timer started from `focus-read-only-cursor-blink'. +The timer calls `focus-read-only-hide-cursor' after +`focus-read-only-blink-seconds' seconds.") + +;; Use make-local-variable for backwards compatibility. +(dolist (var '(focus-current-thing + focus-pre-overlay + focus-post-overlay + focus-read-only-blink-timer)) + (make-local-variable var)) + +;; Changing major-mode should not affect Focus mode. +(dolist (var '(focus-current-thing + focus-pre-overlay + focus-post-overlay + post-command-hook)) + (put var 'permanent-local t)) + +(defun focus-any (f lst) + "Apply F to each element of LST and return first NON-NIL." + (when lst + (let ((v (funcall f (car lst)))) + (if v v (focus-any f (cdr lst)))))) + +(defun focus-get-thing () + "Return the current thing, based on `focus-mode-to-thing'." + (or focus-current-thing + (let* ((modes (mapcar 'car focus-mode-to-thing)) + (mode (focus-any 'derived-mode-p modes))) + (if mode (cdr (assoc mode focus-mode-to-thing)) 'sentence)))) + +(defun focus-bounds () + "Return the current bounds, based on `focus-get-thing'." + (bounds-of-thing-at-point (focus-get-thing))) + +(defun focus-average-colors (color &rest colors) + "Takes an average of the colors given by argument. +Argument COLOR is a color name, and so are the COLORS; COLOR is +there to ensure that the the function receives at least one +argument." + (let* ((colors (cons color colors)) + (colors (mapcar 'color-name-to-rgb colors)) + (len (length colors)) + (sums (apply 'cl-mapcar '+ colors)) + (avg (mapcar (lambda (v) (/ v len)) sums))) + (apply 'color-rgb-to-hex avg))) + +(defun focus-make-dim-color () + "Return a dimmed color relative to the current theme." + (let ((background (face-attribute 'default :background)) + (foreground (face-attribute 'default :foreground)) + (backgrounds (if (> focus-dimness 0) focus-dimness 1)) + (foregrounds (if (< focus-dimness 0) (- focus-dimness) 1))) + (apply 'focus-average-colors + (append (make-list backgrounds background) + (make-list foregrounds foreground))))) + +(defun focus-move-focus () + "Moves the focused section according to `focus-bounds'. + +If `focus-mode' is enabled, this command fires after each +command." + (let* ((bounds (focus-bounds))) + (when bounds + (focus-move-overlays (car bounds) (cdr bounds))))) + +(defun focus-move-overlays (low high) + "Move `focus-pre-overlay' and `focus-post-overlay'." + (move-overlay focus-pre-overlay (point-min) low) + (move-overlay focus-post-overlay high (point-max))) + +(defun focus-init () + "This function is run when command `focus-mode' is enabled. + +It sets the `focus-pre-overlay' and `focus-post-overlay' to +overlays; these are invisible until `focus-move-focus' is run. It +adds `focus-move-focus' to `post-command-hook'." + (unless (or focus-pre-overlay focus-post-overlay) + (setq focus-pre-overlay (make-overlay (point-min) (point-min)) + focus-post-overlay (make-overlay (point-max) (point-max))) + (let ((color (focus-make-dim-color))) + (mapc (lambda (o) (overlay-put o 'face (cons 'foreground-color color))) + (list focus-pre-overlay focus-post-overlay))) + (add-hook 'post-command-hook 'focus-move-focus nil t))) + +(defun focus-terminate () + "This function is run when command `focus-mode' is disabled. + +The overlays pointed to by `focus-pre-overlay' and `focus-post-overlay' are +deleted, and `focus-move-focus' is removed from `post-command-hook'." + (when (and focus-pre-overlay focus-post-overlay) + (mapc 'delete-overlay (list focus-pre-overlay focus-post-overlay)) + (remove-hook 'post-command-hook 'focus-move-focus t) + (setq focus-pre-overlay nil + focus-post-overlay nil))) + +(defun focus-goto-thing (bounds) + "Move point to the middle of BOUNDS." + (when bounds + (goto-char (/ (+ (car bounds) (cdr bounds)) 2)) + (recenter nil))) + +(defun focus-change-thing () + "Adjust the narrowness of the focused section for the current buffer. + +The variable `focus-mode-to-thing' dictates the default thing +according to major-mode. If `focus-current-thing' is set, this +default is overwritten. This function simply helps set the +`focus-current-thing'." + (interactive) + (let* ((candidates '(symbol list sexp defun + filename url email word + sentence whitespace line page)) + (thing (completing-read "Thing: " candidates))) + (setq focus-current-thing (intern thing)))) + +(defun focus-pin () + "Pin the focused section to its current location or the region, +if active." + (interactive) + (when focus-mode + (when (region-active-p) + (focus-move-overlays (region-beginning) (region-end))) + (remove-hook 'post-command-hook 'focus-move-focus t))) + +(defun focus-unpin () + "Unpin the focused section." + (interactive) + (when focus-mode + (add-hook 'post-command-hook 'focus-move-focus nil t))) + +(defun focus-next-thing (&optional n) + "Moves the point to the middle of the Nth next thing." + (interactive "p") + (let ((current-bounds (focus-bounds)) + (thing (focus-get-thing))) + (forward-thing thing n) + (when (equal current-bounds (focus-bounds)) + (forward-thing thing (signum n))) + (focus-goto-thing (focus-bounds)))) + +(defun focus-prev-thing (&optional n) + "Moves the point to the middle of the Nth previous thing." + (interactive "p") + (focus-next-thing (- n))) + +(defun focus-read-only-hide-cursor (&optional buffer) + "Hide the cursor. +This function is triggered by the `focus-read-only-blink-timer', +when `focus-read-only-mode' is activated." + (with-current-buffer (or buffer (current-buffer)) + (when (and focus-read-only-mode (not (null focus-read-only-blink-timer))) + (setq focus-read-only-blink-timer nil) + (setq cursor-type nil)))) + +(defun focus-read-only-cursor-blink () + "Make the cursor visible for `focus-read-only-blink-seconds'. +This is added to the `pre-command-hook' when +`focus-read-only-mode' is active." + (when (and focus-read-only-mode + (not (member last-command '(focus-next-thing focus-prev-thing)))) + (when focus-read-only-blink-timer (cancel-timer focus-read-only-blink-timer)) + (setq cursor-type t) + (setq focus-read-only-blink-timer + (run-at-time focus-read-only-blink-seconds nil + 'focus-read-only-hide-cursor (current-buffer))))) + +(defun focus-read-only-init () + "Run when `focus-read-only-mode' is activated. +Enables `read-only-mode', hides the cursor and adds +`focus-read-only-cursor-blink' to `pre-command-hook'. Also +`focus-read-only-terminate' is added to the `kill-buffer-hook'." + (read-only-mode 1) + (setq cursor-type nil) + (add-hook 'pre-command-hook 'focus-read-only-cursor-blink nil t) + (add-hook 'kill-buffer-hook 'focus-read-only-terminate t)) + +(defun focus-read-only-terminate () + "Run when `focus-read-only-mode' is deactivated. +Disables `read-only-mode' and shows the cursor again. It cleans +up the `focus-read-only-blink-timer' and hooks." + (read-only-mode -1) + (setq cursor-type t) + (when focus-read-only-blink-timer + (cancel-timer focus-read-only-blink-timer)) + (setq focus-read-only-blink-timer nil) + (remove-hook 'pre-command-hook 'focus-read-only-cursor-blink t) + (remove-hook 'kill-buffer-hook 'focus-read-only-terminate t)) + +(defun turn-off-focus-read-only-mode () + "Turn off `focus-read-only-mode'." + (interactive) + (focus-read-only-mode -1)) + +;;;###autoload +(define-minor-mode focus-mode + "Dim the font color of text in surrounding sections." + :init-value nil + :keymap (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-q") 'focus-read-only-mode) + map) + (unless (and (color-defined-p (face-attribute 'default :background)) + (color-defined-p (face-attribute 'default :foreground))) + (message "Can't enable focus mode when no theme is loaded.") + (setq focus-mode nil)) + (if focus-mode (focus-init) (focus-terminate))) + +;;;###autoload +(define-minor-mode focus-read-only-mode + "A read-only mode optimized for `focus-mode'." + :init-value nil + :keymap (let ((map (make-sparse-keymap))) + (define-key map (kbd "n") 'focus-next-thing) + (define-key map (kbd "SPC") 'focus-next-thing) + (define-key map (kbd "p") 'focus-prev-thing) + (define-key map (kbd "S-SPC") 'focus-prev-thing) + (define-key map (kbd "i") 'turn-off-focus-read-only-mode) + (define-key map (kbd "q") 'turn-off-focus-read-only-mode) + map) + (if focus-read-only-mode (focus-read-only-init) (focus-read-only-terminate))) + +(provide 'focus) +;;; focus.el ends here diff --git a/elpa/git-messenger-20160815.1952/git-messenger-autoloads.el b/elpa/git-messenger-20160815.1952/git-messenger-autoloads.el new file mode 100644 index 0000000..01167d6 --- /dev/null +++ b/elpa/git-messenger-20160815.1952/git-messenger-autoloads.el @@ -0,0 +1,22 @@ +;;; git-messenger-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil "git-messenger" "git-messenger.el" (22500 1788 +;;;;;; 424035 61000)) +;;; Generated autoloads from git-messenger.el + +(autoload 'git-messenger:popup-message "git-messenger" "\ + + +\(fn)" t nil) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; git-messenger-autoloads.el ends here diff --git a/elpa/git-messenger-20160815.1952/git-messenger-pkg.el b/elpa/git-messenger-20160815.1952/git-messenger-pkg.el new file mode 100644 index 0000000..d87408e --- /dev/null +++ b/elpa/git-messenger-20160815.1952/git-messenger-pkg.el @@ -0,0 +1 @@ +(define-package "git-messenger" "20160815.1952" "Pop up last commit information of current line" '((popup "0.5.0") (cl-lib "0.5")) :url "https://github.com/syohex/emacs-git-messenger") diff --git a/elpa/git-messenger-20160815.1952/git-messenger.el b/elpa/git-messenger-20160815.1952/git-messenger.el new file mode 100644 index 0000000..8ee492c --- /dev/null +++ b/elpa/git-messenger-20160815.1952/git-messenger.el @@ -0,0 +1,406 @@ +;;; git-messenger.el --- Pop up last commit information of current line + +;; Copyright (C) 2016 by Syohei YOSHIDA + +;; Author: Syohei YOSHIDA +;; URL: https://github.com/syohex/emacs-git-messenger +;; Package-Version: 20160815.1952 +;; Version: 0.17 +;; Package-Requires: ((popup "0.5.0") (cl-lib "0.5")) + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This package provides a function called git-messenger:popup-message +;; that when called will pop-up the last git commit message for the +;; current line. This uses the git-blame tool internally. +;; +;; Example usage: +;; (require 'git-messenger) +;; (global-set-key (kbd "C-x v p") 'git-messenger:popup-message) +;; + +;;; Code: + +(require 'cl-lib) +(require 'popup) + +(defgroup git-messenger nil + "git messenger" + :group 'vc) + +(defcustom git-messenger:show-detail nil + "Pop up commit ID and author name too" + :type 'boolean) + +(defcustom git-messenger:before-popup-hook nil + "Hook run before popup commit message. This hook is taken popup-ed message" + :type 'hook) + +(defcustom git-messenger:after-popup-hook nil + "Hook run after popup commit message. This hook is taken popup-ed message" + :type 'hook) + +(defcustom git-messenger:popup-buffer-hook nil + "Hook run after popup buffer(popup diff, popup show etc)" + :type 'hook) + +(defcustom git-messenger:handled-backends '(git svn hg) + "List of version control backends for which `git-messenger' will be used. +Entries in this list will be tried in order to determine whether a +file is under that sort of version control." + :type '(repeat symbol)) + +(defvar git-messenger:last-message nil + "Last message displayed by git-messenger. + +This is set before the pop-up is displayed so accessible in the hooks +and menus.") + +(defvar git-messenger:last-commit-id nil + "Last commit id for the last message displayed. + +This is set before the pop-up is displayed so accessible in the hooks +and menus.") + +(defvar git-messenger:vcs nil) + +(defconst git-messenger:directory-of-vcs + '((git . ".git") + (svn . ".svn") + (hg . ".hg"))) + +(defun git-messenger:blame-arguments (vcs file line) + (let ((basename (file-name-nondirectory file))) + (cl-case vcs + (git (list "--no-pager" "blame" "-w" "-L" + (format "%d,+1" line) + "--porcelain" basename)) + (svn (list "blame" basename)) + (hg (list "blame" "-wuc" basename))))) + +(defsubst git-messenger:cat-file-arguments (commit-id) + (list "--no-pager" "cat-file" "commit" commit-id)) + +(defsubst git-messenger:vcs-command (vcs) + (cl-case vcs + (git "git") + (svn "svn") + (hg "hg"))) + +(defun git-messenger:execute-command (vcs args output) + (cl-case vcs + (git (apply 'process-file "git" nil output nil args)) + (svn + (let ((process-environment (cons "LANG=C" process-environment))) + (apply 'process-file "svn" nil output nil args))) + (hg + (let ((process-environment (cons + "HGPLAIN=1" + (cons "LANG=utf-8" process-environment)))) + (apply 'process-file "hg" nil output nil args))))) + +(defun git-messenger:git-commit-info-at-line () + (let* ((id-line (buffer-substring-no-properties + (line-beginning-position) (line-end-position))) + (commit-id (car (split-string id-line))) + (author (if (re-search-forward "^author \\(.+\\)$" nil t) + (match-string-no-properties 1) + "unknown"))) + (cons commit-id author))) + +(defun git-messenger:hg-commit-info-at-line (line) + (forward-line (1- line)) + (if (looking-at "^\\s-*\\(\\S-+\\)\\s-+\\([a-z0-9]+\\)") + (cons (match-string-no-properties 2) (match-string-no-properties 1)) + (cons "-" "-"))) + +(defun git-messenger:svn-commit-info-at-line (line) + (forward-line (1- line)) + (if (looking-at "^\\s-*\\([0-9]+\\)\\s-+\\(\\S-+\\)") + (cons (match-string-no-properties 1) (match-string-no-properties 2)) + (cons "-" "-"))) + +(defun git-messenger:commit-info-at-line (vcs file line) + (with-temp-buffer + (let ((args (git-messenger:blame-arguments vcs file line))) + (unless (zerop (git-messenger:execute-command vcs args t)) + (error "Failed: '%s blame'" (git-messenger:vcs-command vcs))) + (goto-char (point-min)) + (cl-case vcs + (git (git-messenger:git-commit-info-at-line)) + (svn (git-messenger:svn-commit-info-at-line line)) + (hg (git-messenger:hg-commit-info-at-line line)))))) + +(defsubst git-messenger:not-committed-id-p (commit-id) + (or (string-match-p "\\`\\(?:0+\\|-\\)\\'" commit-id))) + +(defun git-messenger:git-commit-message (commit-id) + (let ((args (git-messenger:cat-file-arguments commit-id))) + (unless (zerop (git-messenger:execute-command 'git args t)) + (error "Failed: 'git cat-file'")) + (goto-char (point-min)) + (forward-paragraph) + (buffer-substring-no-properties (point) (point-max)))) + +(defun git-messenger:hg-commit-message (commit-id) + (let ((args (list "log" "-T" "{desc}" "-r" commit-id))) + (unless (zerop (git-messenger:execute-command 'hg args t)) + (error "Failed: 'hg log")) + (buffer-substring-no-properties (point-min) (point-max)))) + +(defun git-messenger:svn-commit-message (commit-id) + (let ((args (list "log" "-c" commit-id))) + (unless (zerop (git-messenger:execute-command 'svn args t)) + (error "Failed: 'svn log")) + (let (end) + (goto-char (point-max)) + (when (re-search-backward "^-\\{25\\}" nil t) + (setq end (point))) + (buffer-substring-no-properties (point-min) (or end (point-max)))))) + +(defun git-messenger:commit-message (vcs commit-id) + (with-temp-buffer + (if (git-messenger:not-committed-id-p commit-id) + "* not yet committed *" + (cl-case vcs + (git (git-messenger:git-commit-message commit-id)) + (svn (git-messenger:svn-commit-message commit-id)) + (hg (git-messenger:hg-commit-message commit-id)))))) + +(defun git-messenger:commit-date (commit-id) + (let ((args (list "--no-pager" "show" "--pretty=%cd" commit-id))) + (with-temp-buffer + (unless (zerop (git-messenger:execute-command 'git args t)) + (error "Failed 'git show'")) + (goto-char (point-min)) + (buffer-substring-no-properties + (line-beginning-position) (line-end-position))))) + +(defun git-messenger:hg-commit-date (commit-id) + (let ((args (list "log" "-T" "{date|rfc822date}" "-r" commit-id))) + (with-temp-buffer + (unless (zerop (git-messenger:execute-command 'hg args t)) + (error "Failed 'hg log'")) + (goto-char (point-min)) + (buffer-substring-no-properties + (line-beginning-position) (line-end-position))))) + +(defun git-messenger:format-detail (vcs commit-id author message) + (cl-case vcs + (git (let ((date (git-messenger:commit-date commit-id))) + (format "commit : %s \nAuthor : %s\nDate : %s \n%s" + (substring commit-id 0 8) author date message))) + (hg (let ((date (git-messenger:hg-commit-date commit-id))) + (format "commit : %s \nAuthor : %s\nDate : %s \n%s" + commit-id author date message))) + (svn (with-temp-buffer + (insert message) + (goto-char (point-min)) + (forward-line 1) + (let ((line (buffer-substring-no-properties (point) (line-end-position))) + (re "^\\s-*\\(?:r[0-9]+\\)\\s-+|\\s-+\\([^|]+\\)|\\s-+\\([^|]+\\)")) + (unless (string-match re line) + (error "Can't get revision %s" line)) + (let ((author (match-string-no-properties 1 line)) + (date (match-string-no-properties 2 line))) + (forward-paragraph) + (format "commit : r%s \nAuthor : %s\nDate : %s\n%s" + commit-id author date + (buffer-substring-no-properties (point) (point-max))))))))) + +(defun git-messenger:show-detail-p (commit-id) + (and (or git-messenger:show-detail current-prefix-arg) + (not (git-messenger:not-committed-id-p commit-id)))) + +(defun git-messenger:popup-close () + (interactive) + (throw 'git-messenger-loop t)) + +(defun git-messenger:copy-message () + "Copy current displayed commit message to kill-ring." + (interactive) + (when git-messenger:last-message + (kill-new git-messenger:last-message)) + (git-messenger:popup-close)) + +(defun git-messenger:copy-commit-id () + "Copy current displayed commit id to kill-ring." + (interactive) + (when git-messenger:last-commit-id + (kill-new git-messenger:last-commit-id)) + (git-messenger:popup-close)) + +(defun git-messenger:popup-common (vcs args &optional mode) + (with-current-buffer (get-buffer-create "*git-messenger*") + (view-mode -1) + (fundamental-mode) + (erase-buffer) + (unless (zerop (git-messenger:execute-command vcs args t)) + (error "Failed: '%s(args=%s)'" (git-messenger:vcs-command vcs) args)) + (pop-to-buffer (current-buffer)) + (when mode + (funcall mode)) + (run-hooks 'git-messenger:popup-buffer-hook) + (view-mode +1) + (goto-char (point-min))) + (git-messenger:popup-close)) + +(defun git-messenger:popup-svn-show () + (git-messenger:popup-common + 'svn (list "diff" "-c" git-messenger:last-commit-id) 'diff-mode)) + +(defun git-messenger:popup-hg-show () + (git-messenger:popup-common + 'hg (list "diff" "-c" git-messenger:last-commit-id) 'diff-mode)) + +(defun git-messenger:popup-diff () + (interactive) + (cl-case git-messenger:vcs + (git (let ((args (list "--no-pager" "diff" "--no-ext-diff" + (concat git-messenger:last-commit-id "^!")))) + (git-messenger:popup-common 'git args 'diff-mode))) + (svn (git-messenger:popup-svn-show)) + (hg (git-messenger:popup-hg-show)))) + +(defun git-messenger:popup-show () + (interactive) + (cl-case git-messenger:vcs + (git (let ((args (list "--no-pager" "show" "--no-ext-diff" "--stat" + git-messenger:last-commit-id))) + (git-messenger:popup-common 'git args))) + (svn (git-messenger:popup-svn-show)) + (hg (let ((args (list "log" "--stat" "-r" + git-messenger:last-commit-id))) + (git-messenger:popup-common 'hg args))))) + +(defun git-messenger:popup-show-verbose () + (interactive) + (cl-case git-messenger:vcs + (git (let ((args (list "--no-pager" "show" "--no-ext-diff" "--stat" "-p" + git-messenger:last-commit-id))) + (git-messenger:popup-common 'git args))) + (svn (error "'svn' does not support `popup-show-verbose'")) + (hg (let ((args (list "log" "-p" "--stat" "-r" + git-messenger:last-commit-id))) + (git-messenger:popup-common 'hg args))))) + +(defvar git-messenger-map + (let ((map (make-sparse-keymap))) + ;; key bindings + (define-key map (kbd "q") 'git-messenger:popup-close) + (define-key map (kbd "c") 'git-messenger:copy-commit-id) + (define-key map (kbd "d") 'git-messenger:popup-diff) + (define-key map (kbd "s") 'git-messenger:popup-show) + (define-key map (kbd "S") 'git-messenger:popup-show-verbose) + (define-key map (kbd "M-w") 'git-messenger:copy-message) + (define-key map (kbd ",") 'git-messenger:show-parent) + map) + "Key mappings of git-messenger. This is enabled when commit message is popup-ed.") + +(defun git-messenger:find-vcs () + (let ((longest 0) + result) + (dolist (vcs git-messenger:handled-backends result) + (let* ((dir (assoc-default vcs git-messenger:directory-of-vcs)) + (vcs-root (locate-dominating-file default-directory dir))) + (when (and vcs-root (> (length vcs-root) longest)) + (setq longest (length vcs-root) + result vcs)))))) + +(defun git-messenger:svn-message (msg) + (with-temp-buffer + (insert msg) + (goto-char (point-min)) + (forward-paragraph) + (buffer-substring-no-properties (point) (point-max)))) + +(defvar git-messenger:func-prompt + '((git-messenger:popup-show . "Show") + (git-messenger:popup-show-verbose . "Show verbose") + (git-messenger:popup-close . "Close") + (git-messenger:copy-commit-id . "Copy hash") + (git-messenger:popup-diff . "Diff") + (git-messenger:copy-message . "Copy message") + (git-messenger:show-parent . "Go Parent") + (git-messenger:popup-close . "Quit"))) + +(defsubst git-messenger:function-to-key (func) + (key-description (car-safe (where-is-internal func git-messenger-map)))) + +(defun git-messenger:prompt () + (mapconcat (lambda (fp) + (let ((key (git-messenger:function-to-key (car fp)))) + (format "[%s]%s" key (cdr fp)))) + git-messenger:func-prompt " ")) + +(defun git-messenger:show-parent () + (interactive) + (let ((file (buffer-file-name (buffer-base-buffer)))) + (cl-case git-messenger:vcs + (git (with-temp-buffer + (unless (zerop (process-file "git" nil t nil + "blame" "--increment" git-messenger:last-commit-id "--" file)) + (error "No parent commit ID")) + (goto-char (point-min)) + (when (re-search-forward (concat "^" git-messenger:last-commit-id) nil t) + (when (re-search-forward "previous \\(\\S-+\\)" nil t) + (let ((parent (match-string-no-properties 1))) + (setq git-messenger:last-commit-id parent + git-messenger:last-message (git-messenger:commit-message 'git parent))))) + (throw 'git-messenger-loop nil))) + (otherwise (error "%s does not support for getting parent commit ID" git-messenger:vcs))))) + +;;;###autoload +(defun git-messenger:popup-message () + (interactive) + (let* ((vcs (git-messenger:find-vcs)) + (file (buffer-file-name (buffer-base-buffer))) + (line (line-number-at-pos)) + (commit-info (git-messenger:commit-info-at-line vcs file line)) + (commit-id (car commit-info)) + (author (cdr commit-info)) + (msg (git-messenger:commit-message vcs commit-id)) + (popuped-message (if (git-messenger:show-detail-p commit-id) + (git-messenger:format-detail vcs commit-id author msg) + (cl-case vcs + (git msg) + (svn (if (string= commit-id "-") + msg + (git-messenger:svn-message msg))) + (hg msg))))) + (setq git-messenger:vcs vcs + git-messenger:last-message popuped-message + git-messenger:last-commit-id commit-id) + (let (finish) + (run-hook-with-args 'git-messenger:before-popup-hook popuped-message) + (while (not finish) + (let ((menu (popup-tip git-messenger:last-message :nowait t))) + (unwind-protect + (setq finish (catch 'git-messenger-loop + (popup-menu-event-loop menu git-messenger-map 'popup-menu-fallback + :prompt (git-messenger:prompt)) + t)) + (popup-delete menu))))) + (run-hook-with-args 'git-messenger:after-popup-hook popuped-message))) + +(provide 'git-messenger) + +;; Local Variables: +;; coding: utf-8 +;; indent-tabs-mode: nil +;; End: + +;;; git-messenger.el ends here diff --git a/elpa/gitconfig-20130718.235/gitconfig-autoloads.el b/elpa/gitconfig-20130718.235/gitconfig-autoloads.el new file mode 100644 index 0000000..3172e0b --- /dev/null +++ b/elpa/gitconfig-20130718.235/gitconfig-autoloads.el @@ -0,0 +1,15 @@ +;;; gitconfig-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil nil ("gitconfig.el") (22500 1787 601913 796000)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; gitconfig-autoloads.el ends here diff --git a/elpa/gitconfig-20130718.235/gitconfig-pkg.el b/elpa/gitconfig-20130718.235/gitconfig-pkg.el new file mode 100644 index 0000000..d7427ab --- /dev/null +++ b/elpa/gitconfig-20130718.235/gitconfig-pkg.el @@ -0,0 +1 @@ +(define-package "gitconfig" "20130718.235" "Emacs lisp interface to work with git-config variables" 'nil :keywords '("git" "gitconfig" "git-config")) diff --git a/elpa/gitconfig-20130718.235/gitconfig.el b/elpa/gitconfig-20130718.235/gitconfig.el new file mode 100644 index 0000000..ad52334 --- /dev/null +++ b/elpa/gitconfig-20130718.235/gitconfig.el @@ -0,0 +1,228 @@ +;;; gitconfig.el --- Emacs lisp interface to work with git-config variables +;; +;; Filename: gitconfig.el +;; Description: Emacs lisp interface to work with git-config variables +;; Author: Samuel Tonini +;; Maintainer: Samuel Tonini +;; Version: 1.0.0 +;; Package-Version: 20130718.235 +;; URL: +;; Keywords: git, gitconfig, git-config + +;; 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, 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; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. + +;;; Commentary: +;; +;; Manual Installation: +;; +;; (add-to-list 'load-path "~/path/to/gitconfig.el/") +;; (require 'gitconfig) +;; +;; Interesting variables are: +;; +;; `gitconfig-git-command' +;; +;; The shell command for +;; +;; `gitconfig-buffer-name' +;; +;; Name of the output buffer. +;; +;; Interactive functions are: +;; +;; M-x gitconfig-execute-command +;; +;; Run with custom ARGUMENTS and display it in `gitconfig-buffer-name' +;; +;; Non-Interactive functions are: +;; +;; `gitconfig-current-inside-git-repository-p' +;; +;; Return t if `default-directory' is a git repository +;; +;; `gitconfig-path-to-git-repository' +;; +;; Return the absolute path of the current git repository +;; +;; `gitconfig-get-variables' +;; +;; Get all variables for the given LOCATION +;; and return it as a hash table +;; +;; `gitconfig-set-variable' +;; +;; Set a specific LOCATION variable with a given NAME and VALUE +;; +;; `gitconfig-get-variable' +;; +;; Return a specific LOCATION variable for the given NAME +;; +;; `gitconfig-delete-variable' +;; +;; Delete a specific LOCATION variable for the given NAME +;; +;; `gitconfig-get-local-variables' +;; +;; Return all variables as hash table +;; +;; `gitconfig-get-global-variables' +;; +;; Return all variables as hash table +;; +;; `gitconfig-get-system-variables' +;; +;; Return all variables as hash table +;; +;; `gitconfig-get-local-variable' +;; +;; Return a specific variable by the given NAME +;; +;; `gitconfig-get-global-variable' +;; +;; Return a specific variable by the given NAME +;; +;; `gitconfig-get-system-variable' +;; +;; Return a specific variable by the given NAME +;; + +;;; Code: + +(defcustom gitconfig-git-command "git" + "The shell command for git" + :type 'string + :group 'gitconfig) + +(defvar gitconfig-buffer-name "*GITCONFIG*" + "Name of the git output buffer.") + +(defun gitconfig--get-keys (hash) + "Return all keys for given HASH" + (let (keys) + (maphash (lambda (key value) (setq keys (cons key keys))) hash) + keys)) + +(defun gitconfig--get-buffer (name) + "Get and kills a buffer if exists and returns a new one." + (let ((buffer (get-buffer name))) + (when buffer (kill-buffer buffer)) + (generate-new-buffer name))) + +(defun gitconfig--buffer-setup (buffer) + "Setup the gitconfig buffer before display." + (display-buffer buffer) + (with-current-buffer buffer + (setq buffer-read-only nil) + (local-set-key "q" 'quit-window))) + +(defun gitconfig-current-inside-git-repository-p () + "Return t if the `default-directory' is a repository" + (let ((inside-work-tree (shell-command-to-string + (format "%s rev-parse --is-inside-work-tree" + gitconfig-git-command)))) + (string= (replace-regexp-in-string "\n" "" inside-work-tree nil t) "true"))) + +(defun gitconfig-path-to-git-repository () + "Return the absolute path of the current git repository" + (let ((path-to-git-repo (shell-command-to-string + (format "%s rev-parse --show-toplevel" + gitconfig-git-command)))) + (replace-regexp-in-string "\n" "" path-to-git-repo nil t))) + +(defun gitconfig--execute-command (arguments) + (unless (gitconfig-current-inside-git-repository-p) + (user-error "Fatal: Not a git repository (or any of the parent directories): .git")) + (shell-command-to-string (format "%s config %s" gitconfig-git-command arguments))) + +(defun gitconfig-get-variables (location) + "Get all variables for the given LOCATION and return it as a hash table" + (let ((config-string (gitconfig--execute-command (format "--%s --list" location))) + (variable-hash (make-hash-table :test 'equal))) + (setq config-string (split-string config-string "\n")) + (delete "" config-string) + (mapcar (lambda (x) (puthash (car (split-string x "=")) + (car (last (split-string x "="))) + variable-hash)) config-string) + variable-hash)) + +(defun gitconfig-set-variable (location name value) + "Set a specific LOCATION variable with a given NAME and VALUE" + (unless (gitconfig-current-inside-git-repository-p) + (user-error "Fatal: Not a git repository (or any of the parent directories): .git")) + (let ((exit-status (shell-command + (format "%s config --%s --replace-all %s %s" + gitconfig-git-command location name value)))) + (unless (= exit-status 0) + (user-error (format "Error: key does not contain a section: %s" name))) + t)) + +(defun gitconfig-get-variable (location name) + "Return a specific LOCATION variable for the given NAME" + (when (string= name "") + (user-error "Error: variable does not exist.")) + (let ((variable (gitconfig--execute-command (format "--%s --get %s" location name)))) + (when (string-match "^error: " variable) + (user-error variable)) + (if (string-match "\n+" variable) + (replace-match "" t t variable) + variable))) + +(defun gitconfig-delete-variable (location name) + "Delete a specific LOCATION variable for the given NAME" + (unless (gitconfig-current-inside-git-repository-p) + (user-error "Fatal: Not a git repository (or any of the parent directories): .git")) + (let ((exit-status (shell-command + (format "%s config --%s --unset-all %s" + gitconfig-git-command location name)))) + (unless (= exit-status 0) + (user-error (format "Error: key does not contain a section: %s" name))) + t)) + +(defun gitconfig-execute-command (arguments) + "Run with custom ARGUMENTS and display it in buffer" + (interactive "Mgit config: ") + (let ((buffer (gitconfig--get-buffer gitconfig-buffer-name))) + (shell-command (format "%s config %s" gitconfig-git-command arguments) buffer) + (gitconfig--buffer-setup buffer))) + +(defun gitconfig-get-local-variables () + "Return all variables as hash table" + (gitconfig-get-variables "local")) + +(defun gitconfig-get-global-variables () + "Return all variables as hash table" + (gitconfig-get-variables "global")) + +(defun gitconfig-get-system-variables () + "Return all variables as hash table" + (gitconfig-get-variables "system")) + +(defun gitconfig-get-local-variable (name) + "Return a specific variable by the given NAME" + (gitconfig-get-variable "local" name)) + +(defun gitconfig-get-global-variable (name) + "Return a specific variable by the given NAME" + (gitconfig-get-variable "global" name)) + +(defun gitconfig-get-system-variable (name) + "Return a specific variable by the given NAME" + (gitconfig-get-variable "system" name)) + +(provide 'gitconfig) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; gitconfig.el ends here diff --git a/elpa/github-notifier-20160702.2112/github-notifier-autoloads.el b/elpa/github-notifier-20160702.2112/github-notifier-autoloads.el new file mode 100644 index 0000000..0e47caf --- /dev/null +++ b/elpa/github-notifier-20160702.2112/github-notifier-autoloads.el @@ -0,0 +1,36 @@ +;;; github-notifier-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil "github-notifier" "github-notifier.el" (22500 +;;;;;; 1786 648025 550000)) +;;; Generated autoloads from github-notifier.el + +(defalias 'github-notifier 'github-notifier-mode) + +(defvar github-notifier-mode nil "\ +Non-nil if Github-Notifier mode is enabled. +See the command `github-notifier-mode' 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 `github-notifier-mode'.") + +(custom-autoload 'github-notifier-mode "github-notifier" nil) + +(autoload 'github-notifier-mode "github-notifier" "\ +Toggle github notifications count display in mode line (Github Notifier mode). +With a prefix argument ARG, enable Github Notifier mode if ARG is +positive, and disable it otherwise. If called from Lisp, enable +the mode if ARG is omitted or nil. + +\(fn &optional ARG)" t nil) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; github-notifier-autoloads.el ends here diff --git a/elpa/github-notifier-20160702.2112/github-notifier-pkg.el b/elpa/github-notifier-20160702.2112/github-notifier-pkg.el new file mode 100644 index 0000000..74564b5 --- /dev/null +++ b/elpa/github-notifier-20160702.2112/github-notifier-pkg.el @@ -0,0 +1 @@ +(define-package "github-notifier" "20160702.2112" "Displays your GitHub notifications unread count in mode-line" '((emacs "24")) :url "https://github.com/xuchunyang/github-notifier.el" :keywords '("github" "mode-line")) diff --git a/elpa/github-notifier-20160702.2112/github-notifier.el b/elpa/github-notifier-20160702.2112/github-notifier.el new file mode 100644 index 0000000..0d7afcb --- /dev/null +++ b/elpa/github-notifier-20160702.2112/github-notifier.el @@ -0,0 +1,243 @@ +;;; github-notifier.el --- Displays your GitHub notifications unread count in mode-line -*- lexical-binding: t; -*- + +;; Copyright (C) 2015, 2016 Chunyang Xu + +;; Author: Chunyang Xu +;; URL: https://github.com/xuchunyang/github-notifier.el +;; Package-Version: 20160702.2112 +;; Package-Requires: ((emacs "24")) +;; Keywords: github, mode-line +;; Version: 0.1 + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This is a global minor-mode. Turn it on everywhere with: +;; +;; M-x github-notifier-mode + +;;; Code: + +(require 'url) +(require 'json) + +(defgroup github-notifier nil + "Github Notifier" + :group 'emacs) + +;;; Custom +(defcustom github-notifier-token nil + "Access token to get Github Notifications. + +To generate an access token, visit +URL `https://github.com/settings/tokens/new?scopes=notifications&description=github-notifier.el' + +This is similar to how erc or jabber handle authentication in +emacs, but the following disclaimer always worth reminding. + +DISCLAIMER +When you save this variable, DON'T WRITE IT ANYWHERE PUBLIC. This +token grants (very) limited access to your account. +END DISCLAIMER + +If nil, Github-Notifier will ask you and remember your token via +`customize-save-variable'." + :type '(choice (string :tag "Token") + (const :tag "Ask me" nil)) + :group 'github-notifier) + +(defcustom github-notifier-mode-line + '(:eval + (let (unread-text help-text) + (cond ((null github-notifier-unread-count) + (setq unread-text "-?" + help-text "The Github notifications number is unknown.")) + ((zerop github-notifier-unread-count) + (setq unread-text "" + help-text "Good job, you don't have unread notification.")) + (t + (setq unread-text (format "-%d%s" github-notifier-unread-count + (if (github-notifier-notifications-checked) "*" "")) + help-text (if (= github-notifier-unread-count 1) + "You have 1 unread notification.\nmouse-1 Read it on Github." + (format "You have %d unread notifications.\nmouse-1 Read them on Github." + github-notifier-unread-count))))) + (propertize (concat " GH" unread-text) + 'help-echo help-text + 'local-map github-notifier-mode-line-map + 'mouse-face 'mode-line-highlight))) + "Mode line lighter for Github Notifier." + :type 'sexp + :risky t + :group 'github-notifier) + +(defcustom github-notifier-update-interval 60 + "Seconds after which the github notifications count will be updated." + :type 'integer + :group 'github-notifier) + +(defcustom github-notifier-only-participating nil + "If non-nil, only counts notifications in which the user is directly participating or mentioned." + :type 'boolean + :group 'github-notifier) + +(defcustom github-notifier-enterprise-domain nil + "Domain to Github installation. +Can be overriden to support Enterprise installations" + :type 'string + :group 'github-notifier) + +;;; Variables +(defvar github-notifier-unread-count nil + "Github notifications unread count. +Normally, this is a number, however, nil means unknown by Emacs.") + +(defvar github-notifier-unread-json nil + "JSON object contains latest (to github-notifier) unread notifications.") + +(defvar github-notifier-update-hook nil + "Run by `github-notifier-update-cb'. +Functions added to this hook takes one argument, the unread +notification json object BEFORE updating. Accordingly, +`github-notifier-unread-json' stores the unread notification json +AFTER updating.") + +(defvar github-notifier-mode-line-map + (let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] 'github-notifier-visit-github) + map)) + +(defvar github-notifier-last-notification nil) +(defvar github-notifier-last-notification-checked nil) +(defvar github-notifier-update-timer nil) + +;;; Function +(defun github-notifier-get-url (path &optional api-request) + "Get URL to Github endpoint. +Get a url to PATH on Github or Github enterprise if +`github-enterprise-domain' is set. If API-REQUEST is true it +will return an API." + (let ((url + (if github-notifier-enterprise-domain + (concat github-notifier-enterprise-domain (when api-request "/api/v3")) + (concat (when api-request "api.") "github.com")))) + (concat "https://" url path))) + +;; FIXME: Even we use `url-retrieve' to retrieve network asynchronously, Emacs +;; still gets blocked frequently (?), especially when the network situation is +;; bad, once it blocks Emacs, you have to wait to it gets finised or interrupt +;; it by hitting C-g many times. This is very annoying. +;; +;; Maybe we can try to invoke curl(1) as asynchronous process. +(defun github-notifier-update-cb (_status) + (set-buffer-multibyte t) + (goto-char (point-min)) + (if (not (string-match "200 OK" (buffer-string))) + (progn (message "[github-notifier] Problem connecting to the server") + (setq github-notifier-unread-count nil)) + (re-search-forward "^$" nil 'move) + (let (json-str + (old-count github-notifier-unread-count) + (old-json github-notifier-unread-json)) + (setq json-str (buffer-substring-no-properties (point) (point-max)) + github-notifier-unread-json (json-read-from-string json-str)) + (setq github-notifier-unread-count (length github-notifier-unread-json)) + (when (> github-notifier-unread-count 0) + (setq github-notifier-last-notification (cdr (assoc 'updated_at (elt github-notifier-unread-json 0))))) + (unless (and (equal old-count github-notifier-unread-count) + (github-notifier-notifications-checked)) + (force-mode-line-update t)) + (run-hook-with-args 'github-notifier-update-hook old-json) + ;; Debug + ;; (setq a-json-string json-str) + ;; (message "Github notification %d unread, updated at %s" + ;; github-notifier-unread-count (current-time-string)) + )) + ;; Debug + ;; (display-buffer (current-buffer)) + (kill-buffer) + (when github-notifier-mode + (setq github-notifier-update-timer + (run-at-time github-notifier-update-interval nil #'github-notifier-update)))) + +(defun github-notifier-update (&optional force) + "Update `github-notifier-unread-count'." + (when (or force github-notifier-mode) + (let ((url-request-extra-headers `(("Authorization" . + ,(format "token %s" github-notifier-token)))) + (url (github-notifier-get-url (concat "/notifications" + (when github-notifier-only-participating + "?participating=true")) t))) + (condition-case error-data + (url-retrieve url #'github-notifier-update-cb nil t t) + (error + (message "Error retrieving github notification from %s: %s" url error-data) + (when github-notifier-mode + (setq github-notifier-update-timer + (run-at-time github-notifier-update-interval nil #'github-notifier-update)))))))) + +(defun github-notifier-visit-github () + (interactive) + (browse-url (github-notifier-get-url "/notifications")) + (setq github-notifier-last-notification-checked (format-time-string "%FT%TZ" (current-time) t)) + (force-mode-line-update t)) + +(defun github-notifier-notifications-checked () + (and github-notifier-unread-count (> github-notifier-unread-count 0) + github-notifier-last-notification github-notifier-last-notification-checked + (string< github-notifier-last-notification github-notifier-last-notification-checked))) + +;;; Glboal Minor-mode + +;;;###autoload +(defalias 'github-notifier 'github-notifier-mode) + +;;;###autoload +(define-minor-mode github-notifier-mode + "Toggle github notifications count display in mode line (Github Notifier mode). +With a prefix argument ARG, enable Github Notifier mode if ARG is +positive, and disable it otherwise. If called from Lisp, enable +the mode if ARG is omitted or nil." + :global t :group 'github-notifier + (unless github-notifier-token + (setq github-notifier-token + (with-temp-buffer + (when (or + (= 0 (call-process "git" nil t nil "config" "github-notifier.oauth-token")) + (= 0 (call-process "git" nil t nil "config" "github.oauth-token"))) + (buffer-substring 1 (progn (goto-char 1) (line-end-position))))))) + (unless (stringp github-notifier-token) + (browse-url (github-notifier-get-url "/settings/tokens/new?scopes=notifications&description=github-notifier.el")) + (let (token) + (unwind-protect + (setq token (read-string "Paste Your Access Token: ")) + (if (stringp token) + (customize-save-variable 'github-notifier-token token) + (message "No Access Token") + (setq github-notifier-mode nil))))) + (unless global-mode-string + (setq global-mode-string '(""))) + (if (not github-notifier-mode) + (progn + (setq global-mode-string + (delq 'github-notifier-mode-line global-mode-string)) + (when github-notifier-update-timer + (cancel-timer github-notifier-update-timer) + (setq github-notifier-update-timer nil))) + (add-to-list 'global-mode-string 'github-notifier-mode-line t) + (github-notifier-update))) + +(provide 'github-notifier) +;;; github-notifier.el ends here diff --git a/elpa/queue-0.1.1.signed b/elpa/queue-0.1.1.signed new file mode 100644 index 0000000..3b01a70 --- /dev/null +++ b/elpa/queue-0.1.1.signed @@ -0,0 +1 @@ +Good signature from 474F05837FBDEF9B GNU ELPA Signing Agent (trust undefined) created at 2014-09-24T16:20:08+0200 using DSA \ No newline at end of file diff --git a/elpa/queue-0.1.1/queue-autoloads.el b/elpa/queue-0.1.1/queue-autoloads.el new file mode 100644 index 0000000..299c2da --- /dev/null +++ b/elpa/queue-0.1.1/queue-autoloads.el @@ -0,0 +1,19 @@ +;;; queue-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil "queue" "queue.el" (22500 1794 888069 675000)) +;;; Generated autoloads from queue.el + +(defalias 'make-queue 'queue-create "\ +Create an empty queue data structure.") + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; queue-autoloads.el ends here diff --git a/elpa/queue-0.1.1/queue-pkg.el b/elpa/queue-0.1.1/queue-pkg.el new file mode 100644 index 0000000..adeecde --- /dev/null +++ b/elpa/queue-0.1.1/queue-pkg.el @@ -0,0 +1 @@ +(define-package "queue" "0.1.1" "Queue data structure" 'nil :url "http://www.dr-qubit.org/emacs.php" :keywords '("extensions" "data structures" "queue")) diff --git a/elpa/queue-0.1.1/queue.el b/elpa/queue-0.1.1/queue.el new file mode 100644 index 0000000..aab8c1d --- /dev/null +++ b/elpa/queue-0.1.1/queue.el @@ -0,0 +1,173 @@ +;;; queue.el --- Queue data structure -*- lexical-binding: t; -*- + +;; Copyright (C) 1991-1995, 2008-2009, 2012 Free Software Foundation, Inc + +;; Author: Inge Wallin +;; Toby Cubitt +;; Maintainer: Toby Cubitt +;; Version: 0.1.1 +;; Keywords: extensions, data structures, queue +;; URL: http://www.dr-qubit.org/emacs.php +;; Repository: http://www.dr-qubit.org/git/predictive.git + +;; This file is part of Emacs. +;; +;; GNU Emacs 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. +;; +;; GNU Emacs 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 GNU Emacs. If not, see . + + +;;; Commentary: +;; +;; These queues can be used both as a first-in last-out (FILO) and as a +;; first-in first-out (FIFO) stack, i.e. elements can be added to the front or +;; back of the queue, and can be removed from the front. (This type of data +;; structure is sometimes called an "output-restricted deque".) +;; +;; You create a queue using `make-queue', add an element to the end of the +;; queue using `queue-enqueue', and push an element onto the front of the +;; queue using `queue-prepend'. To remove the first element from a queue, use +;; `queue-dequeue'. A number of other queue convenience functions are also +;; provided, all starting with the prefix `queue-'. Functions with prefix +;; `queue--' are for internal use only, and should never be used outside this +;; package. + + +;;; Code: + +(eval-when-compile (require 'cl)) + + +(defstruct (queue + ;; A tagged list is the pre-defstruct representation. + ;; (:type list) + :named + (:constructor nil) + (:constructor queue-create ()) + (:copier nil)) + head tail) + + +;;;###autoload +(defalias 'make-queue 'queue-create + "Create an empty queue data structure.") + + +(defun queue-enqueue (queue element) + "Append an ELEMENT to the end of the QUEUE." + (if (queue-head queue) + (setcdr (queue-tail queue) + (setf (queue-tail queue) (cons element nil))) + (setf (queue-head queue) + (setf (queue-tail queue) (cons element nil))))) + +(defalias 'queue-append 'queue-enqueue) + + +(defun queue-prepend (queue element) + "Prepend an ELEMENT to the front of the QUEUE." + (if (queue-head queue) + (push element (queue-head queue)) + (setf (queue-head queue) + (setf (queue-tail queue) (cons element nil))))) + + +(defun queue-dequeue (queue) + "Remove the first element of QUEUE and return it. +Returns nil if the queue is empty." + (unless (cdr (queue-head queue)) (setf (queue-tail queue) nil)) + (pop (queue-head queue))) + + +(defun queue-empty (queue) + "Return t if QUEUE is empty, otherwise return nil." + (null (queue-head queue))) + + +(defun queue-first (queue) + "Return the first element of QUEUE or nil if it is empty, +without removing it from the QUEUE." + (car (queue-head queue))) + + +(defun queue-nth (queue n) + "Return the nth element of a queue, without removing it. +If the length of the queue is less than N, return nil. The first +element in the queue has index 0." + (nth n (queue-head queue))) + + +(defun queue-last (queue) + "Return the last element of QUEUE, without removing it. +Returns nil if the QUEUE is empty." + (car (queue-tail queue))) + + +(defun queue-all (queue) + "Return a list of all elements of QUEUE or nil if it is empty. +The oldest element in the queue is the first in the list." + (queue-head queue)) + + +(defun queue-copy (queue) + "Return a copy of QUEUE. +The new queue contains the elements of QUEUE in the same +order. The elements themselves are *not* copied." + (let ((q (queue-create)) + (list (queue-head queue))) + (when (queue-head queue) + (setf (queue-head q) (cons (car (queue-head queue)) nil) + (queue-tail q) (queue-head q)) + (while (setq list (cdr list)) + (setf (queue-tail q) + (setcdr (queue-tail q) (cons (car list) nil))))) + q)) + + +(defun queue-length (queue) + "Return the number of elements in QUEUE." + (length (queue-head queue))) + + +(defun queue-clear (queue) + "Remove all elements from QUEUE." + (setf (queue-head queue) nil + (queue-tail queue) nil)) + +;;;; ChangeLog: + +;; 2014-05-15 Toby S. Cubitt +;; +;; queue.el: fix buggy queue-first and queue-empty definitions. +;; +;; 2012-04-30 Toby S. Cubitt +;; +;; Minor fixes to commentaries, package headers, and whitespace +;; +;; * queue.el: fix description of data structure in Commentary; add +;; Maintainer +;; header. +;; +;; * queue.el, heap.el, tNFA.el, trie.el, dict-tree.el: trivial whitespace +;; fixes. +;; +;; 2012-04-29 Toby S. Cubitt +;; +;; Add queue.el +;; + + + +(provide 'queue) + + +;;; queue.el ends here diff --git a/elpa/spinner-1.7.1.signed b/elpa/spinner-1.7.1.signed new file mode 100644 index 0000000..d3a3faf --- /dev/null +++ b/elpa/spinner-1.7.1.signed @@ -0,0 +1 @@ +Good signature from 474F05837FBDEF9B GNU ELPA Signing Agent (trust undefined) created at 2016-04-02T11:05:01+0200 using DSA \ No newline at end of file diff --git a/elpa/spinner-1.7.1/spinner-autoloads.el b/elpa/spinner-1.7.1/spinner-autoloads.el new file mode 100644 index 0000000..9fcb0f7 --- /dev/null +++ b/elpa/spinner-1.7.1/spinner-autoloads.el @@ -0,0 +1,67 @@ +;;; spinner-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil "spinner" "spinner.el" (22500 1793 528062 392000)) +;;; Generated autoloads from spinner.el + +(autoload 'spinner-create "spinner" "\ +Create a spinner of the given TYPE. +The possible TYPEs are described in `spinner--type-to-frames'. + +FPS, if given, is the number of desired frames per second. +Default is `spinner-frames-per-second'. + +If BUFFER-LOCAL is non-nil, the spinner will be automatically +deactivated if the buffer is killed. If BUFFER-LOCAL is a +buffer, use that instead of current buffer. + +When started, in order to function properly, the spinner runs a +timer which periodically calls `force-mode-line-update' in the +curent buffer. If BUFFER-LOCAL was set at creation time, then +`force-mode-line-update' is called in that buffer instead. When +the spinner is stopped, the timer is deactivated. + +DELAY, if given, is the number of seconds to wait after starting +the spinner before actually displaying it. It is safe to cancel +the spinner before this time, in which case it won't display at +all. + +\(fn &optional TYPE BUFFER-LOCAL FPS DELAY)" nil nil) + +(autoload 'spinner-start "spinner" "\ +Start a mode-line spinner of given TYPE-OR-OBJECT. +If TYPE-OR-OBJECT is an object created with `make-spinner', +simply activate it. This method is designed for minor modes, so +they can use the spinner as part of their lighter by doing: + '(:eval (spinner-print THE-SPINNER)) +To stop this spinner, call `spinner-stop' on it. + +If TYPE-OR-OBJECT is anything else, a buffer-local spinner is +created with this type, and it is displayed in the +`mode-line-process' of the buffer it was created it. Both +TYPE-OR-OBJECT and FPS are passed to `make-spinner' (which see). +To stop this spinner, call `spinner-stop' in the same buffer. + +Either way, the return value is a function which can be called +anywhere to stop this spinner. You can also call `spinner-stop' +in the same buffer where the spinner was created. + +FPS, if given, is the number of desired frames per second. +Default is `spinner-frames-per-second'. + +DELAY, if given, is the number of seconds to wait until actually +displaying the spinner. It is safe to cancel the spinner before +this time, in which case it won't display at all. + +\(fn &optional TYPE-OR-OBJECT FPS DELAY)" nil nil) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; spinner-autoloads.el ends here diff --git a/elpa/spinner-1.7.1/spinner-pkg.el b/elpa/spinner-1.7.1/spinner-pkg.el new file mode 100644 index 0000000..1c216ea --- /dev/null +++ b/elpa/spinner-1.7.1/spinner-pkg.el @@ -0,0 +1 @@ +(define-package "spinner" "1.7.1" "Add spinners and progress-bars to the mode-line for ongoing operations" 'nil :url "https://github.com/Malabarba/spinner.el" :keywords '("processes" "mode-line")) diff --git a/elpa/spinner-1.7.1/spinner.el b/elpa/spinner-1.7.1/spinner.el new file mode 100644 index 0000000..41c959c --- /dev/null +++ b/elpa/spinner-1.7.1/spinner.el @@ -0,0 +1,394 @@ +;;; spinner.el --- Add spinners and progress-bars to the mode-line for ongoing operations -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Artur Malabarba +;; Version: 1.7.1 +;; URL: https://github.com/Malabarba/spinner.el +;; Keywords: processes mode-line + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: +;; +;; 1 Usage +;; ═══════ +;; +;; First of all, don’t forget to add `(spinner "VERSION")' to your +;; package’s dependencies. +;; +;; +;; 1.1 Major-modes +;; ─────────────── +;; +;; 1. Just call `(spinner-start)' and a spinner will be added to the +;; mode-line. +;; 2. Call `(spinner-stop)' on the same buffer when you want to remove +;; it. +;; +;; The default spinner is a line drawing that rotates. You can pass an +;; argument to `spinner-start' to specify which spinner you want. All +;; possibilities are listed in the `spinner-types' variable, but here are +;; a few examples for you to try: +;; +;; • `(spinner-start 'vertical-breathing 10)' +;; • `(spinner-start 'minibox)' +;; • `(spinner-start 'moon)' +;; • `(spinner-start 'triangle)' +;; +;; You can also define your own as a vector of strings (see the examples +;; in `spinner-types'). +;; +;; +;; 1.2 Minor-modes +;; ─────────────── +;; +;; Minor-modes can create a spinner with `spinner-create' and then add it +;; to their mode-line lighter. They can then start the spinner by setting +;; a variable and calling `spinner-start-timer'. Finally, they can stop +;; the spinner (and the timer) by just setting the same variable to nil. +;; +;; Here’s an example for a minor-mode named `foo'. Assuming that +;; `foo--lighter' is used as the mode-line lighter, the following code +;; will add an *inactive* global spinner to the mode-line. +;; ┌──── +;; │ (defvar foo--spinner (spinner-create 'rotating-line)) +;; │ (defconst foo--lighter +;; │ '(" foo" (:eval (spinner-print foo--spinner)))) +;; └──── +;; +;; 1. To activate the spinner, just call `(spinner-start foo--spinner)'. +;; It will show up on the mode-line and start animating. +;; 2. To get rid of it, call `(spinner-stop foo--spinner)'. It will then +;; disappear again. +;; +;; Some minor-modes will need spinners to be buffer-local. To achieve +;; that, just make the `foo--spinner' variable buffer-local and use the +;; third argument of the `spinner-create' function. The snippet below is an +;; example. +;; +;; ┌──── +;; │ (defvar-local foo--spinner nil) +;; │ (defconst foo--lighter +;; │ '(" foo" (:eval (spinner-print foo--spinner)))) +;; │ (defun foo--start-spinner () +;; │ "Create and start a spinner on this buffer." +;; │ (unless foo--spinner +;; │ (setq foo--spinner (spinner-create 'moon t))) +;; │ (spinner-start foo--spinner)) +;; └──── +;; +;; 1. To activate the spinner, just call `(foo--start-spinner)'. +;; 2. To get rid of it, call `(spinner-stop foo--spinner)'. +;; +;; This will use the `moon' spinner, but you can use any of the names +;; defined in the `spinner-types' variable or even define your own. + + +;;; Code: +(eval-when-compile + (require 'cl)) + +(defconst spinner-types + '((3-line-clock . ["┤" "┘" "┴" "└" "├" "┌" "┬" "┐"]) + (2-line-clock . ["┘" "└" "┌" "┐"]) + (flipping-line . ["_" "\\" "|" "/"]) + (rotating-line . ["-" "\\" "|" "/"]) + (progress-bar . ["[ ]" "[= ]" "[== ]" "[=== ]" "[====]" "[ ===]" "[ ==]" "[ =]"]) + (progress-bar-filled . ["| |" "|█ |" "|██ |" "|███ |" "|████|" "| ███|" "| ██|" "| █|"]) + (vertical-breathing . ["▁" "▂" "▃" "▄" "▅" "▆" "▇" "█" "▇" "▆" "▅" "▄" "▃" "▂" "▁" " "]) + (vertical-rising . ["▁" "▄" "█" "▀" "▔"]) + (horizontal-breathing . [" " "▏" "▎" "▍" "▌" "▋" "▊" "▉" "▉" "▊" "▋" "▌" "▍" "▎" "▏"]) + (horizontal-breathing-long + . [" " "▎ " "▌ " "▊ " "█ " "█▎" "█▌" "█▊" "██" "█▊" "█▌" "█▎" "█ " "▊ " "▋ " "▌ " "▍ " "▎ " "▏ "]) + (horizontal-moving . [" " "▌ " "█ " "▐▌" " █" " ▐"]) + (minibox . ["▖" "▘" "▝" "▗"]) + (triangle . ["◢" "◣" "◤" "◥"]) + (box-in-box . ["◰" "◳" "◲" "◱"]) + (box-in-circle . ["◴" "◷" "◶" "◵"]) + (half-circle . ["◐" "◓" "◑" "◒"]) + (moon . ["🌑" "🌘" "🌖" "🌕" "🌔" "🌒"])) + "Predefined alist of spinners. +Each car is a symbol identifying the spinner, and each cdr is a +vector, the spinner itself.") + +(defun spinner-make-progress-bar (width &optional char) + "Return a vector of strings of the given WIDTH. +The vector is a valid spinner type and is similar to the +`progress-bar' spinner, except without the sorrounding brackets. +CHAR is the character to use for the moving bar (defaults to =)." + (let ((whole-string (concat (make-string (1- width) ?\s) + (make-string 4 (or char ?=)) + (make-string width ?\s)))) + (apply #'vector (mapcar (lambda (n) (substring whole-string n (+ n width))) + (number-sequence (+ width 3) 0 -1))))) + +(defvar spinner-current nil + "Spinner curently being displayed on the `mode-line-process'.") +(make-variable-buffer-local 'spinner-current) + +(defconst spinner--mode-line-construct + '(:eval (spinner-print spinner-current)) + "Construct used to display a spinner in `mode-line-process'.") +(put 'spinner--mode-line-construct 'risky-local-variable t) + +(defvar spinner-frames-per-second 10 + "Default speed at which spinners spin, in frames per second. +Each spinner can override this value.") + + +;;; The spinner object. +(defun spinner--type-to-frames (type) + "Return a vector of frames corresponding to TYPE. +The list of possible built-in spinner types is given by the +`spinner-types' variable, but you can also use your own (see +below). + +If TYPE is nil, the frames of this spinner are given by the first +element of `spinner-types'. +If TYPE is a symbol, it specifies an element of `spinner-types'. +If TYPE is 'random, use a random element of `spinner-types'. +If TYPE is a list, it should be a list of symbols, and a random +one is chosen as the spinner type. +If TYPE is a vector, it should be a vector of strings and these +are used as the spinner's frames. This allows you to make your +own spinner animations." + (cond + ((vectorp type) type) + ((not type) (cdr (car spinner-types))) + ((eq type 'random) + (cdr (elt spinner-types + (random (length spinner-types))))) + ((listp type) + (cdr (assq (elt type (random (length type))) + spinner-types))) + ((symbolp type) (cdr (assq type spinner-types))) + (t (error "Unknown spinner type: %s" type)))) + +(defstruct (spinner + (:copier nil) + (:conc-name spinner--) + (:constructor make-spinner (&optional type buffer-local frames-per-second delay-before-start))) + (frames (spinner--type-to-frames type)) + (counter 0) + (fps (or frames-per-second spinner-frames-per-second)) + (timer (timer-create) :read-only) + (active-p nil) + (buffer (when buffer-local + (if (bufferp buffer-local) + buffer-local + (current-buffer)))) + (delay (or delay-before-start 0))) + +;;;###autoload +(defun spinner-create (&optional type buffer-local fps delay) + "Create a spinner of the given TYPE. +The possible TYPEs are described in `spinner--type-to-frames'. + +FPS, if given, is the number of desired frames per second. +Default is `spinner-frames-per-second'. + +If BUFFER-LOCAL is non-nil, the spinner will be automatically +deactivated if the buffer is killed. If BUFFER-LOCAL is a +buffer, use that instead of current buffer. + +When started, in order to function properly, the spinner runs a +timer which periodically calls `force-mode-line-update' in the +curent buffer. If BUFFER-LOCAL was set at creation time, then +`force-mode-line-update' is called in that buffer instead. When +the spinner is stopped, the timer is deactivated. + +DELAY, if given, is the number of seconds to wait after starting +the spinner before actually displaying it. It is safe to cancel +the spinner before this time, in which case it won't display at +all." + (make-spinner type buffer-local fps delay)) + +(defun spinner-print (spinner) + "Return a string of the current frame of SPINNER. +If SPINNER is nil, just return nil. +Designed to be used in the mode-line with: + (:eval (spinner-print some-spinner))" + (when (and spinner (spinner--active-p spinner)) + (let ((frame (spinner--counter spinner))) + (when (>= frame 0) + (elt (spinner--frames spinner) frame))))) + +(defun spinner--timer-function (spinner) + "Function called to update SPINNER. +If SPINNER is no longer active, or if its buffer has been killed, +stop the SPINNER's timer." + (let ((buffer (spinner--buffer spinner))) + (if (or (not (spinner--active-p spinner)) + (and buffer (not (buffer-live-p buffer)))) + (spinner-stop spinner) + ;; Increment + (callf (lambda (x) (if (< x 0) + (1+ x) + (% (1+ x) (length (spinner--frames spinner))))) + (spinner--counter spinner)) + ;; Update mode-line. + (if (buffer-live-p buffer) + (with-current-buffer buffer + (force-mode-line-update)) + (force-mode-line-update))))) + +(defun spinner--start-timer (spinner) + "Start a SPINNER's timer." + (let ((old-timer (spinner--timer spinner))) + (when (timerp old-timer) + (cancel-timer old-timer)) + + (setf (spinner--active-p spinner) t) + + (unless (ignore-errors (> (spinner--fps spinner) 0)) + (error "A spinner's FPS must be a positive number")) + (setf (spinner--counter spinner) (round (- (* (or (spinner--delay spinner) 0) + (spinner--fps spinner))))) + ;; Create timer. + (let* ((repeat (/ 1.0 (spinner--fps spinner))) + (time (timer-next-integral-multiple-of-time (current-time) repeat)) + ;; Create the timer as a lex variable so it can cancel itself. + (timer (spinner--timer spinner))) + (timer-set-time timer time repeat) + (timer-set-function timer #'spinner--timer-function (list spinner)) + (timer-activate timer) + ;; Return a stopping function. + (lambda () (spinner-stop spinner))))) + + +;;; The main functions +;;;###autoload +(defun spinner-start (&optional type-or-object fps delay) + "Start a mode-line spinner of given TYPE-OR-OBJECT. +If TYPE-OR-OBJECT is an object created with `make-spinner', +simply activate it. This method is designed for minor modes, so +they can use the spinner as part of their lighter by doing: + '(:eval (spinner-print THE-SPINNER)) +To stop this spinner, call `spinner-stop' on it. + +If TYPE-OR-OBJECT is anything else, a buffer-local spinner is +created with this type, and it is displayed in the +`mode-line-process' of the buffer it was created it. Both +TYPE-OR-OBJECT and FPS are passed to `make-spinner' (which see). +To stop this spinner, call `spinner-stop' in the same buffer. + +Either way, the return value is a function which can be called +anywhere to stop this spinner. You can also call `spinner-stop' +in the same buffer where the spinner was created. + +FPS, if given, is the number of desired frames per second. +Default is `spinner-frames-per-second'. + +DELAY, if given, is the number of seconds to wait until actually +displaying the spinner. It is safe to cancel the spinner before +this time, in which case it won't display at all." + (unless (spinner-p type-or-object) + ;; Choose type. + (if (spinner-p spinner-current) + (setf (spinner--frames spinner-current) (spinner--type-to-frames type-or-object)) + (setq spinner-current (make-spinner type-or-object (current-buffer) fps delay))) + (setq type-or-object spinner-current) + ;; Maybe add to mode-line. + (unless (memq 'spinner--mode-line-construct mode-line-process) + (setq mode-line-process + (list (or mode-line-process "") + 'spinner--mode-line-construct)))) + + ;; Create timer. + (when fps (setf (spinner--fps type-or-object) fps)) + (when delay (setf (spinner--delay type-or-object) delay)) + (spinner--start-timer type-or-object)) + +(defun spinner-start-print (spinner) + "Like `spinner-print', but also start SPINNER if it's not active." + (unless (spinner--active-p spinner) + (spinner-start spinner)) + (spinner-print spinner)) + +(defun spinner-stop (&optional spinner) + "Stop SPINNER, defaulting to the current buffer's spinner. +It is always safe to call this function, even if there is no +active spinner." + (let ((spinner (or spinner spinner-current))) + (when (spinner-p spinner) + (let ((timer (spinner--timer spinner))) + (when (timerp timer) + (cancel-timer timer))) + (setf (spinner--active-p spinner) nil) + (force-mode-line-update)))) + +;;;; ChangeLog: + +;; 2016-04-01 Artur Malabarba +;; +;; Remove reference to thread-last +;; +;; 2016-02-08 Artur Malabarba +;; +;; Spinner version 1.7 +;; +;; Offer a spinner-make-progress-bar function. Make spinner-stop never +;; signal. Allow floating-point delays. +;; +;; 2016-02-07 Artur Malabarba +;; +;; Update the mode-line after spinner-stop +;; +;; 2015-08-11 Artur Malabarba +;; +;; Merge commit '8d8c459d7757cf5774f11be9147d7a54f5f9bbd7' +;; +;; 2015-05-02 Artur Malabarba +;; +;; * spinner: Rename constructor. +;; +;; 2015-04-30 Artur Malabarba +;; +;; * spinner/spinner.el: Rewrite spinners as structures +;; +;; 2015-04-09 Artur Malabarba +;; +;; spinner: Fix readme +;; +;; 2015-04-09 Artur Malabarba +;; +;; spinner: Fix leftover mode-line-format code +;; +;; 2015-04-09 Artur Malabarba +;; +;; Merge commit 'c44ef65515f50bd38304a6f50adebc984fb8e431' +;; +;; 2015-03-07 Artur Malabarba +;; +;; Merge commit '7eca7d023c95bc21c7838467b3a58d549afaf68d' +;; +;; 2015-03-07 Artur Malabarba +;; +;; Merge commit 'a7b4e52766977b58c6b9899305e962a2b5235bda' +;; +;; 2015-03-07 Artur Malabarba +;; +;; Add 'packages/spinner/' from commit +;; '9477ee899d62259d4b946f243cdcdd9cdeb1e910' +;; +;; git-subtree-dir: packages/spinner git-subtree-mainline: +;; 5736e852fd48a0f1ba1c328dd4d03e3fa008a406 git-subtree-split: +;; 9477ee899d62259d4b946f243cdcdd9cdeb1e910 +;; + + +(provide 'spinner) + +;;; spinner.el ends here