From 5c5cba014381af00708aa1553fc5b127d3c6fc1f Mon Sep 17 00:00:00 2001 From: Andreas Gerler Date: Fri, 12 Jan 2018 15:53:21 +0100 Subject: [PATCH] A lot of updates. cleaning up my configuration directory. Signed-off-by: Andreas Gerler --- .../apples-mode-autoloads.el | 31 + .../apples-mode-pkg.el | 5 + elpa/apples-mode-20110120.2018/apples-mode.el | 1397 +++++++ .../apples-mode/comment | 6 + .../apples-mode/considering | 6 + .../considering-application-responses | 6 + .../apples-mode/display-dialog | 4 + elpa/apples-mode-20110120.2018/apples-mode/if | 8 + .../apples-mode/ignoring | 6 + .../ignoring-application-responses | 6 + elpa/apples-mode-20110120.2018/apples-mode/on | 6 + .../apples-mode/repeat | 6 + .../apples-mode/repeat-until | 6 + .../apples-mode/repeat-while | 6 + .../apples-mode/repeat-with | 6 + .../apples-mode/tell-application | 6 + .../apples-mode/tell-application-to-activate | 5 + .../apples-mode-20110120.2018/apples-mode/try | 8 + .../apples-mode/using-terms-from-application | 6 + .../apples-mode/with-timeout-of-seconds | 6 + .../apples-mode/with-transaction | 6 + .../apples-tmp--1713.applescript | 0 .../apples-tmp-scratch.applescript | 0 .../apples-tmp-send.applescript | 0 elpa/apples-mode-readme.txt | 29 + .../async-autoloads.el | 12 +- .../async-bytecomp.el | 0 .../async-pkg.el | 2 +- .../async.el | 34 +- .../dired-async.el | 51 +- .../smtpmail-async.el | 2 +- elpa/cider-20170129.1941/cider-apropos.el | 203 + elpa/cider-20170129.1941/cider-autoloads.el | 326 ++ elpa/cider-20170129.1941/cider-browse-ns.el | 221 + elpa/cider-20170129.1941/cider-classpath.el | 114 + elpa/cider-20170129.1941/cider-client.el | 1126 ++++++ elpa/cider-20170129.1941/cider-common.el | 265 ++ elpa/cider-20170129.1941/cider-compat.el | 157 + elpa/cider-20170129.1941/cider-debug.el | 753 ++++ elpa/cider-20170129.1941/cider-doc.el | 524 +++ elpa/cider-20170129.1941/cider-eldoc.el | 440 ++ elpa/cider-20170129.1941/cider-grimoire.el | 119 + elpa/cider-20170129.1941/cider-inspector.el | 391 ++ elpa/cider-20170129.1941/cider-interaction.el | 1828 +++++++++ .../cider-macroexpansion.el | 208 + elpa/cider-20170129.1941/cider-mode.el | 859 ++++ elpa/cider-20170129.1941/cider-overlays.el | 312 ++ elpa/cider-20170129.1941/cider-pkg.el | 12 + elpa/cider-20170129.1941/cider-popup.el | 130 + .../cider-20170129.1941/cider-repl-history.el | 729 ++++ elpa/cider-20170129.1941/cider-repl.el | 1402 +++++++ elpa/cider-20170129.1941/cider-resolve.el | 129 + elpa/cider-20170129.1941/cider-scratch.el | 96 + elpa/cider-20170129.1941/cider-selector.el | 167 + elpa/cider-20170129.1941/cider-stacktrace.el | 718 ++++ elpa/cider-20170129.1941/cider-test.el | 729 ++++ elpa/cider-20170129.1941/cider-util.el | 677 ++++ elpa/cider-20170129.1941/cider.el | 885 ++++ elpa/cider-20170129.1941/nrepl-client.el | 1306 ++++++ elpa/cider-20170129.1941/nrepl-dict.el | 187 + elpa/circe-20161102.1405/circe-autoloads.el | 223 + elpa/circe-20161102.1405/circe-chanop.el | 97 + elpa/circe-20161102.1405/circe-color-nicks.el | 345 ++ elpa/circe-20161102.1405/circe-compat.el | 53 + .../circe-highlight-all-nicks.el | 100 + elpa/circe-20161102.1405/circe-lagmon.el | 243 ++ .../circe-new-day-notifier.el | 86 + elpa/circe-20161102.1405/circe-pkg.el | 6 + elpa/circe-20161102.1405/circe.el | 3590 +++++++++++++++++ elpa/circe-20161102.1405/irc.el | 1406 +++++++ elpa/circe-20161102.1405/lcs.el | 202 + elpa/circe-20161102.1405/lui-autopaste.el | 115 + elpa/circe-20161102.1405/lui-format.el | 198 + elpa/circe-20161102.1405/lui-irc-colors.el | 182 + elpa/circe-20161102.1405/lui-logging.el | 201 + elpa/circe-20161102.1405/lui-track-bar.el | 110 + elpa/circe-20161102.1405/lui.el | 1343 ++++++ elpa/circe-20161102.1405/make-tls-process.el | 194 + elpa/circe-20161102.1405/shorten.el | 223 + elpa/circe-20161102.1405/tracking.el | 391 ++ .../command-log-mode-autoloads.el | 27 + .../command-log-mode-pkg.el | 2 + .../command-log-mode.el | 323 ++ elpa/command-log-mode-readme.txt | 15 + elpa/dash-20161116.920/dash-pkg.el | 2 - .../dash-autoloads.el | 2 +- elpa/dash-20170810.137/dash-pkg.el | 2 + .../dash.el | 124 +- .../gnuplot-autoloads.el | 95 + elpa/gnuplot-20141231.1337/gnuplot-context.el | 2225 ++++++++++ elpa/gnuplot-20141231.1337/gnuplot-gui.el | 1748 ++++++++ elpa/gnuplot-20141231.1337/gnuplot-pkg.el | 5 + elpa/gnuplot-20141231.1337/gnuplot.el | 3352 +++++++++++++++ elpa/gnuplot-readme.txt | 122 + .../hcl-mode-autoloads.el | 23 + elpa/hcl-mode-20160502.1700/hcl-mode-pkg.el | 1 + elpa/hcl-mode-20160502.1700/hcl-mode.el | 217 + 97 files changed, 34218 insertions(+), 60 deletions(-) create mode 100644 elpa/apples-mode-20110120.2018/apples-mode-autoloads.el create mode 100644 elpa/apples-mode-20110120.2018/apples-mode-pkg.el create mode 100644 elpa/apples-mode-20110120.2018/apples-mode.el create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/comment create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/considering create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/considering-application-responses create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/display-dialog create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/if create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/ignoring create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/ignoring-application-responses create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/on create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/repeat create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/repeat-until create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/repeat-while create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/repeat-with create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/tell-application create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/tell-application-to-activate create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/try create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/using-terms-from-application create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/with-timeout-of-seconds create mode 100644 elpa/apples-mode-20110120.2018/apples-mode/with-transaction create mode 100644 elpa/apples-mode-20110120.2018/apples-tmp-dir/apples-tmp--1713.applescript create mode 100644 elpa/apples-mode-20110120.2018/apples-tmp-dir/apples-tmp-scratch.applescript create mode 100644 elpa/apples-mode-20110120.2018/apples-tmp-dir/apples-tmp-send.applescript create mode 100644 elpa/apples-mode-readme.txt rename elpa/{async-20161103.1036 => async-20170916.2256}/async-autoloads.el (94%) rename elpa/{async-20161103.1036 => async-20170916.2256}/async-bytecomp.el (100%) rename elpa/{async-20161103.1036 => async-20170916.2256}/async-pkg.el (68%) rename elpa/{async-20161103.1036 => async-20170916.2256}/async.el (93%) rename elpa/{async-20161103.1036 => async-20170916.2256}/dired-async.el (88%) rename elpa/{async-20161103.1036 => async-20170916.2256}/smtpmail-async.el (98%) create mode 100644 elpa/cider-20170129.1941/cider-apropos.el create mode 100644 elpa/cider-20170129.1941/cider-autoloads.el create mode 100644 elpa/cider-20170129.1941/cider-browse-ns.el create mode 100644 elpa/cider-20170129.1941/cider-classpath.el create mode 100644 elpa/cider-20170129.1941/cider-client.el create mode 100644 elpa/cider-20170129.1941/cider-common.el create mode 100644 elpa/cider-20170129.1941/cider-compat.el create mode 100644 elpa/cider-20170129.1941/cider-debug.el create mode 100644 elpa/cider-20170129.1941/cider-doc.el create mode 100644 elpa/cider-20170129.1941/cider-eldoc.el create mode 100644 elpa/cider-20170129.1941/cider-grimoire.el create mode 100644 elpa/cider-20170129.1941/cider-inspector.el create mode 100644 elpa/cider-20170129.1941/cider-interaction.el create mode 100644 elpa/cider-20170129.1941/cider-macroexpansion.el create mode 100644 elpa/cider-20170129.1941/cider-mode.el create mode 100644 elpa/cider-20170129.1941/cider-overlays.el create mode 100644 elpa/cider-20170129.1941/cider-pkg.el create mode 100644 elpa/cider-20170129.1941/cider-popup.el create mode 100644 elpa/cider-20170129.1941/cider-repl-history.el create mode 100644 elpa/cider-20170129.1941/cider-repl.el create mode 100644 elpa/cider-20170129.1941/cider-resolve.el create mode 100644 elpa/cider-20170129.1941/cider-scratch.el create mode 100644 elpa/cider-20170129.1941/cider-selector.el create mode 100644 elpa/cider-20170129.1941/cider-stacktrace.el create mode 100644 elpa/cider-20170129.1941/cider-test.el create mode 100644 elpa/cider-20170129.1941/cider-util.el create mode 100644 elpa/cider-20170129.1941/cider.el create mode 100644 elpa/cider-20170129.1941/nrepl-client.el create mode 100644 elpa/cider-20170129.1941/nrepl-dict.el create mode 100644 elpa/circe-20161102.1405/circe-autoloads.el create mode 100644 elpa/circe-20161102.1405/circe-chanop.el create mode 100644 elpa/circe-20161102.1405/circe-color-nicks.el create mode 100644 elpa/circe-20161102.1405/circe-compat.el create mode 100644 elpa/circe-20161102.1405/circe-highlight-all-nicks.el create mode 100644 elpa/circe-20161102.1405/circe-lagmon.el create mode 100644 elpa/circe-20161102.1405/circe-new-day-notifier.el create mode 100644 elpa/circe-20161102.1405/circe-pkg.el create mode 100644 elpa/circe-20161102.1405/circe.el create mode 100644 elpa/circe-20161102.1405/irc.el create mode 100644 elpa/circe-20161102.1405/lcs.el create mode 100644 elpa/circe-20161102.1405/lui-autopaste.el create mode 100644 elpa/circe-20161102.1405/lui-format.el create mode 100644 elpa/circe-20161102.1405/lui-irc-colors.el create mode 100644 elpa/circe-20161102.1405/lui-logging.el create mode 100644 elpa/circe-20161102.1405/lui-track-bar.el create mode 100644 elpa/circe-20161102.1405/lui.el create mode 100644 elpa/circe-20161102.1405/make-tls-process.el create mode 100644 elpa/circe-20161102.1405/shorten.el create mode 100644 elpa/circe-20161102.1405/tracking.el create mode 100644 elpa/command-log-mode-20160412.2147/command-log-mode-autoloads.el create mode 100644 elpa/command-log-mode-20160412.2147/command-log-mode-pkg.el create mode 100644 elpa/command-log-mode-20160412.2147/command-log-mode.el create mode 100644 elpa/command-log-mode-readme.txt delete mode 100644 elpa/dash-20161116.920/dash-pkg.el rename elpa/{dash-20161116.920 => dash-20170810.137}/dash-autoloads.el (84%) create mode 100644 elpa/dash-20170810.137/dash-pkg.el rename elpa/{dash-20161116.920 => dash-20170810.137}/dash.el (96%) create mode 100644 elpa/gnuplot-20141231.1337/gnuplot-autoloads.el create mode 100644 elpa/gnuplot-20141231.1337/gnuplot-context.el create mode 100644 elpa/gnuplot-20141231.1337/gnuplot-gui.el create mode 100644 elpa/gnuplot-20141231.1337/gnuplot-pkg.el create mode 100644 elpa/gnuplot-20141231.1337/gnuplot.el create mode 100644 elpa/gnuplot-readme.txt create mode 100644 elpa/hcl-mode-20160502.1700/hcl-mode-autoloads.el create mode 100644 elpa/hcl-mode-20160502.1700/hcl-mode-pkg.el create mode 100644 elpa/hcl-mode-20160502.1700/hcl-mode.el diff --git a/elpa/apples-mode-20110120.2018/apples-mode-autoloads.el b/elpa/apples-mode-20110120.2018/apples-mode-autoloads.el new file mode 100644 index 00000000..ad7bad2f --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode-autoloads.el @@ -0,0 +1,31 @@ +;;; apples-mode-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path)))) + +;;;### (autoloads nil "apples-mode" "apples-mode.el" (22813 44928 +;;;;;; 0 0)) +;;; Generated autoloads from apples-mode.el + +(autoload 'apples-open-scratch "apples-mode" "\ +Open scratch buffer for AppleScript. + +\(fn)" t nil) + +(autoload 'apples-mode "apples-mode" "\ +Happy AppleScripting! + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil nil ("apples-mode-pkg.el") (22813 44928 0 0)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; apples-mode-autoloads.el ends here diff --git a/elpa/apples-mode-20110120.2018/apples-mode-pkg.el b/elpa/apples-mode-20110120.2018/apples-mode-pkg.el new file mode 100644 index 00000000..f09b7a50 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode-pkg.el @@ -0,0 +1,5 @@ +(define-package "apples-mode" "20110120.2018" "Major mode for editing and executing AppleScript code" 'nil :keywords + '("applescript" "languages")) +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/apples-mode-20110120.2018/apples-mode.el b/elpa/apples-mode-20110120.2018/apples-mode.el new file mode 100644 index 00000000..45bf6edf --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode.el @@ -0,0 +1,1397 @@ +;;; apples-mode.el --- Major mode for editing and executing AppleScript code + +;; Copyright (C) 2011 tequilasunset + +;; Author: tequilasunset +;; Keywords: AppleScript, languages +(defconst apples-mode-version "0.0.2" + "The Current version of `apples-mode'.") + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General 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 program provides a major mode for AppleScript. + +;; [INSTALL] +;; +;; Put files in your load-path and add the following to your init file. +;; +;; (autoload 'apples-mode "apples-mode" "Happy AppleScripting!" t) +;; (autoload 'apples-open-scratch "apples-mode" "Open scratch buffer for AppleScript." t) +;; (add-to-list 'auto-mode-alist '("\\.\\(applescri\\|sc\\)pt\\'" . apples-mode)) +;; or +;; (require 'apples-mode) +;; (add-to-list 'auto-mode-alist '("\\.\\(applescri\\|sc\\)pt\\'" . apples-mode)) +;; +;; After that you should byte-compile apples-mode.el. +;; +;; M-x byte-compile-file RET /path/to/apples-mode.el RET +;; +;; During the byte-compilation, you may get some warnings, but you should +;; ignore them. +;; +;; [FEATURES] +;; +;; Commands for the execution have the prefix `apples-run-'. You can see +;; the other features via menu. +;; +;; [CONFIGURATION] +;; +;; You can access to the customize group via menu or using the command +;; `apples-customize-group'. + +;;; Tested: + +;; GNU Emacs 23.2.1 on Mac OS X 10.6.6 +;; AppleScript 2.1.2 + +;;; Known Bugs: + + +;;; TODO: + + +;;; Code: + +(require 'cl) +(require 'easymenu) +(require 'newcomment) + +(defgroup apples nil + "Major mode for editing and executing AppleScript code." + :group 'languages + :prefix "apples-") + + +;;; Utilities for internal use + +(defconst apples-identifier "\\(?:\\sw\\|\\s_\\)+") ; "[[:alnum:]_]+" + +(defmacro apples-define-show-func (name var) + "Define `apples-show-NAME', which is the command to display VAR." + `(defun ,(intern (format "apples-show-%s" name)) () + (interactive) + (message "%s" (or ,var "")))) + +(apples-define-show-func mode-version apples-mode-version) + +(defsubst apples-replace-re-comma->spaces (re) + "Replace all `,'s with `\\\\s-+' in RE." + (replace-regexp-in-string "," "\\\\s-+" re)) + +(defsubst apples-replace-re-space->spaces (re) + "Replace all ` 's with `\\\\s-+' in RE." + (replace-regexp-in-string " " "\\\\s-+" re)) + +;; DB +(defvar apples-plist nil) +(defsubst apples-plist-put (prop val) + (setq apples-plist (plist-put apples-plist prop val)) + val) +(defsubst apples-plist-get (prop) + (plist-get apples-plist prop)) + +;; temp files +(defcustom apples-tmp-dir nil + "Specify the path of temp dir. If nil, temp dir will be created to +the same directory where apples-mode.el is located." + :type '(choice directory (const nil)) + :group 'apples) + +(defmacro apples-define-tmp-file (name) + "Define `apples-tmp-NAME'." + `(progn + (defvar ,(intern (format "apples-tmp-%s" name)) nil) + (let ((files (apples-plist-get :tmp-files)) + (file ',(intern (format "apples-tmp-%s" name)))) + (unless (memq file files) + (apples-plist-put :tmp-files (cons file files))) + file))) + +(defun apples-tmp-files-setup () + "Make the apples-tmp-dir and temp files." + (when (apples-plist-get :tmp-files) + (let ((dir (expand-file-name + (or apples-tmp-dir + (concat (file-name-directory (locate-library "apples-mode")) + "apples-tmp-dir"))))) + (unless (file-directory-p dir) + (mkdir dir t)) + (loop for file in (apples-plist-get :tmp-files) + for tmp = (format "%s/%s.applescript" dir file) + do + (set file tmp) + (unless (file-exists-p tmp) + (with-temp-file tmp)) + finally (apples-plist-put :tmp-files nil))))) + + +;;; User variables + +(defcustom apples-follow-error-position t + "If non-nil, automatically move to the beginning position +where error has occurred." + :type 'boolean + :group 'apples) + +(defcustom apples-prefer-coding-system nil + "Specify the coding-system used for the execution of script." + :type '(choice symbol (const nil)) + :group 'apples) + +(defcustom apples-compile-create-file-flag nil + "If non-nil, create an output file of compilation without confirmations +if it doesn't exist." + :type 'boolean + :group 'apples) + +(defcustom apples-decompile-callback 'apples-handle-decompile + "Function to handle decompiled text via `apples-decompile'. +It is required two arguments SCRIPT and FILENAME. +SCRIPT is decompiled script. FILENAME is decompiled file name." + :type 'function + :group 'apples) + +(defcustom apples-decompile-query nil + "If valid char is specified, handle the output of decompiling +with specified one. Acceptable chars are as following:\n +?o - overwrite file by decompiled script +?i - insert decompiled script at point +?c - copy decompiled script in clipboard.\n +If you set `apples-decompile-callback' to other value, this is ignored. +Because this variable is used in `apples-handle-decompile'." + :type '(choice character (const nil)) + :group 'apples) + +(defcustom apples-continuation-char ?\x00AC + "Continuation character (not sign in mathematics)." + :type 'character + :group 'apples) + +(defcustom apples-indent-offset 4 + "Amount of offset per level of indentation for AppleScript." + :type 'integer + :group 'apples) + +(defcustom apples-continuation-offset apples-indent-offset + "Extra offset for the lines whose previous line is terminated with +the continuation character. See also `apples-continuation-char'." + :type 'integer + :group 'apples) + +(defcustom apples-indenters + '("considering" "else" "if" "ignoring" "on" "repeat" "tell" "try") + "Leading words of previous line which invoke the indentation of +current line.\n +See also `apples-deindenters', `apples-indent-regexps' and +`apples-noindent-regexps'." + :type '(repeat string) + :group 'apples) + +(defcustom apples-deindenters + '("else" "end") + "Leading words of current line which invoke the deindentation.\n +See also `apples-indenters', `apples-indent-regexps' and + `apples-noindent-regexps'." + :type '(repeat string) + :group 'apples) + +(defcustom apples-indent-regexps + (mapcar + (lambda (re) (concat "^" (apples-replace-re-comma->spaces re))) + '(;; script foo + "script,\\<" + "using,terms,from" + "with,timeout" + "with,transaction" + )) + "Regexps match to previous line, which invoke the indentation of +current line. This variable has priority over `apples-indenters'.\n +See also `apples-deindenters' and `apples-noindent-regexps'." + :type '(repeat regexp) + :group 'apples) + +(defcustom apples-noindent-regexps + (mapcar + (lambda (re) (concat "^" (apples-replace-re-comma->spaces re))) + '(;; if foo then bar + "if\\>.+\\.+\\" . apples-toggle-indent) + ("C-c t r" . apples-run-region/buffer) + ("C-c t k" . apples-compile) + ("C-c t d" . apples-decompile) + ("C-c t 3" . apples-show-last-result) + ("C-c t l" . apples-insert-continuation-char) + ("C-c t RET" . apples-insert-continuation-char-and-newline) + ("C-c t o" . apples-open-dict-index) + ("C-c t s" . apples-send-to-applescript-editor) + ("C-c t e" . apples-end-completion) + ) + "Alist of keybindings for `apples-mode'. Each element should be the form +\(KEY . COMMAND). KEY must be a string read by `kbd'. +If the value is nil, nothing will be set." + :type '(repeat (cons string symbol)) ; Can't set to nil via customize group? + :group 'apples) + +(defcustom apples-underline-syntax-class nil + "Specify syntax class of `_' (underline). +For example, \"w\" means a word, \"_\" means a symbol. +If nil, treated as a symbol." + :type '(choice string (const nil)) + :link '(info-link "(elisp)Syntax Class Table") + :group 'apples) + +(defcustom apples-end-completion-hl 'words + "Just after end completion, highlight 'region, 'words or +nothing (nil). See also `apples-end-completion-hl-duration'." + :type '(choice symbol (const nil)) + :group 'apples) + +(defcustom apples-end-completion-hl-duration 0.3 + "Highlight duration of end competion." + :type 'float + :group 'apples) + +(defcustom apples-mode-hook nil + "Hook executed just after called `apples-mode'." + :type 'hook + :group 'apples) + +(defcustom ac-source-applescript + '((candidates . (apples-keywords)) + (symbol . "d") + (cache)) + "Source for keywords of AppleScript. This is an additional source for +`auto-complete-mode'." + :type 'sexp + :link '(url-link "http://github.com/m2ym/auto-complete") + :group 'apples) + +;; Faces +(macrolet ((face (name &rest attrs) + `(defface ,(intern (format "apples-%s" name)) + '((t (,@attrs))) + ,(subst-char-in-string ?- ? (format "Face for %s." name)) + :group 'apples))) + (face statements :inherit font-lock-keyword-face) + (face commands :inherit font-lock-keyword-face :italic t) + (face operators :inherit font-lock-type-face) + (face labels :inherit font-lock-type-face :italic t) + (face records :inherit font-lock-builtin-face) + (face reserved-words :inherit font-lock-keyword-face :italic t) + (face error :inherit font-lock-warning-face) + (face standard-folders :inherit font-lock-constant-face) + (face continuation-char :inherit escape-glyph) + (face error-highlight :background "DeepPink3") + (face result-prompt :inherit minibuffer-prompt) + (face error-prompt :inherit font-lock-warning-face) + (face end-completion :inherit apples-error-highlight) + ) + + +;;; Process + +(apples-define-show-func last-result (apples-plist-get :last-result)) +(apples-define-show-func last-raw-result (apples-plist-get :last-raw-result)) + +(defmacro apples-set-run-info (&optional pred beg buf) + "If PRED returns non-nil, record BEG (or 1) and BUF (or current buffer). +Otherwise delete stored info." + (declare (indent 0)) + `(progn + (apples-delete-result) ; Delete last display + (apples-plist-put :run-info (if ,pred + (cons (or ,beg 1) (or ,buf (current-buffer))) + (cons nil nil))))) + +(defun apples-delete-overlay (ov) + (if (consp ov) + (mapc #'apples-delete-overlay ov) + (when (overlayp ov) + (delete-overlay ov)))) + +(defun apples-error-overlay-setup () + (let ((ov (apples-plist-get :err-ov))) + (if ov + (move-overlay ov 1 1) + (setq ov (make-overlay 1 1)) + (overlay-put ov 'face 'apples-error-highlight) + (apples-plist-put :err-ov ov)))) + +(defun apples-delete-result (&rest _) + (apples-delete-overlay (apples-plist-get :err-ov)) + (remove-hook 'pre-command-hook 'apples-display-result t) + (remove-hook 'after-change-functions 'apples-delete-result t)) + +(defun apples-display-result (&optional result) + (let (message-log-max) + (message (cond + ;; first time + (result + (add-hook 'pre-command-hook 'apples-display-result nil t) + (add-hook 'after-change-functions 'apples-delete-result nil t) + (apples-plist-put :last-result result)) + ;; called from hook + ((and (eq major-mode 'apples-mode) + (eq (cdr (apples-plist-get :run-info)) + (current-buffer))) + (apples-plist-get :last-result)))))) + +(apples-define-tmp-file -1713) +(defun apples-error--1713-workaround (f/s) + "Avoid AppleScript's error -1713.\n + execution error: No user interaction allowed. (-1713)" + ;; Ref: + (unless (file-exists-p f/s) + (with-temp-file apples-tmp--1713 + (insert f/s)) + (setq f/s apples-tmp--1713)) + (apples-do-applescript + (format + "tell application \"AppleScript Runner\" to do script \"%s\"" f/s))) + +(defun apples-parse-error (result) + (destructuring-bind + (err-ov (actual-beg . err-buf) + &aux err-beg err-end err-type err-msg err-num unknown) + (values (apples-plist-get :err-ov) (apples-plist-get :run-info)) + (if (string-match + "\\([0-9]+\\):\\([0-9]+\\): \\([^:]+:\\) \\(.+\\) (\\(-?[0-9]+\\))$" + result) + (progn + (setq err-beg (string-to-number (match-string 1 result)) + err-end (string-to-number (match-string 2 result)) + err-type (match-string 3 result) + err-msg (match-string 4 result) + err-num (string-to-number (match-string 5 result))) + (when actual-beg + (setq err-beg (+ err-beg actual-beg) + err-end (+ err-end actual-beg)))) + (setq unknown t)) + (values + unknown + ;; If get the unknown error, below five values return nil. + err-beg err-end err-type err-msg err-num + ;; If executed script is an unopened file or called from the minibuffer, + ;; err-buf returns nil. + err-buf err-ov))) + +(defun apples-result (result status f/s) + "Handle the result of AppleScript's execution. +If execution has done successfully, display the result. +If error has occurred, display the error. +In that case, if executed script is same as current buffer or in it, +also highlight the error region and go to the beginning of it if +`apples-follow-error-position' is non-nil." + (block nil + (apples-plist-put :last-raw-result result) + (apples-display-result + (replace-regexp-in-string + "%" "%%" ; %-sequence => % + (if (= status 1) + ;; error + (multiple-value-bind (unknown beg end type msg num buf ov) + (apples-parse-error result) + ;; -1713 + (when (eq num -1713) + (return (apples-error--1713-workaround f/s))) + (when (and beg buf) + ;; highlight and move + (when apples-follow-error-position + (switch-to-buffer buf) + (goto-char beg) + (deactivate-mark)) + (move-overlay ov beg end buf)) + ;; res + (if unknown + result + (format "%s%s [%s]" + (propertize (concat type " ") 'face 'apples-error-prompt) + msg + (propertize (int-to-string num) + 'face 'apples-error-prompt)))) + ;; no error + (concat (propertize "Result: " 'face 'apples-result-prompt) + (replace-regexp-in-string + "\\\\\"" "\"" (if (string-match "^\"\\(.*\\)\"$" result) + (match-string-no-properties 1 result) + result)))))))) + +(defsubst apples-proc-live-p (proc) + "Return non-nil if PROC is still running." + (and (processp proc) + (not (eq (process-status proc) 'exit)) + (= (process-exit-status proc) 0) + t)) + +(defsubst apples-buffer-string (&optional buffer-or-name) + "Return contents of a currnet buffer or BUFFER-OR-NAME. +Also delete the entire contents of the buffer." + (with-current-buffer (or buffer-or-name (current-buffer)) + (if (zerop (buffer-size)) + "" + (prog1 (buffer-substring-no-properties + (point-min) (1- (point-max))) + (erase-buffer))))) + +(defsubst apples-proc-failed-p (proc) + "Return non-nil, if PROC has been failed." + (= (process-exit-status proc) 1)) + +(defsubst apples-proc-failed (msg buf) + "Display BUF's contents or MSG added 'missed message. +After that, delete BUF's contents." + (let ((str (apples-buffer-string buf))) + (message (or (and (not (string= str "")) str) + (concat msg "missed"))))) + +(defsubst apples-encode-string (str) + "Encode STR to `apples-prefer-coding-system' if it is specified." + (if apples-prefer-coding-system + (encode-coding-string str apples-prefer-coding-system) + str)) + +(defun apples-do-applescript (filename-or-script &optional callback) + "Execute FILENAME-OR-SCRIPT as AppleScript. CALLBACK is required +three arguments RESULT, EXIT-PROC-STATUS and FILENAME-OR-SCRIPT. +If CALLBACK is omitted, call `apples-result'." + (lexical-let* ((f/s filename-or-script) + (callback callback) + (buf (get-buffer-create " *apples-do-applescript*")) + (args (if (file-exists-p f/s) + `(,f/s) + `("-ss" "-e" ,(apples-encode-string f/s)))) + (old-proc (get-buffer-process buf)) + (enable (if (apples-proc-live-p old-proc) + (when (y-or-n-p "\ +apples: Process is still running; kill it? ") + (progn + (kill-process old-proc) + t)) + t))) + (when enable + (set-process-sentinel + (apply #'start-process "apples-do-applescript" buf "osascript" args) + (lambda (proc _) + (funcall (or callback 'apples-result) + (apples-buffer-string buf) + (process-exit-status proc) + f/s)))))) + +;; Compile +(defun apples-compile (&optional filename output) + "Compile FILENAME into OUTPUT." + (interactive) + (labels ((read (file prompt default) + (expand-file-name + (or file (read-file-name prompt default default))))) + (lexical-let* ((filename (read filename "File: " buffer-file-name)) + (output (let ((file (read output "Output: " filename))) + (if (file-exists-p file) + file + (when (or apples-compile-create-file-flag + (y-or-n-p + (format "apples: %s doesn't exist; make it? " + file))) + (let ((dir (file-name-directory file))) + (unless (file-directory-p dir) + (mkdir dir t)) + (with-temp-file file)) + file)))) + (buf (get-buffer-create " *apples-compile*")) + (args `("-o" ,output ,filename)) + msg) + (when (every 'file-exists-p `(,filename ,output)) + (setq msg (message "Compiling...")) + (set-process-sentinel + (apply #'start-process "apples-compile" buf "osacompile" args) + (lambda (proc _) + (if (apples-proc-failed-p proc) + (apples-proc-failed msg buf) + (message "%sdone" msg)))))))) + +;; Decompile +(defun apples-handle-decompile (script filename) + "Default function to handle decompiled script. +To specify the default query, set `apples-decompile-query'." + (case (or apples-decompile-query + (ignore-errors + (read-char + (apply #'format + "%s%sverwrite file %snsert script %sopy script" + (propertize "Select: " 'face 'apples-result-prompt) + (mapcar (lambda (s) + (propertize (concat "[" (upcase s) "]") + 'face '(:weight bold))) + '("o" "i" "c")))))) + (?o (let ((buf (get-file-buffer filename))) + (if buf + (with-current-buffer buf + (erase-buffer) + (insert script)) + (with-temp-file filename + (insert script))))) + (?i (insert script)) + (?c (with-temp-buffer + (insert script) + (kill-ring-save (point-min) (point-max)))))) + +(defun apples-decompile (filename) + "Decompile FILENAME. See also `apples-decompile-query' and +`apples-decompile-callback'." + (interactive + (list (read-file-name "File: " buffer-file-name buffer-file-name))) + (lexical-let* ((filename (expand-file-name filename)) + (buf (get-buffer-create " *apples-decompile*")) + msg) + (when (file-exists-p filename) + (setq msg (message "Decompiling...")) + (set-process-sentinel + (start-process "apples-decompile" buf "osadecompile" filename) + (lambda (proc _) + (if (apples-proc-failed-p proc) + (apples-proc-failed msg buf) + (funcall apples-decompile-callback + (apples-buffer-string buf) + filename))))))) + +;; Send script to AppleScript Editor +(defun apples-quoted-string (str) + "Convert `\"' to `\\\"', `\\' to `\\\\' in STR." + (replace-regexp-in-string + "\"" "\\\\\"" (replace-regexp-in-string "\\\\" "\\\\\\\\" str))) + +(apples-define-tmp-file send) +(defun apples-send-to-applescript-editor () + "Send region or current buffer to AppleScript Editor and run it." + (interactive) + (ignore-errors + (do-applescript + (apples-encode-string + (format + (mapconcat + 'identity + '("tell application \"AppleScript Editor\"" + " activate" + " open \"%s\"" + " tell document \"%s\"" + " set contents to \"%s\"" + ;; " save" + " execute" + " end tell" + "end tell") + "\n") + (expand-file-name apples-tmp-send) + (file-name-nondirectory apples-tmp-send) + (apples-quoted-string + (apply #'buffer-substring-no-properties + (if (use-region-p) + (list (region-beginning) (region-end)) + (list (point-min) (point-max)))))))))) + + +;;; Commands + +;; Run +(defun apples-run-file (&optional filename) + "Execute FILENAME as AppleScript." + (interactive "fFile: ") + (setq filename (expand-file-name filename)) + (when (file-exists-p filename) + (apples-set-run-info + (eq (get-file-buffer filename) + (current-buffer))) + (apples-do-applescript filename))) + +(defun apples-run-buffer (&optional buffer-or-name) + "Execute a current buffer or BUFFER-OR-NAME as AppleScript." + (interactive) + (or buffer-or-name (setq buffer-or-name (current-buffer))) + (apples-set-run-info + (eq (or (get-buffer buffer-or-name) + buffer-or-name) + (current-buffer))) + (with-current-buffer buffer-or-name + (apples-do-applescript (buffer-string)))) + +(defun apples-run-region (beg end) + "Execute region as AppleScript." + (interactive "r") + (when (/= beg end) + (apples-set-run-info t beg) + (apples-do-applescript (buffer-substring beg end)))) + +(defun apples-run-region/buffer () + "Execute region or current buffer as AppleScript." + (interactive) + (if (use-region-p) + (call-interactively 'apples-run-region) + (apples-run-buffer))) + +(defun apples-run-minibuf (script) + "Read script from minibuffer and execute it as AppleScript." + (interactive "sScript: ") + (apples-set-run-info nil) + (apples-do-applescript script)) + +;; Open Dictionary index +(defun apples-open-dict-index () + "Open dictionary index in AppleScript Editor." + (interactive) + (do-applescript + (mapconcat + 'identity + '("tell application \"AppleScript Editor\" to activate" + "tell application \"System Events\"" + " tell process \"AppleScript Editor\"" + " key code 31 using {shift down, command down}" ; Command-Shift-O + " end tell" + "end tell") + "\n"))) + +;; Insert continuation character +(defsubst apples-continuation-char () + "Return the continuation character as a string." + (char-to-string apples-continuation-char)) + +(defun apples-insert-continuation-char () + "Insert the continuation character." + (interactive "^") + (when (re-search-backward "\\s-+\\=" nil t) + (delete-region (match-beginning 0) (match-end 0))) + (insert ? apples-continuation-char)) + +(defun apples-insert-continuation-char-and-newline () + "Insert the continuation character, then add newline." + (interactive "^") + (apples-insert-continuation-char) + (call-interactively (key-binding (kbd "RET")))) + +;; Scratch buffer for AppleScript +(apples-define-tmp-file scratch) +(defun apples-save-scratch () + "Write the contents of *apples-scratch* to temp file." + (let ((buf (get-buffer "*apples-scratch*"))) + (when buf + (with-current-buffer buf + (write-region (point-min) (point-max) apples-tmp-scratch nil 'quiet))))) + +;;;###autoload +(defun apples-open-scratch () + "Open scratch buffer for AppleScript." + (interactive) + (apples-tmp-files-setup) + (let ((buf (get-buffer "*apples-scratch*"))) + (pop-to-buffer (get-buffer-create "*apples-scratch*")) + (unless buf + (add-hook 'kill-emacs-hook 'apples-save-scratch) + (add-hook 'kill-buffer-hook 'apples-save-scratch nil t) + (insert-file-contents apples-tmp-scratch) + (goto-char (point-max)) + (apples-mode)))) + +;; Key code +(defconst apples-key-codes + '((?a . 0) (?b . 11) (?c . 8) (?d . 2) (?e . 14) (?f . 3) (?g . 5) (?h . 4) + (?i . 34) (?j . 38) (?k . 40) (?l . 37) (?m . 46) (?n . 45) (?o . 31) + (?p . 35) (?q . 12) (?r . 15) (?s . 1) (?t . 17) (?u . 32) (?v . 9) + (?w . 13) (?x . 7) (?y . 16) (?z . 6) (?0 . 29) (?1 . 18) (?2 . 19) + (?3 . 20) (?4 . 21) (?5 . 23) (?6 . 22) (?7 . 26) (?8 . 28) (?9 . 25) + (f1 . 122) (f2 . 120) (f3 . 99) (f4 . 118) (f5 . 96) (f6 . 97) (f7 . 98) + (f8 . 100) (f9 . 101) (f10 . 109) (f11 . 103) (f12 . 111) (escape . 53) + (tab . 48) (? . 49) (return . 36) (backspace . 51) (left . 123) + (right . 124) (down . 125) (up . 126)) + "Index of key codes. Each element has the form (CHAR-OR-SYMBOL . KEY-CODE).") + +(defun apples-lookup-key->key-code () + "Look up key code of AppleScript from key." + (interactive) + (clear-this-command-keys) + (message (propertize "Key: " 'face 'minibuffer-prompt)) + (let* ((key (read-event)) + (key-code (cdr (assq key apples-key-codes))) + (key (if (integerp key) (char-to-string key) key))) + (if key-code + (message (format "Key: %s Key code: %d" key key-code)) + (message "Not found %s" key)))) + +(defun apples-lookup-key-code->key (key-code) + "Look up key from key code of AppleScript." + (interactive "nKey code: ") + (let* ((key (car (rassq key-code apples-key-codes))) + (key (if (integerp key) (char-to-string key) key))) + (if key + (message (format "Key: %s Key code: %d" key key-code)) + (message "Not found %d" key-code)))) + +;; Comment +(defun apples-comment-or-uncomment-region (beg end &optional arg) + "`comment-or-uncomment-region' for `apples-mode'." + (interactive "*r\nP") + (let ((comment-style 'indent)) + (comment-or-uncomment-region beg end arg))) + +(defun apples-comment-dwim (arg) + "`comment-dwim' for `apples-mode'." + (interactive "*P") + (let ((comment-style 'indent)) + (comment-dwim arg))) + + +;;; Indentation + +(defsubst apples-in-string/comment-p (&optional pos) + "Return non-nil, if POS is in string or in comment." + (save-excursion + (let ((ppss (syntax-ppss pos))) + (or (nth 3 ppss) (nth 4 ppss))))) + +(defsubst apples-in-string-p (&optional pos) + "Return non-nil, if POS is in string." + (save-excursion + (nth 3 (syntax-ppss pos)))) + +(defsubst apples-ideal-prev-bol () + "Return the point of previous bol or nil. Lines like the followings +are skipped.\n +- Empty lines +- Lines filled by whitespaces +- Lines whose bol is in string or in comment +- Comments" + (save-excursion + (loop initially (beginning-of-line) + while (not (bobp)) + do (forward-line -1) + unless (or (looking-at "\\s-*$") + (apples-in-string/comment-p) + (let ((face-prop (save-excursion + (skip-chars-forward " \t") + (get-text-property (point) 'face)))) + (some (lambda (face) + (if (listp face-prop) + (memq face face-prop) + (eq face face-prop))) + '(font-lock-comment-face + font-lock-comment-delimiter-face)))) + return (point)))) + +(defsubst apples-leading-word-of-line () + "Return the leading word of line as a string. +If leading char except whitespaces is not a word, return nil." + (save-excursion + (beginning-of-line) + (when (looking-at (concat "\\s-*\\(" apples-identifier "\\)")) + (buffer-substring-no-properties + (match-beginning 1) (match-end 1))))) + +(defsubst apples-line-string () + "Return the contents of current line as a string. Leading and trailing +whitespaces are deleted." + (let (beg end) + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (setq beg (point)) + (end-of-line) + (skip-chars-backward " \t") + (setq end (point))) + (buffer-substring-no-properties beg end))) + +(defsubst apples-string-match (regexps string) + "Unlike `string-match', first argument has to be a list of REGEXPS." + (some (lambda (re) (string-match re string)) regexps)) + +(defun apples-parse-lines () + "Parse current and previous lines then return the values." + (let ((prev-bol (unless (= (point-at-bol) (point-min)) + (apples-ideal-prev-bol))) + (cchar-re (concat (apples-continuation-char) "$")) + prev-indent prev-lword prev-lstr pprev-bol prev-cchar-p pprev-cchar-p) + (flet ((cchar? (lstr) (string-match cchar-re lstr))) + (when prev-bol + (save-excursion + (goto-char prev-bol) + (setq prev-indent (current-indentation) + prev-lstr (apples-line-string) + prev-lword (when (string-match (concat "^" apples-identifier) + prev-lstr) + (match-string-no-properties 0 prev-lstr)) + prev-cchar-p (cchar? prev-lstr)) + ;; Parse previous line again for continuation char. + (when (setq pprev-bol (apples-ideal-prev-bol)) + (goto-char pprev-bol) + (setq pprev-cchar-p (cchar? (apples-line-string)))))) + (values + (current-column) (current-indentation) (apples-leading-word-of-line) + ;; If prev-bol is nil, belows return nil. + prev-bol prev-indent prev-lword prev-lstr prev-cchar-p pprev-cchar-p)))) + +(defun apples-indent-line () + "Indent current line according to AppleScript indentation rules." + (interactive "^") + (let* ((bol-ppss (save-excursion (syntax-ppss (point-at-bol)))) + (bol-is-in-string (nth 3 bol-ppss)) + (bol-is-in-comment (nth 4 bol-ppss)) + (pos (point)) + indent) + (unless bol-is-in-string + (multiple-value-bind + (cur-col cur-indent cur-lword prev-bol prev-indent + prev-lword prev-lstr prev-cchar-p pprev-cchar-p) + (apples-parse-lines) + (if bol-is-in-comment + (setq indent (or prev-indent 0)) + ;; bol is neither in string nor in comment + (flet ((match? (regs str) (and regs str (apples-string-match regs str))) + (member? (str lst) (and str lst (member str lst)))) + (let* ((cchar-indent? (and prev-cchar-p (not pprev-cchar-p))) + (prev-indent? (match? apples-indent-regexps prev-lstr)) + (prev-noindent? (match? apples-noindent-regexps prev-lstr)) + (cchar-deindent? (and (not prev-cchar-p) pprev-cchar-p)) + (prev-indenter? (member? prev-lword apples-indenters)) + (cur-deindenter? + (or (member? cur-lword apples-deindenters) + (and (string= cur-lword "on") + (string-match "^on\\s-+error" + (apples-line-string)))))) + ;; Calculating... + (setq indent (- (cond ((and cchar-indent? (not prev-noindent?)) + ;; indent by cchar offset + (+ prev-indent apples-continuation-offset)) + ((and (or prev-indent? prev-indenter?) + (not prev-noindent?)) + ;; indent + (+ prev-indent apples-indent-offset)) + (cchar-deindent? + ;; deindent by cchar offset + (- prev-indent apples-continuation-offset)) + ;; same as prev + (prev-indent) + ;; no prev + (0)) + (if cur-deindenter? + ;; deindent + apples-indent-offset + ;; noindent + 0)))))) + ;; Now indent line. + (indent-line-to (if (natnump indent) indent 0)) + (when (> (- cur-col cur-indent) 0) + (goto-char (+ pos (- (current-indentation) cur-indent)))))))) + +(defun apples-toggle-indent () + "Toggle indentation." + (interactive "^") + (unless (apples-in-string-p (point-at-bol)) + (multiple-value-bind + (cur-col cur-indent _1 prev? prev-indent _2 _3 prev-cchar-p pprev-cchar-p) + (apples-parse-lines) + (let* ((pos (point)) + (offset (if (or prev-cchar-p pprev-cchar-p) + apples-continuation-offset + apples-indent-offset)) + (indent (cond (prev? + (let ((diff (- prev-indent cur-indent))) + (cond ((> diff 0) prev-indent) + ((= diff 0) (+ prev-indent offset)) + (t (- prev-indent offset))))) + ;; no prev + ((= cur-indent 0) offset) + (0)))) + ;; Now indent line. + (indent-line-to (if (natnump indent) indent 0)) + (when (> (- cur-col cur-indent) 0) + (goto-char (+ pos (- (current-indentation) cur-indent)))))))) + +;; end completion +(defconst apples-statements + `(,@(loop for word in '("considering" "ignoring" "try" "if" + "repeat" "tell" "using terms from") + collect (cons word word)) + ("with timeout" . "timeout" ) + ("with transaction" . "transaction" ) + ("on adding folder items to" . "adding folder items to" ) + ("on closing folder window for" . "closing folder window for" ) + ("on moving folder window for" . "moving folder window for" ) + ("on opening folder" . "opening folder" ) + ("on removing folder items from" . "removing folder items from" ) + ) + "Alist of (BEG-WORD-OF-STATEMENT . END-WORD-OF-STATEMENT)s.") + +(defun apples-parse-statement () + "Parse the current statement block and return the values +\(BOL-WHERE-STATEMENT-STARTS BEG-WORD-OF-STATEMENT END-WORD-OF-STATEMENT)." + (destructuring-bind (min count nils &aux bol lstr) + (values (point-min) 1 (values nil nil nil)) + (if (apples-in-string/comment-p) + nils + (catch 'val + (save-excursion + (while (/= (point) min) + (catch 'loop + (if (null (setq bol (apples-ideal-prev-bol))) + (throw 'val nils) + (goto-char bol) + (setq lstr (apples-line-string)) + (if (string-match "^end\\>" lstr) + (incf count) + (loop for (beg . end) in apples-statements + when (and (string-match (concat "^" beg "\\>") lstr) + (not (apples-string-match apples-noindent-regexps + lstr))) + do (if (zerop (decf count)) + (throw 'val (values bol beg end)) + (throw 'loop nil)) + finally + ;; in case of `on' + (when (and (string-match (concat "^on \\(" + apples-identifier + "\\)") + lstr) + (setq end (match-string-no-properties 1 lstr)) + (not (string= end "error")) + (zerop (decf count))) + (throw 'val (values bol + (concat "on " end) + end))))))))))))) + +(defun apples-end-completion () + "Insert `end + current-statement-name'. If `apples-end-completion-hl' is +specified, also highlight the matching statement." + (interactive "^") + (multiple-value-bind (bol bword eword) + (apples-parse-statement) + (when eword + (insert "end " eword) + (when apples-end-completion-hl + (apples-end-completion-hl bol bword eword))))) + +(defun apples-end-completion-hl (bol bword eword) + (destructuring-bind ((bov . eov) beg pos) + (values (apples-plist-get :end-ovs) + (save-excursion + (goto-char bol) + (skip-chars-forward " \t") + (point)) + (point)) + (case apples-end-completion-hl + (region (move-overlay bov beg pos)) + (words (move-overlay bov beg (+ beg (length bword))) + (move-overlay eov (- pos (length eword) 4) pos))) + (run-at-time apples-end-completion-hl-duration nil + 'apples-delete-overlay (list bov eov)))) + +(defun apples-end-completion-hl-setup () + (unless (apples-plist-get :end-ovs) + (let ((bov (make-overlay 1 1)) + (eov (make-overlay 1 1))) + (overlay-put bov 'face 'apples-end-completion) + (overlay-put eov 'face 'apples-end-completion) + (apples-plist-put :end-ovs (cons bov eov))))) + + +;;; Font lock + +(defconst apples-keywords + `((reserved-words + . ("about" "above" "after" "against" "and" "apart from" "around" "as" + "aside from" "at" "back" "before" "beginning" "behind" "below" "beneath" + "beside" "between" "but" "by" "considering" "contain" "contains" + "contains" "continue" "copy" "div" "does" "eighth" "else" "end" "equal" + "equals" "error" "every" "exit" "false" "fifth" "first" "for" "fourth" + "from" "front" "get" "given" "global" "if" "ignoring" "in" "instead of" + "into" "is" "it" "its" "last" "local" "me" "middle" "mod" "my" "ninth" + "not" "of" "on" "onto" "or" "out of" "over" "prop" "property" "put" + "ref" "reference" "repeat" "return" "returning" "script" "second" "set" + "seventh" "since" "sixth" "some" "tell" "tenth" "that" "the" "then" + "third" "through" "thru" "timeout" "times" "to" "transaction" "true" + "try" "until" "where" "while" "whose" "with" "without")) + (statements + . (,@(mapcar 'car apples-statements) + "application" "considering application responses" "continue" "else" + "end" "error" "exit" "ignoring application responses" "on" + "repeat until" "repeat while" "repeat with" "return" "then")) + (commands + . ("ASCII character" "ASCII number" "activate" "AGStart" "beep" "copy" + "count" "choose application" "choose color" "choose file" + "choose file name" "choose folder" "choose from list" + "choose remote application" "choose URL" "clipboard info" "close access" + "current date" "delay" "display alert" "display dialog" + "do shell script" "get" "get eof" "get volume settings" "info for" + "launch" "list disks" "list folder" "load script" "localized string" + "log" "monitor depth" "max monitor depth" "min monitor depth" + "mount volume" "new file" "offset" "open for access" "open location" + "path to" "path to application" "path to folder" "path to resource" + "random number" "read" "round" "run" "run script" "say" + "scripting component" "set" "set eof" "set monitor depth" + "set the clipboard to" "set volume" "start log" "stop log" + "store script" "system attribute" "system info" "time to GMT" + "the clipboard" "write")) + (operators + . ("&" "*" "+" "-" "/" "<" "<=" "=" ">" ">=" "^" "a ref to" "a ref" + "a reference to" "a reference" "and" "as" "begin with" "begins with" + "comes after" "comes before" "contain" "contains" "div" + "does not come after" "does not come before" "does not contain" + "does not equal" "doesn't come after" "doesn't come before" + "doesn't contain" "doesn't equal" "end with" "ends with" "equal to" + "equals" "greater than or equal to" "greater than or equal" + "greater than" "in not contained by" "is contained by" "is equal to" + "is equal" "is greater than or equal to" "is greater than or equal" + "is greater than" "is in" "is less than or equal to" + "is less than or equal" "is less than" "is not equal to" "is not equal" + "is not greater than or equal to" "is not greater than or equal" + "is not greater than" "is not in" "is not less than or equal to" + "is not less than or equal" "is not less than" "is not" + "isn't contained by" "isn't equal to" "isn't equal" + "isn't greater than or equal to" "isn't greater than or equal" + "isn't greater than" "isn't less than or equal to" + "isn't less than or equal" "isn't less than" "isn't" + "less than or equal to" "less than or equal" "less than" "mod" "not" + "or" "ref to" "ref" "reference to" "reference" "start with" + "starts with")) + (handler-parameter-labels + . ("about" "above" "against" "apart from" "around" "aside from" "at" + "below" "beneath" "beside" "between" "by" "for" "from" "given" + "instead of" "into" "on" "onto" "out of" "over" "since" "thru" "through" + "under")) + + (standard-folders + . ,(let ((lst + ;; Ref: + ;; + '(("application support" + "Macintosh HD:Library:Application Support:" + "/Library/Application Support/") + ("applications folder" + "Macintosh HD:Applications:" + "/Applications/") + ("current application" + "Macintosh HD:System:Library:CoreServices:AppleScript Runner.app:" + "/System/Library/CoreServices/AppleScript Runner.app/") + ("current user folder" + "Macintosh HD:Users:username:" + "/Users/username/") + ("desktop" + "Macintosh HD:Users:username:Desktop:" + "/Users/username/Desktop/") + ("desktop pictures folder" + "Macintosh HD:Library:Desktop Pictures:" + "/Library/Desktop Pictures/") + ("documents folder" + "Macintosh HD:Users:username:Documents:" + "/Users/username/Documents/") + ("downloads folder" + "Macintosh HD:Users:username:Downloads:" + "/Users/username/Downloads/") + ("favorites folder" + "Macintosh HD:Users:username:Library:Favorites:" + "/Users/username/Library/Favorites/") + ("Folder Action scripts" + "Macintosh HD:Users:username:Library:Scripts:Folder Action Scripts:" + "/Users/username/Library/Scripts/Folder Action Scripts/") + ("fonts" + "Macintosh HD:System:Library:Fonts:" + "/System/Library/Fonts/") + ("frontmost application" + "Macintosh HD:System:Library:CoreServices:Finder.app:" + "/System/Library/CoreServices/Finder.app/") + ("help folder" + "Macintosh HD:Library:Documentation:Help:" + "/Library/Documentation/Help/") + ("home folder" + "Macintosh HD:Users:username:" + "/Users/username/") + ("keychain folder" + "Macintosh HD:Users:username:Library:Keychains:" + "/Users/username/Library/Keychains/") + ("library folder" + "Macintosh HD:Library:" + "/Library/") + ("modem scripts" + "Macintosh HD:System:Library:Modem Scripts:" + "/System/Library/Modem Scripts/") + ("movies folder" + "Macintosh HD:Users:username:Movies:" + "/Users/username/Movies/") + ("music folder" + "Macintosh HD:Users:username:Music:" + "/Users/username/Music/") + ("pictures folder" + "Macintosh HD:Users:username:Pictures:" + "/Users/username/Pictures/") + ("preferences" + "Macintosh HD:Users:username:Library:Preferences:" + "/Users/username/Library/Preferences/") + ("printer descriptions" + "Macintosh HD:System:Library:Printers:PPDs:" + "/System/Library/Printers/PPDs/") + ("public folder" + "Macintosh HD:Users:username:Public:" + "/Users/username/Public/") + ("scripting additions" + "Macintosh HD:System:Library:ScriptingAdditions:" + "/System/Library/ScriptingAdditions/") + ("scripts folder" + "Macintosh HD:Users:username:Library:Scripts:" + "/Users/username/Library/Scripts/") + ("shared documents folder" + "Macintosh HD:Users:Shared:" + "/Users/Shared/") + ("shared libraries" + "Macintosh HD:System:Library:CFMSupport:" + "/System/Library/CFMSupport/") + ("sites folder" + "Macintosh HD:Users:username:Sites:" + "/Users/username/Sites/") + ("startup disk" + "Macintosh HD:" + "/") + ("system folder" + "Macintosh HD:System:" + "/System/") + ("system preferences" + "Macintosh HD:System:Library:PreferencePanes:" + "/System/Library/PreferencePanes/") + ("temporary items" + "Macintosh HD:private:var:folders:foobar:TemporaryItems:" + "/private/var/folders/foobar/TemporaryItems/") + ("trash" + "Macintosh HD:Users:username:.Trash:" + "/Users/username/.Trash/") + ("users folder" + "Macintosh HD:Users:" + "/Users/") + ("utilities folder" + "Macintosh HD:Applications:Utilities:" + "/Applications/Utilities/") + ("voices" + "Macintosh HD:System:Library:Speech:Voices:" + "/System/Library/Speech/Voices/") + ))) + (loop for (folder path posix) in (nreverse lst) + collect (propertize folder 'path path 'posix posix)))) + ) + "Keywords of AppleScript. Each element has the form (TYPE . KEYWORDS).") + + +(defun apples-keywords (&optional type) + "Return keywords of TYPE. If it is omitted, return all keywords." + (if type + (cdr (assq type apples-keywords)) + (apply 'append (mapcar 'cdr apples-keywords)))) + +(defvar apples-font-lock-keywords + (let ((i apples-identifier)) + (flet ((kws (type) (apples-replace-re-space->spaces + (regexp-opt (apples-keywords type) 'words))) + (cat (&rest s) (apples-replace-re-comma->spaces (apply #'concat s)))) + `( + ("\\" 0 'apples-error ) + (,(kws 'statements) 1 'apples-statements ) + (,(cat "^\\s-*\\(?:on\\|to\\),\\(" i "\\)") + 1 font-lock-function-name-face ) + (,(cat "\\") 1 font-lock-variable-name-face ) + (,(apples-continuation-char) 0 'apples-continuation-char ) + (,(kws 'standard-folders) 1 'apples-standard-folders ) + (,(kws 'commands) 1 'apples-commands ) + (,(kws 'operators) 1 'apples-operators ) + (,(cat ",\\([-&*+/<=>^]\\|<=\\|>=\\),") 0 'apples-operators ) + (,(cat "\\<" i ":") 0 'apples-records ) + (,(kws 'handler-parameter-labels) 1 'apples-labels ) + (,(kws 'reserved-words) 1 'apples-reserved-words ) + ("\\('s\\)\\s-+" 1 'apples-reserved-words ) + ))) + "Font lock keywords for `apples-mode'. +See also `font-lock-defaults' and `font-lock-keywords'.") + + +;;; Misc + +(defvar apples-mode-map + (let ((map (make-sparse-keymap))) + ;; Define menu. + (easy-menu-define nil map + "Menu for `apples-mode'." + `("AppleScript" + ["Open Scratch" apples-open-scratch] + ["Open Dictionary..." apples-open-dict-index] + ("Edit" :visible (not buffer-read-only) + ["(Un)comment Region" apples-comment-or-uncomment-region] + ["Comment Dwim" apples-comment-dwim] + "---" + ["Insert Continuation Char" apples-insert-continuation-char] + ["Insert Continuation Char and Newline" + apples-insert-continuation-char-and-newline] + "---" + ["End Completion" apples-end-completion] + ) + ("Execution" + ["Run File" apples-run-file] + ["Run Buffer" apples-run-buffer] + ["Run Region" apples-run-region] + ["Run from Minibuffer" apples-run-minibuf] + ["Run Region or Buffer" apples-run-region/buffer] + ["Run Region or Buffer in ASE" apples-send-to-applescript-editor] + "---" + ["Compile" apples-compile] + ["Decompile" apples-decompile] + "---" + ["Last Result" apples-show-last-result] + ["Last Raw Result" apples-show-last-raw-result] + ) + ("Misc" + ("Key <=> Key Code" + ["Key => Key Code" apples-lookup-key->key-code] + ["Key Code => Key" apples-lookup-key-code->key]) + ("path to..." + ,@(loop for folder in (nreverse (apples-keywords 'standard-folders)) + collect (multiple-value-bind (path posix) + (with-temp-buffer + (insert folder) + (let ((pos (point-min))) + (values (get-text-property pos 'path) + (get-text-property pos 'posix)))) + `(,(capitalize folder) + [,folder + (insert ,folder) + (not buffer-read-only)] + [,(concat "PATH: " path) + (prin1 ,path (current-buffer)) + (not buffer-read-only)] + [,(concat "POSIX: " posix) + (prin1 ,posix (current-buffer)) + (not buffer-read-only)])))) + ) + "---" + ["Customizations" apples-customize-group] + ["Mode Version" apples-show-mode-version] + ["AppleScript Version" apples-show-applescript-version] + ["Visit apples-mode Project" apples-visit-project] + )) + map) + "Keymap used in `apples-mode'.") + +(defun apples-keymap-setup () + "Set up keybindings for `apples-mode' according to `apples-keymap'." + (when (and apples-keymap + (not (apples-plist-get :keybinded?))) + (loop for (key . cmd) in apples-keymap + do (define-key apples-mode-map (read-kbd-macro key) cmd) + finally (apples-plist-put :keybinded? t)))) + +(defvar apples-mode-syntax-table + (let ((st (make-syntax-table)) + (lst + '((?\" "\"") + (?\\ "\\") + (?| "w") + (?: "_") + (?_ "_") + (?# "<") + (?- ". 12") + (?\t " ") + (?\f " ") + (?\n "> ") + (?\{ "(}") + (?\} "){") + (?\( "() 1b") + (?\) ")( 4b") + (?* ". 23b") + ))) + (loop for (char entry) in lst + do (modify-syntax-entry char entry st)) + st) + "Syntax table used in `apples-mode'.") + +(defun apples-applescript-version () + "Return AppleScript's version." + (unless (apples-plist-get :AS-version) + (let ((ver (with-temp-buffer + (when (= (call-process "osascript" nil (current-buffer) t + "-e" "AppleScript's version") + 0) + (apples-buffer-string))))) + (apples-plist-put :AS-version ver) + ver))) +(apples-define-show-func applescript-version (apples-plist-get :AS-version)) + +(defun apples-customize-group () + (interactive) + (customize-group "apples")) + +(defun apples-visit-project () + (interactive) + (browse-url "http://github.com/tequilasunset/apples-mode")) + +(defvar apples-imenu-generic-expression + (nreverse + (mapcar (lambda (pair) + `(,(car pair) + ,(concat "^\\s-*" (apples-replace-re-comma->spaces (cdr pair))) + 1)) + '(("Handlers" . "\\(?:on\\|to\\),\\(.+\\)$" ) + ("Tells" . "tell,\\(.+\\)$" ) + ("Variables" . "set,\\(.+\\),to" ) + ))) + "Imenu index pattern for AppleScript. See also `imenu-generic-expression'.") + + +;;; Major mode + +;;;###autoload +(defun apples-mode () + "Happy AppleScripting!" + (interactive) + (kill-all-local-variables) + (apples-applescript-version) + (apples-tmp-files-setup) + (apples-error-overlay-setup) + (apples-end-completion-hl-setup) + ;; map and table + (apples-keymap-setup) + (use-local-map apples-mode-map) + (set-syntax-table apples-mode-syntax-table) + (when apples-underline-syntax-class + (modify-syntax-entry ?_ apples-underline-syntax-class apples-mode-syntax-table)) + ;; local variables + (setq major-mode 'apples-mode + mode-name "AppleScript" + font-lock-defaults '(apples-font-lock-keywords) + paragraph-separate "[ \t\n\f]*$" + paragraph-start "[ \t\n\f]*$" + comment-start "-- " + comment-end "" + comment-start-skip "\\(?:#\\|---*\\|(\\*\\)+[ \t]*" + comment-column 40 + indent-line-function 'apples-indent-line + imenu-generic-expression apples-imenu-generic-expression + ) + (run-mode-hooks 'apples-mode-hook)) + +(provide 'apples-mode) +;;; apples-mode.el ends here diff --git a/elpa/apples-mode-20110120.2018/apples-mode/comment b/elpa/apples-mode-20110120.2018/apples-mode/comment new file mode 100644 index 00000000..d3e9f366 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/comment @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: comment +# -- +(* +$0 +*) \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/considering b/elpa/apples-mode-20110120.2018/apples-mode/considering new file mode 100644 index 00000000..2abb8ffe --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/considering @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: considering +# -- +considering $1 +$0 +end considering \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/considering-application-responses b/elpa/apples-mode-20110120.2018/apples-mode/considering-application-responses new file mode 100644 index 00000000..36e6db1f --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/considering-application-responses @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: considering-application-responses +# -- +considering application responses +$0 +end considering \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/display-dialog b/elpa/apples-mode-20110120.2018/apples-mode/display-dialog new file mode 100644 index 00000000..ee84626a --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/display-dialog @@ -0,0 +1,4 @@ +# -*- mode: snippet -*- +# name: display-dialog +# -- +display dialog "$0" \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/if b/elpa/apples-mode-20110120.2018/apples-mode/if new file mode 100644 index 00000000..404a3587 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/if @@ -0,0 +1,8 @@ +# -*- mode: snippet -*- +# name: if +# -- +if $1 then +$2 +else +$0 +end if \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/ignoring b/elpa/apples-mode-20110120.2018/apples-mode/ignoring new file mode 100644 index 00000000..8dd8e039 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/ignoring @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: ignoring +# -- +ignoring $1 +$0 +end ignoring \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/ignoring-application-responses b/elpa/apples-mode-20110120.2018/apples-mode/ignoring-application-responses new file mode 100644 index 00000000..4624d818 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/ignoring-application-responses @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: ignoring-application-responses +# -- +ignoring application responses +$0 +end ignoring \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/on b/elpa/apples-mode-20110120.2018/apples-mode/on new file mode 100644 index 00000000..81db8dc0 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/on @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: on +# -- +on $1 +$0 +end $1 \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/repeat b/elpa/apples-mode-20110120.2018/apples-mode/repeat new file mode 100644 index 00000000..fb9ab59d --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/repeat @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: repeat +# -- +repeat $1 +$0 +end repeat \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/repeat-until b/elpa/apples-mode-20110120.2018/apples-mode/repeat-until new file mode 100644 index 00000000..dd155685 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/repeat-until @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: repeat-until +# -- +repeat until $1 +$0 +end repeat \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/repeat-while b/elpa/apples-mode-20110120.2018/apples-mode/repeat-while new file mode 100644 index 00000000..97daf987 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/repeat-while @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: repeat-while +# -- +repeat while $1 +$0 +end repeat \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/repeat-with b/elpa/apples-mode-20110120.2018/apples-mode/repeat-with new file mode 100644 index 00000000..e672d98b --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/repeat-with @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: repeat-with +# -- +repeat with $1 +$0 +end repeat \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/tell-application b/elpa/apples-mode-20110120.2018/apples-mode/tell-application new file mode 100644 index 00000000..b3913852 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/tell-application @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: tell-application +# -- +tell application "$1" +$0 +end tell \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/tell-application-to-activate b/elpa/apples-mode-20110120.2018/apples-mode/tell-application-to-activate new file mode 100644 index 00000000..c124bd09 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/tell-application-to-activate @@ -0,0 +1,5 @@ +# -*- mode: snippet -*- +# name: tell-application-to-activate +# -- +tell application "$1" to activate +$0 \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/try b/elpa/apples-mode-20110120.2018/apples-mode/try new file mode 100644 index 00000000..42130890 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/try @@ -0,0 +1,8 @@ +# -*- mode: snippet -*- +# name: try +# -- +try +$1 +on error $2 +$0 +end try \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/using-terms-from-application b/elpa/apples-mode-20110120.2018/apples-mode/using-terms-from-application new file mode 100644 index 00000000..2b1128ba --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/using-terms-from-application @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: using-terms-from-application +# -- +using terms from application "$1" +$0 +end using terms from \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/with-timeout-of-seconds b/elpa/apples-mode-20110120.2018/apples-mode/with-timeout-of-seconds new file mode 100644 index 00000000..4f56eb58 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/with-timeout-of-seconds @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: with-timeout-of-seconds +# -- +with timeout of $1 seconds +$0 +end timeout \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-mode/with-transaction b/elpa/apples-mode-20110120.2018/apples-mode/with-transaction new file mode 100644 index 00000000..c675d3b2 --- /dev/null +++ b/elpa/apples-mode-20110120.2018/apples-mode/with-transaction @@ -0,0 +1,6 @@ +# -*- mode: snippet -*- +# name: with-transaction +# -- +with transaction +$0 +end transaction \ No newline at end of file diff --git a/elpa/apples-mode-20110120.2018/apples-tmp-dir/apples-tmp--1713.applescript b/elpa/apples-mode-20110120.2018/apples-tmp-dir/apples-tmp--1713.applescript new file mode 100644 index 00000000..e69de29b diff --git a/elpa/apples-mode-20110120.2018/apples-tmp-dir/apples-tmp-scratch.applescript b/elpa/apples-mode-20110120.2018/apples-tmp-dir/apples-tmp-scratch.applescript new file mode 100644 index 00000000..e69de29b diff --git a/elpa/apples-mode-20110120.2018/apples-tmp-dir/apples-tmp-send.applescript b/elpa/apples-mode-20110120.2018/apples-tmp-dir/apples-tmp-send.applescript new file mode 100644 index 00000000..e69de29b diff --git a/elpa/apples-mode-readme.txt b/elpa/apples-mode-readme.txt new file mode 100644 index 00000000..e2a9bdc8 --- /dev/null +++ b/elpa/apples-mode-readme.txt @@ -0,0 +1,29 @@ +This program provides a major mode for AppleScript. + +[INSTALL] + +Put files in your load-path and add the following to your init file. + + (autoload 'apples-mode "apples-mode" "Happy AppleScripting!" t) + (autoload 'apples-open-scratch "apples-mode" "Open scratch buffer for AppleScript." t) + (add-to-list 'auto-mode-alist '("\\.\\(applescri\\|sc\\)pt\\'" . apples-mode)) +or + (require 'apples-mode) + (add-to-list 'auto-mode-alist '("\\.\\(applescri\\|sc\\)pt\\'" . apples-mode)) + +After that you should byte-compile apples-mode.el. + + M-x byte-compile-file RET /path/to/apples-mode.el RET + +During the byte-compilation, you may get some warnings, but you should +ignore them. + +[FEATURES] + +Commands for the execution have the prefix `apples-run-'. You can see +the other features via menu. + +[CONFIGURATION] + +You can access to the customize group via menu or using the command +`apples-customize-group'. diff --git a/elpa/async-20161103.1036/async-autoloads.el b/elpa/async-20170916.2256/async-autoloads.el similarity index 94% rename from elpa/async-20161103.1036/async-autoloads.el rename to elpa/async-20170916.2256/async-autoloads.el index 3f680392..ff846532 100644 --- a/elpa/async-20161103.1036/async-autoloads.el +++ b/elpa/async-20170916.2256/async-autoloads.el @@ -3,7 +3,7 @@ ;;; Code: (add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path)))) -;;;### (autoloads nil "async" "async.el" (22576 8239 0 0)) +;;;### (autoloads nil "async" "async.el" (22975 34388 0 0)) ;;; Generated autoloads from async.el (autoload 'async-start-process "async" "\ @@ -68,8 +68,8 @@ returns nil. It can still be useful, however, as an argument to ;;;*** -;;;### (autoloads nil "async-bytecomp" "async-bytecomp.el" (22576 -;;;;;; 8239 0 0)) +;;;### (autoloads nil "async-bytecomp" "async-bytecomp.el" (22975 +;;;;;; 34388 0 0)) ;;; Generated autoloads from async-bytecomp.el (autoload 'async-byte-recompile-directory "async-bytecomp" "\ @@ -97,7 +97,7 @@ Async compilation of packages can be controlled by ;;;*** -;;;### (autoloads nil "dired-async" "dired-async.el" (22576 8239 +;;;### (autoloads nil "dired-async" "dired-async.el" (22975 34388 ;;;;;; 0 0)) ;;; Generated autoloads from dired-async.el @@ -118,8 +118,8 @@ Do dired actions asynchronously. ;;;*** -;;;### (autoloads nil nil ("async-pkg.el" "smtpmail-async.el") (22576 -;;;;;; 8239 0 0)) +;;;### (autoloads nil nil ("async-pkg.el" "smtpmail-async.el") (22975 +;;;;;; 34388 0 0)) ;;;*** diff --git a/elpa/async-20161103.1036/async-bytecomp.el b/elpa/async-20170916.2256/async-bytecomp.el similarity index 100% rename from elpa/async-20161103.1036/async-bytecomp.el rename to elpa/async-20170916.2256/async-bytecomp.el diff --git a/elpa/async-20161103.1036/async-pkg.el b/elpa/async-20170916.2256/async-pkg.el similarity index 68% rename from elpa/async-20161103.1036/async-pkg.el rename to elpa/async-20170916.2256/async-pkg.el index 239d8870..70f61053 100644 --- a/elpa/async-20161103.1036/async-pkg.el +++ b/elpa/async-20170916.2256/async-pkg.el @@ -1,4 +1,4 @@ -(define-package "async" "20161103.1036" "Asynchronous processing in Emacs" 'nil :keywords +(define-package "async" "20170916.2256" "Asynchronous processing in Emacs" 'nil :keywords '("async") :url "https://github.com/jwiegley/emacs-async") ;; Local Variables: diff --git a/elpa/async-20161103.1036/async.el b/elpa/async-20170916.2256/async.el similarity index 93% rename from elpa/async-20161103.1036/async.el rename to elpa/async-20170916.2256/async.el index 0bb45fab..c1fb40bf 100644 --- a/elpa/async-20161103.1036/async.el +++ b/elpa/async-20170916.2256/async.el @@ -4,7 +4,7 @@ ;; Author: John Wiegley ;; Created: 18 Jun 2012 -;; Version: 1.9 +;; Version: 1.9.2 ;; Keywords: async ;; X-URL: https://github.com/jwiegley/emacs-async @@ -169,24 +169,32 @@ as follows: (prin1 (list 'async-signal err))))))) (defun async-ready (future) - "Query a FUTURE to see if the ready is ready -- i.e., if no blocking + "Query a FUTURE to see if it is ready. + +I.e., if no blocking would result from a call to `async-get' on that FUTURE." (and (memq (process-status future) '(exit signal)) - (with-current-buffer (process-buffer future) - async-callback-value-set))) + (let ((buf (process-buffer future))) + (if (buffer-live-p buf) + (with-current-buffer buf + async-callback-value-set) + t)))) (defun async-wait (future) "Wait for FUTURE to become ready." (while (not (async-ready future)) - (sit-for 0.05))) + (sleep-for 0.05))) (defun async-get (future) - "Get the value from an asynchronously function when it is ready. + "Get the value from process FUTURE when it is ready. FUTURE is returned by `async-start' or `async-start-process' when its FINISH-FUNC is nil." - (async-wait future) - (with-current-buffer (process-buffer future) - (async-handle-result #'identity async-callback-value (current-buffer)))) + (and future (async-wait future)) + (let ((buf (process-buffer future))) + (when (buffer-live-p buf) + (with-current-buffer buf + (async-handle-result + #'identity async-callback-value (current-buffer)))))) (defun async-message-p (value) "Return true of VALUE is an async.el message packet." @@ -223,6 +231,12 @@ working directory." (set (make-local-variable 'async-callback-for-process) t)) proc))) +(defvar async-quiet-switch "-Q" + "The Emacs parameter to use to call emacs without config. +Can be one of \"-Q\" or \"-q\". +Default is \"-Q\" but it is sometimes useful to use \"-q\" to have a +enhanced config or some more variables loaded.") + ;;;###autoload (defun async-start (start-func &optional finish-func) "Execute START-FUNC (often a lambda) in a subordinate Emacs process. @@ -280,7 +294,7 @@ returns nil. It can still be useful, however, as an argument to (expand-file-name invocation-name invocation-directory)) finish-func - "-Q" "-l" + async-quiet-switch "-l" ;; Using `locate-library' ensure we use the right file ;; when the .elc have been deleted. (locate-library "async") diff --git a/elpa/async-20161103.1036/dired-async.el b/elpa/async-20170916.2256/dired-async.el similarity index 88% rename from elpa/async-20161103.1036/dired-async.el rename to elpa/async-20170916.2256/dired-async.el index ed379535..485786c9 100644 --- a/elpa/async-20161103.1036/dired-async.el +++ b/elpa/async-20170916.2256/dired-async.el @@ -66,6 +66,14 @@ Should take same args as `message'." :group 'dired-async :type 'string) +(defcustom dired-async-mode-lighter '(:eval + (when (eq major-mode 'dired-mode) + " Async")) + "Mode line lighter used for `dired-async-mode'." + :group 'dired-async + :risky t + :type 'sexp) + (defface dired-async-message '((t (:foreground "yellow"))) "Face used for mode-line message." @@ -177,11 +185,13 @@ Should take same args as `message'." See `dired-create-files' for the behavior of arguments." (setq overwrite-query nil) (let ((total (length fn-list)) - failures async-fn-list skipped callback) + failures async-fn-list skipped callback + async-quiet-switch) (let (to) (dolist (from fn-list) (setq to (funcall name-constructor from)) - (if (equal to from) + (if (and (equal to from) + (null (eq file-creator 'backup-file))) (progn (setq to nil) (dired-log "Cannot %s to same file: %s\n" @@ -232,6 +242,13 @@ ESC or `q' to not overwrite any of the remaining files, (dired-log "%s `%s' to `%s' failed\n" operation from to))) (push (cons from to) async-fn-list))))) + ;; Fix tramp issue #80 with emacs-26, use "-q" only when needed. + (setq async-quiet-switch + (if (and (boundp 'tramp-cache-read-persistent-data) + async-fn-list + (cl-loop for (from . to) in async-fn-list + thereis (file-remote-p to))) + "-q" "-Q")) ;; When failures have been printed to dired log add the date at bob. (when (or failures skipped) (dired-log t)) ;; When async-fn-list is empty that's mean only one file @@ -275,7 +292,7 @@ ESC or `q' to not overwrite any of the remaining files, ;; Inline `backup-file' as long as it is not ;; available in emacs. (defalias 'backup-file - ;; Same feature as "cp --backup=numbered from to" + ;; Same feature as "cp -f --backup=numbered from to" ;; Symlinks are copied as file from source unlike ;; `dired-copy-file' which is same as cp -d. ;; Directories are omitted. @@ -310,22 +327,40 @@ ESC or `q' to not overwrite any of the remaining files, (dired-async--modeline-mode 1) (message "%s proceeding asynchronously..." operation)))) +(defvar wdired-use-interactive-rename) +(defun dired-async-wdired-do-renames (old-fn &rest args) + ;; Perhaps a better fix would be to ask for renaming BEFORE starting + ;; OLD-FN when `wdired-use-interactive-rename' is non-nil. For now + ;; just bind it to nil to ensure no questions will be asked between + ;; each rename. + (let (wdired-use-interactive-rename) + (apply old-fn args))) + +(defadvice wdired-do-renames (around wdired-async) + (let (wdired-use-interactive-rename) + ad-do-it)) + (defadvice dired-create-files (around dired-async) (dired-async-create-files file-creator operation fn-list name-constructor marker-char)) ;;;###autoload (define-minor-mode dired-async-mode - "Do dired actions asynchronously." + "Do dired actions asynchronously." :group 'dired-async + :lighter dired-async-mode-lighter :global t (if dired-async-mode (if (fboundp 'advice-add) - (advice-add 'dired-create-files :override #'dired-async-create-files) - (ad-activate 'dired-create-files)) + (progn (advice-add 'dired-create-files :override #'dired-async-create-files) + (advice-add 'wdired-do-renames :around #'dired-async-wdired-do-renames)) + (ad-activate 'dired-create-files) + (ad-activate 'wdired-do-renames)) (if (fboundp 'advice-remove) - (advice-remove 'dired-create-files #'dired-async-create-files) - (ad-deactivate 'dired-create-files)))) + (progn (advice-remove 'dired-create-files #'dired-async-create-files) + (advice-remove 'wdired-do-renames #'dired-async-wdired-do-renames)) + (ad-deactivate 'dired-create-files) + (ad-deactivate 'wdired-do-renames)))) (provide 'dired-async) diff --git a/elpa/async-20161103.1036/smtpmail-async.el b/elpa/async-20170916.2256/smtpmail-async.el similarity index 98% rename from elpa/async-20161103.1036/smtpmail-async.el rename to elpa/async-20170916.2256/smtpmail-async.el index 6fcf287f..ac269231 100644 --- a/elpa/async-20161103.1036/smtpmail-async.el +++ b/elpa/async-20170916.2256/smtpmail-async.el @@ -61,7 +61,7 @@ It is called just before calling `smtpmail-send-it'.") (set-buffer-multibyte nil) ;; Pass in the variable environment for smtpmail ,(async-inject-variables - "\\`\\(smtpmail\\|async-smtpmail\\|\\(user-\\)?mail\\)-\\|auth-sources\\|epg" + "\\`\\(smtpmail\\|async-smtpmail\\|\\(user-\\)?mail\\)-\\|auth-sources\\|epg\\|nsm" nil "\\`\\(mail-header-format-function\\|smtpmail-address-buffer\\|mail-mode-abbrev-table\\)") (run-hooks 'async-smtpmail-before-send-hook) (smtpmail-send-it))) diff --git a/elpa/cider-20170129.1941/cider-apropos.el b/elpa/cider-20170129.1941/cider-apropos.el new file mode 100644 index 00000000..74d00860 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-apropos.el @@ -0,0 +1,203 @@ +;;; cider-apropos.el --- Apropos functionality for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2014-2017 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 'subr-x) +(require 'cider-compat) + +(require 'cider-client) +(require 'cider-popup) +(require 'nrepl-dict) + +(require 'clojure-mode) +(require 'apropos) +(require 'button) + +(defconst cider-apropos-buffer "*cider-apropos*") + +(push cider-apropos-buffer cider-ancillary-buffers) + +(defcustom cider-apropos-actions '(("display-doc" . cider-doc-lookup) + ("find-def" . cider--find-var) + ("lookup-on-grimoire" . cider-grimoire-lookup)) + "Controls the actions to be applied on the symbol found by an apropos search. +The first action key in the list will be selected as default. If the list +contains only one action key, the associated action function will be +applied automatically. An action function can be any function that receives +the symbol found by the apropos search as argument." + :type '(alist :key-type string :value-type function) + :group 'cider + :package-version '(cider . "0.13.0")) + +(defun cider-apropos-doc (button) + "Display documentation for the symbol represented at BUTTON." + (cider-doc-lookup (button-get button 'apropos-symbol))) + +(defun cider-apropos-summary (query ns docs-p include-private-p case-sensitive-p) + "Return a short description for the performed apropos search. + +QUERY can be a regular expression list of space-separated words +\(e.g take while) which will be converted to a regular expression +\(like take.+while) automatically behind the scenes. The search may be +limited to the namespace NS, and may optionally search doc strings +\(based on DOCS-P), include private vars (based on INCLUDE-PRIVATE-P), +and be case-sensitive (based on CASE-SENSITIVE-P)." + (concat (if case-sensitive-p "Case-sensitive " "") + (if docs-p "Documentation " "") + (format "Apropos for %S" query) + (if ns (format " in namespace %S" ns) "") + (if include-private-p + " (public and private symbols)" + " (public symbols only)"))) + +(defun cider-apropos-highlight (doc query) + "Return the DOC string propertized to highlight QUERY matches." + (let ((pos 0)) + (while (string-match query doc pos) + (setq pos (match-end 0)) + (put-text-property (match-beginning 0) + (match-end 0) + 'font-lock-face apropos-match-face doc))) + doc) + +(defun cider-apropos-result (result query docs-p) + "Emit a RESULT matching QUERY into current buffer, formatted for DOCS-P." + (nrepl-dbind-response result (name type doc) + (let* ((label (capitalize (if (string= type "variable") "var" type))) + (help (concat "Display doc for this " (downcase label)))) + (cider-propertize-region (list 'apropos-symbol name + 'action 'cider-apropos-doc + 'help-echo help) + (insert-text-button name 'type 'apropos-symbol) + (insert "\n ") + (insert-text-button label 'type (intern (concat "apropos-" type))) + (insert ": ") + (let ((beg (point))) + (if docs-p + (insert (cider-apropos-highlight doc query) "\n") + (insert doc) + (fill-region beg (point)))) + (insert "\n"))))) + +(declare-function cider-mode "cider-mode") + +(defun cider-show-apropos (summary results query docs-p) + "Show SUMMARY and RESULTS for QUERY in a pop-up buffer, formatted for DOCS-P." + (with-current-buffer (cider-popup-buffer cider-apropos-buffer t) + (let ((inhibit-read-only t)) + (apropos-mode) + (if (boundp 'header-line-format) + (setq-local header-line-format summary) + (insert summary "\n\n")) + (dolist (result results) + (cider-apropos-result result query docs-p)) + (goto-char (point-min))))) + +;;;###autoload +(defun cider-apropos (query &optional ns docs-p privates-p case-sensitive-p) + "Show all symbols whose names match QUERY, a regular expression. +QUERY can also be a list of space-separated words (e.g. take while) which +will be converted to a regular expression (like take.+while) automatically +behind the scenes. The search may be limited to the namespace NS, and may +optionally search doc strings (based on DOCS-P), include private vars +\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P)." + (interactive + (cons (read-string "Search for Clojure symbol (a regular expression): ") + (when current-prefix-arg + (list (let ((ns (completing-read "Namespace (default is all): " (cider-sync-request:ns-list)))) + (if (string= ns "") nil ns)) + (y-or-n-p "Search doc strings? ") + (y-or-n-p "Include private symbols? ") + (y-or-n-p "Case-sensitive? "))))) + (cider-ensure-connected) + (cider-ensure-op-supported "apropos") + (if-let ((summary (cider-apropos-summary + query ns docs-p privates-p case-sensitive-p)) + (results (cider-sync-request:apropos query ns docs-p privates-p case-sensitive-p))) + (cider-show-apropos summary results query docs-p) + (message "No apropos matches for %S" query))) + +;;;###autoload +(defun cider-apropos-documentation () + "Shortcut for (cider-apropos 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-20170129.1941/cider-autoloads.el b/elpa/cider-20170129.1941/cider-autoloads.el new file mode 100644 index 00000000..3bec2d92 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-autoloads.el @@ -0,0 +1,326 @@ +;;; cider-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path)))) + +;;;### (autoloads nil "cider" "cider.el" (22692 30287 0 0)) +;;; Generated autoloads from cider.el + +(autoload 'cider-version "cider" "\ +Display CIDER's version. + +\(fn)" t nil) + +(autoload 'cider-jack-in "cider" "\ +Start an nREPL server for the current project and connect to it. +If PROMPT-PROJECT is t, then prompt for the project for which to +start the server. +If CLJS-TOO is non-nil, also start a ClojureScript REPL session with its +own buffer. + +\(fn &optional PROMPT-PROJECT CLJS-TOO)" t nil) + +(autoload 'cider-jack-in-clojurescript "cider" "\ +Start an nREPL server and connect to it both Clojure and ClojureScript REPLs. +If PROMPT-PROJECT is t, then prompt for the project for which to +start the server. + +\(fn &optional PROMPT-PROJECT)" t nil) + +(autoload 'cider-connect "cider" "\ +Connect to an nREPL server identified by HOST and PORT. +Create REPL buffer and start an nREPL client connection. + +When the optional param PROJECT-DIR is present, the connection +gets associated with it. + +\(fn HOST PORT &optional PROJECT-DIR)" t nil) + +(eval-after-load 'clojure-mode '(progn (define-key clojure-mode-map (kbd "C-c M-j") #'cider-jack-in) (define-key clojure-mode-map (kbd "C-c M-J") #'cider-jack-in-clojurescript) (define-key clojure-mode-map (kbd "C-c M-c") #'cider-connect))) + +;;;*** + +;;;### (autoloads nil "cider-apropos" "cider-apropos.el" (22692 30287 +;;;;;; 0 0)) +;;; Generated autoloads from cider-apropos.el + +(autoload 'cider-apropos "cider-apropos" "\ +Show all symbols whose names match QUERY, a regular expression. +QUERY can also be a list of space-separated words (e.g. take while) which +will be converted to a regular expression (like take.+while) automatically +behind the scenes. The search may be limited to the namespace NS, and may +optionally search doc strings (based on DOCS-P), include private vars +\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P). + +\(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t nil) + +(autoload 'cider-apropos-documentation "cider-apropos" "\ +Shortcut for (cider-apropos 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" (22692 +;;;;;; 30287 0 0)) +;;; Generated autoloads from cider-browse-ns.el + +(autoload 'cider-browse-ns "cider-browse-ns" "\ +List all NAMESPACE's vars in BUFFER. + +\(fn NAMESPACE)" t nil) + +(autoload 'cider-browse-ns-all "cider-browse-ns" "\ +List all loaded namespaces in BUFFER. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-classpath" "cider-classpath.el" (22692 +;;;;;; 30287 0 0)) +;;; Generated autoloads from cider-classpath.el + +(autoload 'cider-classpath "cider-classpath" "\ +List all classpath entries. + +\(fn)" t nil) + +(autoload 'cider-open-classpath-entry "cider-classpath" "\ +Open a classpath entry. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-debug" "cider-debug.el" (22692 30287 +;;;;;; 0 0)) +;;; Generated autoloads from cider-debug.el + +(autoload 'cider-debug-defun-at-point "cider-debug" "\ +Instrument the \"top-level\" expression at point. +If it is a defn, dispatch the instrumented definition. Otherwise, +immediately evaluate the instrumented expression. + +While debugged code is being evaluated, the user is taken through the +source code and displayed the value of various expressions. At each step, +a number of keys will be prompted to the user. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-grimoire" "cider-grimoire.el" (22692 +;;;;;; 30287 0 0)) +;;; Generated autoloads from cider-grimoire.el + +(autoload 'cider-grimoire-web "cider-grimoire" "\ +Open grimoire documentation in the default web browser. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates. + +\(fn &optional ARG)" t nil) + +(autoload 'cider-grimoire "cider-grimoire" "\ +Open grimoire documentation in a popup buffer. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates. + +\(fn &optional ARG)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-inspector" "cider-inspector.el" (22692 +;;;;;; 30287 0 0)) +;;; Generated autoloads from cider-inspector.el + +(autoload 'cider-inspect-last-sexp "cider-inspector" "\ +Inspect the result of the the expression preceding point. + +\(fn)" t nil) + +(autoload 'cider-inspect-defun-at-point "cider-inspector" "\ +Inspect the result of the \"top-level\" expression at point. + +\(fn)" t nil) + +(autoload 'cider-inspect-last-result "cider-inspector" "\ +Inspect the most recent eval result. + +\(fn)" t nil) + +(autoload 'cider-inspect "cider-inspector" "\ +Inspect the result of the preceding sexp. + +With a prefix argument ARG it inspects the result of the \"top-level\" form. +With a second prefix argument it prompts for an expression to eval and inspect. + +\(fn &optional ARG)" t nil) + +(autoload 'cider-inspect-expr "cider-inspector" "\ +Evaluate EXPR in NS and inspect its value. +Interactively, EXPR is read from the minibuffer, and NS the +current buffer's namespace. + +\(fn EXPR NS)" t nil) + +(define-obsolete-function-alias 'cider-inspect-read-and-inspect 'cider-inspect-expr "0.13.0") + +;;;*** + +;;;### (autoloads nil "cider-macroexpansion" "cider-macroexpansion.el" +;;;;;; (22692 30287 0 0)) +;;; Generated autoloads from cider-macroexpansion.el + +(autoload 'cider-macroexpand-1 "cider-macroexpansion" "\ +Invoke \\=`macroexpand-1\\=` on the expression preceding point. +If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of +\\=`macroexpand-1\\=`. + +\(fn &optional PREFIX)" t nil) + +(autoload 'cider-macroexpand-all "cider-macroexpansion" "\ +Invoke \\=`clojure.walk/macroexpand-all\\=` on the expression preceding point. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-mode" "cider-mode.el" (22692 30287 0 +;;;;;; 0)) +;;; Generated autoloads from cider-mode.el + +(defvar cider-mode-line '(:eval (format " cider[%s]" (cider--modeline-info))) "\ +Mode line lighter for `cider-mode'. + +The value of this variable is a mode line template as in +`mode-line-format'. See Info Node `(elisp)Mode Line Format' for +details about mode line templates. + +Customize this variable to change how `cider-mode' displays its +status in the mode line. The default value displays the current connection. +Set this variable to nil to disable the mode line +entirely.") + +(custom-autoload 'cider-mode-line "cider-mode" t) + +(eval-after-load 'clojure-mode '(easy-menu-define cider-clojure-mode-menu-open clojure-mode-map "Menu for Clojure mode.\n This is displayed in `clojure-mode' buffers, if `cider-mode' is not active." `("CIDER" :visible (not cider-mode) ["Start a REPL" cider-jack-in :help "Starts an nREPL server (with lein, boot, or maven) and connects a REPL to it."] ["Connect to a REPL" cider-connect :help "Connects to a REPL that's already running."] ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clojurescript :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL.\n Configure `cider-cljs-lein-repl', `cider-cljs-boot-repl' and `cider-cljs-gradle-repl' to change the ClojureScript REPL to use."] "--" ["View manual online" cider-view-manual]))) + +(autoload 'cider-mode "cider-mode" "\ +Minor mode for REPL interaction from a Clojure buffer. + +\\{cider-mode-map} + +\(fn &optional ARG)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-repl-history" "cider-repl-history.el" +;;;;;; (22692 30287 0 0)) +;;; Generated autoloads from cider-repl-history.el + +(autoload 'cider-repl-history "cider-repl-history" "\ +Display items in the CIDER command history in another buffer. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-scratch" "cider-scratch.el" (22692 30287 +;;;;;; 0 0)) +;;; Generated autoloads from cider-scratch.el + +(autoload 'cider-scratch "cider-scratch" "\ +Go to the scratch buffer named `cider-scratch-buffer-name'. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-selector" "cider-selector.el" (22692 +;;;;;; 30287 0 0)) +;;; Generated autoloads from cider-selector.el + +(autoload 'cider-selector "cider-selector" "\ +Select a new buffer by type, indicated by a single character. +The user is prompted for a single character indicating the method by +which to choose a new buffer. The `?' character describes then +available methods. OTHER-WINDOW provides an optional target. + +See `def-cider-selector-method' for defining new methods. + +\(fn &optional OTHER-WINDOW)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-test" "cider-test.el" (22692 30287 0 +;;;;;; 0)) +;;; Generated autoloads from cider-test.el + +(defvar cider-auto-test-mode nil "\ +Non-nil if Cider-Auto-Test mode is enabled. +See the `cider-auto-test-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `cider-auto-test-mode'.") + +(custom-autoload 'cider-auto-test-mode "cider-test" nil) + +(autoload 'cider-auto-test-mode "cider-test" "\ +Toggle automatic testing of Clojure files. + +When enabled this reruns tests every time a Clojure file is loaded. +Only runs tests corresponding to the loaded file's namespace and does +nothing if no tests are defined or if the file failed to load. + +\(fn &optional ARG)" t nil) + +;;;*** + +;;;### (autoloads nil "cider-util" "cider-util.el" (22692 30287 0 +;;;;;; 0)) +;;; Generated autoloads from cider-util.el + +(autoload 'cider-view-manual "cider-util" "\ +View the manual in your default browser. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil nil ("cider-client.el" "cider-common.el" "cider-compat.el" +;;;;;; "cider-doc.el" "cider-eldoc.el" "cider-interaction.el" "cider-overlays.el" +;;;;;; "cider-pkg.el" "cider-popup.el" "cider-repl.el" "cider-resolve.el" +;;;;;; "cider-stacktrace.el" "nrepl-client.el" "nrepl-dict.el") +;;;;;; (22692 30287 0 0)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; cider-autoloads.el ends here diff --git a/elpa/cider-20170129.1941/cider-browse-ns.el b/elpa/cider-20170129.1941/cider-browse-ns.el new file mode 100644 index 00000000..b142ecfe --- /dev/null +++ b/elpa/cider-20170129.1941/cider-browse-ns.el @@ -0,0 +1,221 @@ +;;; cider-browse-ns.el --- CIDER namespace browser + +;; Copyright © 2014-2017 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 'subr-x) +(require 'cider-compat) +(require 'cider-util) +(require 'nrepl-dict) + +(defconst cider-browse-ns-buffer "*cider-ns-browser*") + +(push cider-browse-ns-buffer cider-ancillary-buffers) + +(defvar-local cider-browse-ns-current-ns nil) + +;; Mode Definition + +(defvar cider-browse-ns-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map cider-popup-buffer-mode-map) + (define-key map "d" #'cider-browse-ns-doc-at-point) + (define-key map "s" #'cider-browse-ns-find-at-point) + (define-key map (kbd "RET") #'cider-browse-ns-operate-at-point) + (define-key map "^" #'cider-browse-ns-all) + (define-key map "n" #'next-line) + (define-key map "p" #'previous-line) + map)) + +(defvar cider-browse-ns-mouse-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] #'cider-browse-ns-handle-mouse) + map)) + +(define-derived-mode cider-browse-ns-mode special-mode "browse-ns" + "Major mode for browsing Clojure namespaces. + +\\{cider-browse-ns-mode-map}" + (setq buffer-read-only t) + (setq-local electric-indent-chars nil) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t)) + (setq-local cider-browse-ns-current-ns nil)) + +(defun cider-browse-ns--text-face (var-meta) + "Return font-lock-face for a var. +VAR-META contains the metadata information used to decide a face. +Presence of \"arglists-str\" and \"macro\" indicates a macro form. +Only \"arglists-str\" indicates a function. Otherwise, its a variable. +If the NAMESPACE is not loaded in the REPL, assume TEXT is a fn." + (cond + ((not var-meta) 'font-lock-function-name-face) + ((and (nrepl-dict-contains var-meta "arglists") + (string= (nrepl-dict-get var-meta "macro") "true")) + 'font-lock-keyword-face) + ((nrepl-dict-contains var-meta "arglists") 'font-lock-function-name-face) + (t 'font-lock-variable-name-face))) + +(defun cider-browse-ns--properties (var var-meta) + "Decorate VAR with a clickable keymap and a face. +VAR-META is used to decide a font-lock face." + (let ((face (cider-browse-ns--text-face var-meta))) + (propertize var + 'font-lock-face face + 'mouse-face 'highlight + 'keymap cider-browse-ns-mouse-map))) + +(defun cider-browse-ns--list (buffer title items &optional ns noerase) + "Reset contents of BUFFER. +Display TITLE at the top and ITEMS are indented underneath. +If NS is non-nil, it is added to each item as the +`cider-browse-ns-current-ns' text property. If NOERASE is non-nil, the +contents of the buffer are not reset before inserting TITLE and ITEMS." + (with-current-buffer buffer + (cider-browse-ns-mode) + (let ((inhibit-read-only t)) + (unless noerase (erase-buffer)) + (goto-char (point-max)) + (insert (cider-propertize title 'ns) "\n") + (dolist (item items) + (insert (propertize (concat " " item "\n") + 'cider-browse-ns-current-ns ns))) + (goto-char (point-min))))) + +(defun cider-browse-ns--first-doc-line (doc) + "Return the first line of the given DOC string. +If the first line of the DOC string contains multiple sentences, only +the first sentence is returned. If the DOC string is nil, a Not documented +string is returned." + (if doc + (let* ((split-newline (split-string doc "\n")) + (first-line (car split-newline))) + (cond + ((string-match "\\. " first-line) (substring first-line 0 (match-end 0))) + ((= 1 (length split-newline)) first-line) + (t (concat first-line "...")))) + "Not documented.")) + +(defun cider-browse-ns--items (namespace) + "Return the items to show in the namespace browser of the given NAMESPACE. +Each item consists of a ns-var and the first line of its docstring." + (let* ((ns-vars-with-meta (cider-sync-request:ns-vars-with-meta namespace)) + (propertized-ns-vars (nrepl-dict-map #'cider-browse-ns--properties ns-vars-with-meta))) + (mapcar (lambda (ns-var) + (let* ((doc (nrepl-dict-get-in ns-vars-with-meta (list ns-var "doc"))) + ;; to avoid (read nil) + ;; it prompts the user for a Lisp expression + (doc (when doc (read doc))) + (first-doc-line (cider-browse-ns--first-doc-line doc))) + (concat ns-var " " (propertize first-doc-line 'font-lock-face 'font-lock-doc-face)))) + propertized-ns-vars))) + +;; Interactive Functions + +;;;###autoload +(defun cider-browse-ns (namespace) + "List all NAMESPACE's vars in BUFFER." + (interactive (list (completing-read "Browse namespace: " (cider-sync-request:ns-list)))) + (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t) + (cider-browse-ns--list (current-buffer) + namespace + (cider-browse-ns--items namespace)) + (setq-local cider-browse-ns-current-ns namespace))) + +;;;###autoload +(defun cider-browse-ns-all () + "List all loaded namespaces in BUFFER." + (interactive) + (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t) + (let ((names (cider-sync-request:ns-list))) + (cider-browse-ns--list (current-buffer) + "All loaded namespaces" + (mapcar (lambda (name) + (cider-browse-ns--properties name nil)) + names)) + (setq-local cider-browse-ns-current-ns nil)))) + +(defun cider-browse-ns--thing-at-point () + "Get the thing at point. +Return a list of the type ('ns or 'var) and the value." + (let ((line (car (split-string (string-trim (thing-at-point 'line)) " ")))) + (if (string-match "\\." line) + (list 'ns line) + (list 'var (format "%s/%s" + (or (get-text-property (point) 'cider-browse-ns-current-ns) + cider-browse-ns-current-ns) + line))))) + +(defun cider-browse-ns-doc-at-point () + "Show the documentation for the thing at current point." + (interactive) + (let* ((thing (cider-browse-ns--thing-at-point)) + (value (cadr thing))) + ;; value is either some ns or a var + (cider-doc-lookup value))) + +(defun cider-browse-ns-operate-at-point () + "Expand browser according to thing at current point. +If the thing at point is a ns it will be browsed, +and if the thing at point is some var - its documentation will +be displayed." + (interactive) + (let* ((thing (cider-browse-ns--thing-at-point)) + (type (car thing)) + (value (cadr thing))) + (if (eq type 'ns) + (cider-browse-ns value) + (cider-doc-lookup value)))) + +(defun cider-browse-ns-find-at-point () + "Find the definition of the thing at point." + (interactive) + (let* ((thing (cider-browse-ns--thing-at-point)) + (type (car thing)) + (value (cadr thing))) + (if (eq type 'ns) + (cider-find-ns nil value) + (cider-find-var current-prefix-arg value)))) + +(defun cider-browse-ns-handle-mouse (event) + "Handle mouse click EVENT." + (interactive "e") + (cider-browse-ns-operate-at-point)) + +(provide 'cider-browse-ns) + +;;; cider-browse-ns.el ends here diff --git a/elpa/cider-20170129.1941/cider-classpath.el b/elpa/cider-20170129.1941/cider-classpath.el new file mode 100644 index 00000000..ea7fe8a8 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-classpath.el @@ -0,0 +1,114 @@ +;;; cider-classpath.el --- Basic Java classpath browser + +;; Copyright © 2014-2017 Bozhidar Batsov and CIDER contributors + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Basic Java classpath browser for CIDER. + +;;; Code: + +(require 'cider-client) +(require 'cider-popup) +(require 'subr-x) +(require 'cider-compat) + +(defvar cider-classpath-buffer "*cider-classpath*") + +(push cider-classpath-buffer cider-ancillary-buffers) + +(defvar cider-classpath-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map cider-popup-buffer-mode-map) + (define-key map (kbd "RET") #'cider-classpath-operate-on-point) + (define-key map "n" #'next-line) + (define-key map "p" #'previous-line) + map)) + +(defvar cider-classpath-mouse-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] #'cider-classpath-handle-mouse) + map)) + +(define-derived-mode cider-classpath-mode special-mode "classpath" + "Major mode for browsing the entries in Java's classpath. + +\\{cider-classpath-mode-map}" + (setq buffer-read-only t) + (setq-local electric-indent-chars nil) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t))) + +(defun cider-classpath-list (buffer items) + "Populate BUFFER with ITEMS." + (with-current-buffer buffer + (cider-classpath-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (dolist (item items) + (insert item "\n")) + (goto-char (point-min))))) + +(defun cider-classpath-properties (text) + "Decorate TEXT with a clickable keymap and function face." + (let ((face (cond + ((not (file-exists-p text)) 'font-lock-warning-face) + ((file-directory-p text) 'dired-directory) + (t 'default)))) + (propertize text + 'font-lock-face face + 'mouse-face 'highlight + 'keymap cider-classpath-mouse-map))) + +(defun cider-classpath-operate-on-point () + "Expand browser according to thing at current point." + (interactive) + (let* ((bol (line-beginning-position)) + (eol (line-end-position)) + (line (buffer-substring-no-properties bol eol))) + (find-file-other-window line))) + +(defun cider-classpath-handle-mouse (event) + "Handle mouse click EVENT." + (interactive "e") + (cider-classpath-operate-on-point)) + +;;;###autoload +(defun cider-classpath () + "List all classpath entries." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "classpath") + (with-current-buffer (cider-popup-buffer cider-classpath-buffer t) + (cider-classpath-list (current-buffer) + (mapcar (lambda (name) + (cider-classpath-properties name)) + (cider-sync-request:classpath))))) + +;;;###autoload +(defun cider-open-classpath-entry () + "Open a classpath entry." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "classpath") + (when-let ((entry (completing-read "Classpath entries: " (cider-sync-request:classpath)))) + (find-file-other-window entry))) + +(provide 'cider-classpath) + +;;; cider-classpath.el ends here diff --git a/elpa/cider-20170129.1941/cider-client.el b/elpa/cider-20170129.1941/cider-client.el new file mode 100644 index 00000000..f921af71 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-client.el @@ -0,0 +1,1126 @@ +;;; cider-client.el --- A layer of abstraction above the actual client code. -*- lexical-binding: t -*- + +;; Copyright © 2013-2017 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 'subr-x) +(require 'cider-compat) +(require 'seq) + +;;; Connection Buffer Management + +(defcustom cider-request-dispatch 'dynamic + "Controls the request dispatch mechanism when several connections are present. +Dynamic dispatch tries to infer the connection based on the current project +& currently visited file, while static dispatch simply uses the default +connection. + +Project metadata is attached to connections when they are created with commands +like `cider-jack-in' and `cider-connect'." + :type '(choice (const :tag "dynamic" dynamic) + (const :tag "static" static)) + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-connection-message-fn #'cider-random-words-of-inspiration + "The function to use to generate the message displayed on connect. +When set to nil no additional message will be displayed. + +A good alternative to the default is `cider-random-tip'." + :type 'function + :group 'cider + :package-version '(cider . "0.11.0")) + +(defvar cider-connections nil + "A list of connections.") + +(defun cider-connected-p () + "Return t if CIDER is currently connected, nil otherwise." + (not (null (cider-connections)))) + +(defun cider-ensure-connected () + "Ensure there is a cider connection present. +An error is signaled in the absence of a connection." + (unless (cider-connected-p) + (user-error "`%s' needs an active nREPL connection" this-command))) + +(defsubst cider--in-connection-buffer-p () + "Return non-nil if current buffer is connected to a server." + (and (derived-mode-p 'cider-repl-mode) + (process-live-p + (get-buffer-process (current-buffer))))) + +(defun cider-default-connection (&optional no-error) + "The default (fallback) connection to use for nREPL interaction. +When NO-ERROR is non-nil, don't throw an error when no connection has been +found." + (or (car (cider-connections)) + (unless no-error + (error "No nREPL connection buffer")))) + +(defun cider-connections () + "Return the list of connection buffers. +If the list is empty and buffer-local, return the global value." + (or (setq cider-connections + (seq-filter #'buffer-live-p cider-connections)) + (when (local-variable-p 'cider-connect) + (kill-local-variable 'cider-connections) + (seq-filter #'buffer-live-p cider-connections)))) + +(defun cider-repl-buffers () + "Return the list of REPL buffers." + (seq-filter + (lambda (buffer) + (with-current-buffer buffer (derived-mode-p 'cider-repl-mode))) + (buffer-list))) + +(defun cider-make-connection-default (connection-buffer) + "Make the nREPL CONNECTION-BUFFER the default connection. +Moves CONNECTION-BUFFER to the front of variable `cider-connections'." + (interactive (list (if (cider--in-connection-buffer-p) + (current-buffer) + (user-error "Not in a REPL buffer")))) + ;; maintain the connection list in most recently used order + (let ((buf (get-buffer connection-buffer))) + (setq cider-connections + (cons buf (delq buf cider-connections)))) + (cider--connections-refresh)) + +(declare-function cider--close-buffer "cider-interaction") +(defun cider--close-connection-buffer (conn-buffer) + "Close CONN-BUFFER, removing it from variable `cider-connections'. +Also close associated REPL and server buffers." + (let ((buffer (get-buffer conn-buffer)) + (nrepl-messages-buffer (and nrepl-log-messages + (nrepl-messages-buffer conn-buffer)))) + (setq cider-connections + (delq buffer cider-connections)) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when spinner-current (spinner-stop)) + (when nrepl-tunnel-buffer + (cider--close-buffer nrepl-tunnel-buffer))) + ;; If this is the only (or last) REPL connected to its server, the + ;; kill-process hook will kill the server. + (cider--close-buffer buffer) + (when nrepl-messages-buffer + (kill-buffer nrepl-messages-buffer))))) + + +;;; Current connection logic +(defvar-local cider-repl-type "clj" + "The type of this REPL buffer, usually either \"clj\" or \"cljs\".") + +(defun cider-find-connection-buffer-for-project-directory (&optional project-directory all-connections) + "Return the most appropriate connection-buffer for the current project. + +By order of preference, this is any connection whose directory matches +`clojure-project-dir', followed by any connection whose directory is nil, +followed by any connection at all. + +If PROJECT-DIRECTORY is provided act on that project instead. + +Only return nil if variable `cider-connections' is empty, +i.e there are no connections. + +If more than one connection satisfy a given level of preference, return the +connection buffer closer to the start of variable `cider-connections'. This is +usally the connection that was more recently created, but the order can be +changed. For instance, the function `cider-make-connection-default' can be +used to move a connection to the head of the list, so that it will take +precedence over other connections associated with the same project. + +If ALL-CONNECTIONS is non-nil, the return value is a list and all matching +connections are returned, instead of just the most recent." + (when-let ((project-directory (or project-directory + (clojure-project-dir (cider-current-dir)))) + (fn (if all-connections #'seq-filter #'seq-find))) + (or (funcall fn (lambda (conn) + (when-let ((conn-proj-dir (with-current-buffer conn + nrepl-project-dir))) + (equal (file-truename project-directory) + (file-truename conn-proj-dir)))) + cider-connections) + (funcall fn (lambda (conn) + (with-current-buffer conn + (not nrepl-project-dir))) + cider-connections) + (if all-connections + cider-connections + (car cider-connections))))) + +(defun cider-read-connection (prompt) + "Completing read for connections using PROMPT." + (get-buffer (completing-read prompt (mapcar #'buffer-name (cider-connections))))) + +(defun cider-assoc-project-with-connection (&optional project connection) + "Associate a Clojure PROJECT with an nREPL CONNECTION. + +Useful for connections created using `cider-connect', as for them +such a link cannot be established automatically." + (interactive) + (cider-ensure-connected) + (let ((conn-buf (or connection (cider-read-connection "Connection: "))) + (project-dir (or project (read-directory-name "Project directory: " (clojure-project-dir))))) + (when conn-buf + (with-current-buffer conn-buf + (setq nrepl-project-dir project-dir))))) + +(defun cider-assoc-buffer-with-connection () + "Associate the current buffer with a connection. + +Useful for connections created using `cider-connect', as for them +such a link cannot be established automatically." + (interactive) + (cider-ensure-connected) + (let ((conn (cider-read-connection "Connection: "))) + (when conn + (setq-local cider-connections (list conn))))) + +(defun cider-toggle-buffer-connection () + "Toggles the current buffer's connection between Clojure and ClojureScript." + (interactive) + (cider-ensure-connected) + (let ((other-conn (cider-other-connection))) + (if other-conn + (setq-local cider-connections (list other-conn)) + (user-error "No other connection available")))) + +(defun cider-clear-buffer-local-connection () + "Remove association between the current buffer and a connection." + (interactive) + (cider-ensure-connected) + (kill-local-variable 'cider-connections)) + +(defun cider-connection-type-for-buffer () + "Return the matching connection type (clj or cljs) for the current buffer." + (cond + ((derived-mode-p 'clojurescript-mode) "cljs") + ((derived-mode-p 'clojure-mode) "clj") + (cider-repl-type) + (t "clj"))) + +(defun cider-toggle-request-dispatch () + "Toggles the value of `cider-request-dispatch' between static and dynamic. + +Handy when you're using dynamic dispatch, but you want to quickly force all +evaluation commands to use a particular connection." + (interactive) + (let ((new-value (if (eq cider-request-dispatch 'static) 'dynamic 'static))) + (setq cider-request-dispatch new-value) + (message "Toggled CIDER request dispatch to %s." new-value))) + +(defun cider-current-connection (&optional type) + "Return the REPL buffer relevant for the current Clojure source buffer. +A REPL is relevant if its `nrepl-project-dir' is compatible with the +current directory (see `cider-find-connection-buffer-for-project-directory'). + +If TYPE is provided, it is either \"clj\" or \"cljs\", and only a +connection of that type is returned. If no connections of that TYPE exist, +return nil. + +If TYPE is nil, then connections whose type matches the current file +extension are given preference, but if none exist, any connection is +returned. In this case, only return nil if there are no active connections +at all." + ;; If TYPE was specified, we only return that type (or nil). OW, we prefer + ;; that TYPE, but ultimately allow any type. + (cl-labels ((right-type-p + (c) + (when (or (not type) + (and (buffer-live-p c) + (with-current-buffer c (equal cider-repl-type type)))) + c))) + (let ((connections (cider-connections))) + (cond + ((not connections) nil) + ;; if you're in a REPL buffer, it's the connection buffer + ((and (derived-mode-p 'cider-repl-mode) (right-type-p (current-buffer)))) + ((eq cider-request-dispatch 'static) (car connections)) + ((= 1 (length connections)) (right-type-p (car connections))) + (t (let ((project-connections (cider-find-connection-buffer-for-project-directory + nil :all-connections)) + (guessed-type (or type (cider-connection-type-for-buffer)))) + ;; So we have multiple connections. Look for the connection type we + ;; want, prioritizing the current project. + (or (seq-find (lambda (conn) + (equal (cider--connection-type conn) guessed-type)) + project-connections) + (seq-find (lambda (conn) + (equal (cider--connection-type conn) guessed-type)) + connections) + (right-type-p (car project-connections)) + (right-type-p (car connections))))))))) + +(defun cider-other-connection (&optional connection) + "Return the first connection of another type than CONNECTION. +Only return connections in the same project or nil. +CONNECTION defaults to `cider-current-connection'." + (when-let ((connection (or connection (cider-current-connection))) + (connection-type (cider--connection-type connection))) + (cider-current-connection (pcase connection-type + (`"clj" "cljs") + (_ "clj"))))) + +(defvar cider--has-warned-about-bad-repl-type nil) + +(defun cider--guess-cljs-connection () + "Hacky way to find a ClojureScript REPL. +DO NOT USE THIS FUNCTION. +It was written only to be used in `cider-map-connections', as a workaround +to a still-undetermined bug in the state-stracker backend." + (when-let ((project-connections (cider-find-connection-buffer-for-project-directory + nil :all-connections)) + (cljs-conn + ;; So we have multiple connections. Look for the connection type we + ;; want, prioritizing the current project. + (or (seq-find (lambda (c) (string-match "\\bCLJS\\b" (buffer-name c))) + project-connections) + (seq-find (lambda (c) (string-match "\\bCLJS\\b" (buffer-name c))) + (cider-connections))))) + (unless cider--has-warned-about-bad-repl-type + (setq cider--has-warned-about-bad-repl-type t) + (read-key + (concat "The ClojureScript REPL seems to be is misbehaving." + (substitute-command-keys + "\nWe have applied a workaround, but please also file a bug report with `\\[cider-report-bug]'.") + "\nPress any key to continue."))) + cljs-conn)) + +(defun cider-map-connections (function which &optional any-mode) + "Call FUNCTION once for each appropriate connection. +The function is called with one argument, the connection buffer. +The appropriate connections are found by inspecting the current buffer. If +the buffer is associated with a .cljc or .cljx file, BODY will be executed +multiple times. + +WHICH is one of the following keywords identifying which connections to map +over. + :any - Act the connection whose type matches the current buffer. + :clj - Like :any, but signal a `user-error' in `clojurescript-mode' or if + there is no Clojure connection (use this for commands only + supported in Clojure). + :cljs - Like :clj, but demands a ClojureScript connection instead. + :both - In `clojurec-mode' or `clojurex-mode' act on both connections, + otherwise function like :any. Obviously, this option might run + FUNCTION twice. + +If ANY-MODE is non-nil, :clj and :cljs don't signal errors due to being in +the wrong major mode (they still signal if the desired connection type +doesn't exist). Use this for commands that only apply to a specific +connection but can be invoked from any buffer (like `cider-refresh')." + (cl-labels ((err (msg) (user-error (concat "`%s' " msg) this-command))) + ;; :both in a clj or cljs buffer just means :any. + (let* ((which (if (and (eq which :both) + (not (cider--cljc-or-cljx-buffer-p))) + :any + which)) + (curr + (pcase which + (`:any (let ((type (cider-connection-type-for-buffer))) + (or (cider-current-connection type) + (when (equal type "cljs") + (cider--guess-cljs-connection)) + (err (substitute-command-keys + (format "needs a Clojure%s REPL.\nIf you don't know what that means, you probably need to jack-in (%s)." + (if (equal type "cljs") "Script" "") + (if (equal type "cljs") "`\\[cider-jack-in-clojurescript]'" "`\\[cider-jack-in]'"))))))) + (`:both (or (cider-current-connection) + (err "needs an active REPL connection"))) + (`:clj (cond ((and (not any-mode) + (derived-mode-p 'clojurescript-mode)) + (err "doesn't support ClojureScript")) + ((cider-current-connection "clj")) + ((err "needs a Clojure REPL")))) + (`:cljs (cond ((and (not any-mode) + (eq major-mode 'clojure-mode)) + (err "doesn't support Clojure")) + ((cider-current-connection "cljs")) + ((err "needs a ClojureScript REPL"))))))) + (funcall function curr) + (when (eq which :both) + (when-let ((other-connection (cider-other-connection curr))) + (funcall function other-connection)))))) + + +;;; Connection Browser +(defvar cider-connections-buffer-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "d" #'cider-connections-make-default) + (define-key map "g" #'cider-connection-browser) + (define-key map "k" #'cider-connections-close-connection) + (define-key map (kbd "RET") #'cider-connections-goto-connection) + (define-key map "?" #'describe-mode) + (define-key map "h" #'describe-mode) + map)) + +(declare-function cider-popup-buffer-mode "cider-popup") +(define-derived-mode cider-connections-buffer-mode cider-popup-buffer-mode + "CIDER Connections" + "CIDER Connections Buffer Mode. +\\{cider-connections-buffer-mode-map} +\\{cider-popup-buffer-mode-map}" + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t))) + +(defvar cider--connection-ewoc) +(defconst cider--connection-browser-buffer-name "*cider-connections*") + +(defun cider-connection-browser () + "Open a browser buffer for nREPL connections." + (interactive) + (if-let ((buffer (get-buffer cider--connection-browser-buffer-name))) + (progn + (cider--connections-refresh-buffer buffer) + (unless (get-buffer-window buffer) + (select-window (display-buffer buffer)))) + (cider--setup-connection-browser))) + +(defun cider--connections-refresh () + "Refresh the connections buffer, if the buffer exists. +The connections buffer is determined by +`cider--connection-browser-buffer-name'" + (when-let ((buffer (get-buffer cider--connection-browser-buffer-name))) + (cider--connections-refresh-buffer buffer))) + +(add-hook 'nrepl-disconnected-hook #'cider--connections-refresh) + +(defun cider--connections-refresh-buffer (buffer) + "Refresh the connections BUFFER." + (cider--update-connections-display + (buffer-local-value 'cider--connection-ewoc buffer) + cider-connections)) + +(defun cider--setup-connection-browser () + "Create a browser buffer for nREPL connections." + (with-current-buffer (get-buffer-create cider--connection-browser-buffer-name) + (let ((ewoc (ewoc-create + 'cider--connection-pp + " REPL Host Port Project Type\n"))) + (setq-local cider--connection-ewoc ewoc) + (cider--update-connections-display ewoc cider-connections) + (setq buffer-read-only t) + (cider-connections-buffer-mode) + (display-buffer (current-buffer))))) + +(defun cider-client-name-repl-type (type) + "Return a human-readable name for a connection TYPE. +TYPE can be any of the possible values of `cider-repl-type'." + (pcase type + ("clj" "Clojure") + ("cljs" "ClojureScript") + (_ "Unknown"))) + +(defun cider-project-name (project-dir) + "Extract the project name from PROJECT-DIR." + (if (and project-dir (not (equal project-dir ""))) + (file-name-nondirectory (directory-file-name project-dir)) + "-")) + +(defun cider--connection-pp (connection) + "Print an nREPL CONNECTION to the current buffer." + (let* ((buffer-read-only nil) + (buffer (get-buffer connection)) + (project-name (cider-project-name (buffer-local-value 'nrepl-project-dir buffer))) + (repl-type (cider-client-name-repl-type (buffer-local-value 'cider-repl-type buffer))) + (endpoint (buffer-local-value 'nrepl-endpoint buffer))) + (insert + (format "%s %-30s %-16s %5s %-16s %s" + (if (equal connection (car cider-connections)) "*" " ") + (buffer-name connection) + (car endpoint) + (prin1-to-string (cadr endpoint)) + project-name + repl-type)))) + +(defun cider--update-connections-display (ewoc connections) + "Update the connections EWOC to show CONNECTIONS." + (ewoc-filter ewoc (lambda (n) (member n connections))) + (let ((existing)) + (ewoc-map (lambda (n) (setq existing (cons n existing))) ewoc) + (let ((added (seq-difference connections existing))) + (mapc (apply-partially 'ewoc-enter-last ewoc) added) + (save-excursion (ewoc-refresh ewoc))))) + +(defun cider--ewoc-apply-at-point (f) + "Apply function F to the ewoc node at point. +F is a function of two arguments, the ewoc and the data at point." + (let* ((ewoc cider--connection-ewoc) + (node (and ewoc (ewoc-locate ewoc)))) + (when node + (funcall f ewoc (ewoc-data node))))) + +(defun cider-connections-make-default () + "Make default the connection at point in the connection browser." + (interactive) + (save-excursion + (cider--ewoc-apply-at-point #'cider--connections-make-default))) + +(defun cider--connections-make-default (ewoc data) + "Make the connection in EWOC specified by DATA default. +Refreshes EWOC." + (interactive) + (cider-make-connection-default data) + (ewoc-refresh ewoc)) + +(defun cider-connections-close-connection () + "Close connection at point in the connection browser." + (interactive) + (cider--ewoc-apply-at-point #'cider--connections-close-connection)) + +(defun cider--connections-close-connection (ewoc data) + "Close the connection in EWOC specified by DATA." + (cider--close-connection-buffer (get-buffer data)) + (cider--update-connections-display ewoc cider-connections)) + +(defun cider-connections-goto-connection () + "Goto connection at point in the connection browser." + (interactive) + (cider--ewoc-apply-at-point #'cider--connections-goto-connection)) + +(defun cider--connections-goto-connection (_ewoc data) + "Goto the REPL for the connection in _EWOC specified by DATA." + (when (buffer-live-p data) + (select-window (display-buffer data)))) + + +(defun cider-display-connected-message () + "Message displayed on successful connection." + (message + (concat "Connected." + (if cider-connection-message-fn + (format " %s" (funcall cider-connection-message-fn)) + "")))) + +;; TODO: Replace direct usage of such hooks with CIDER hooks, +;; that are connection type independent +(add-hook 'nrepl-connected-hook 'cider-display-connected-message) + + +;;; 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 + ns line column additional-params) + (cider-spinner-start connection))) + +(defun cider-nrepl-sync-request:eval (input &optional ns) + "Send the INPUT to the nREPL server synchronously. +If NS is non-nil, include it in the request." + (nrepl-sync-request:eval + input + (cider-current-connection) + ns)) + +(defcustom cider-pprint-fn 'pprint + "Sets the function to use when pretty-printing evaluation results. + +The value must be one of the following symbols: + + `pprint' - to use \\=`clojure.pprint/pprint\\=` + + `fipp' - to use the Fast Idiomatic Pretty Printer, approximately 5-10x + faster than \\=`clojure.core/pprint\\=` (this is the default) + + `puget' - to use Puget, which provides canonical serialization of data on + top of fipp, but at a slight performance cost + +Alternatively, can be the namespace-qualified name of a Clojure function of +one argument. If the function cannot be resolved, an exception will be +thrown. + +The function is assumed to respect the contract of \\=`clojure.pprint/pprint\\=` +with respect to the bound values of \\=`*print-length*\\=`, \\=`*print-level*\\=`, +\\=`*print-meta*\\=`, and \\=`clojure.pprint/*print-right-margin*\\=`." + :type '(choice (const pprint) + (const fipp) + (const puget) + string) + :group 'cider + :package-version '(cider . "0.11.0")) + +(defun cider--pprint-fn () + "Return the value to send in the pprint-fn slot of messages." + (pcase cider-pprint-fn + (`pprint "clojure.pprint/pprint") + (`fipp "cider.nrepl.middleware.pprint/fipp-pprint") + (`puget "cider.nrepl.middleware.pprint/puget-pprint") + (_ cider-pprint-fn))) + +(defun cider--nrepl-pprint-request-plist (right-margin &optional pprint-fn) + "Plist to be appended to an eval request to make it use pprint. +PPRINT-FN is the name of the Clojure function to use. +RIGHT-MARGIN specifies the maximum column-width of the pretty-printed +result, and is included in the request if non-nil." + (append (list "pprint" "true" + "pprint-fn" (or pprint-fn (cider--pprint-fn))) + (and right-margin (list "print-right-margin" right-margin)))) + +(defun cider-tooling-eval (input callback &optional ns) + "Send the request INPUT and register the CALLBACK as the response handler. +NS specifies the namespace in which to evaluate the request." + ;; namespace forms are always evaluated in the "user" namespace + (nrepl-request:eval input + callback + (cider-current-connection) + ns nil nil nil t ; tooling + )) + +(defalias 'cider-current-repl-buffer #'cider-current-connection + "The current REPL buffer. +Return the REPL buffer given by `cider-current-connection'.") + +(declare-function cider-interrupt-handler "cider-interaction") +(defun cider-interrupt () + "Interrupt any pending evaluations." + (interactive) + (with-current-buffer (cider-current-connection) + (let ((pending-request-ids (cider-util--hash-keys nrepl-pending-requests))) + (dolist (request-id pending-request-ids) + (nrepl-request:interrupt + request-id + (cider-interrupt-handler (current-buffer)) + (cider-current-connection)))))) + +(defun cider-current-session () + "Return the eval nREPL session id of the current connection." + (cider-session-for-connection (cider-current-connection))) + +(defun cider-session-for-connection (connection) + (with-current-buffer connection + nrepl-session)) + +(defun cider-current-messages-buffer () + "The nREPL messages buffer, matching the current connection." + (nrepl-messages-buffer (cider-current-connection))) + +(defun cider-current-tooling-session () + "Return the tooling nREPL session id of the current connection." + (with-current-buffer (cider-current-connection) + nrepl-tooling-session)) + +(defun cider--var-choice (var-info) + "Prompt to choose from among multiple VAR-INFO candidates, if required. +This is needed only when the symbol queried is an unqualified host platform +method, and multiple classes have a so-named member. If VAR-INFO does not +contain a `candidates' key, it is returned as is." + (let ((candidates (nrepl-dict-get var-info "candidates"))) + (if candidates + (let* ((classes (nrepl-dict-keys candidates)) + (choice (completing-read "Member in class: " classes nil t)) + (info (nrepl-dict-get candidates choice))) + info) + var-info))) + +(defun cider-var-info (var &optional all) + "Return VAR's info as an alist with list cdrs. +When multiple matching vars are returned you'll be prompted to select one, +unless ALL is truthy." + (when (and var (not (string= var ""))) + (let ((var-info (cider-sync-request:info var))) + (if all var-info (cider--var-choice var-info))))) + +(defun cider-member-info (class member) + "Return the CLASS MEMBER's info as an alist with list cdrs." + (when (and class member) + (cider-sync-request:info nil class member))) + +(defun cider--find-var-other-window (var &optional line) + "Find the definition of VAR, optionally at a specific LINE. + +Display the results in a different window." + (if-let ((info (cider-var-info var))) + (progn + (if line (setq info (nrepl-dict-put info "line" line))) + (cider--jump-to-loc-from-info info t)) + (user-error "Symbol %s not resolved" var))) + +(defun cider--find-var (var &optional line) + "Find the definition of VAR, optionally at a specific LINE." + (if-let ((info (cider-var-info var))) + (progn + (if line (setq info (nrepl-dict-put info "line" line))) + (cider--jump-to-loc-from-info info)) + (user-error "Symbol %s not resolved" var))) + +(defun cider-find-var (&optional arg var line) + "Find definition for VAR at LINE. + +Prompt according to prefix ARG and `cider-prompt-for-symbol'. +A single or double prefix argument inverts the meaning of +`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes +the results to be displayed in a different window. The default value is +thing at point." + (interactive "P") + (cider-ensure-op-supported "info") + (if var + (cider--find-var var line) + (funcall (cider-prompt-for-symbol-function arg) + "Symbol" + (if (cider--open-other-window-p arg) + #'cider--find-var-other-window + #'cider--find-var)))) + + +;;; Requests + +(declare-function cider-load-file-handler "cider-interaction") +(defun cider-request:load-file (file-contents file-path file-name &optional connection callback) + "Perform the nREPL \"load-file\" op. +FILE-CONTENTS, FILE-PATH and FILE-NAME are details of the file to be +loaded. + +If CONNECTION is nil, use `cider-current-connection'. +If CALLBACK is nil, use `cider-load-file-handler'." + (cider-nrepl-send-request (list "op" "load-file" + "file" file-contents + "file-path" file-path + "file-name" file-name) + (or callback + (cider-load-file-handler (current-buffer))) + connection)) + + +;;; Sync Requests + +(defcustom cider-filtered-namespaces-regexps + '("^cider.nrepl" "^refactor-nrepl" "^clojure.tools.nrepl") + "List of regexps used to filter out some vars/symbols/namespaces. +When nil, nothing is filtered out. Otherwise, all namespaces matching any +regexp from this list are dropped out of the \"ns-list\" op. +Also, \"apropos\" won't include vars from such namespaces. +This list is passed on to the nREPL middleware without any pre-processing. +So the regexps have to be in Clojure format (with twice the number of +backslashes) and not Emacs Lisp." + :type '(repeat string) + :safe #'listp + :group 'cider + :package-version '(cider . "0.13.0")) + +(defun cider-sync-request:apropos (query &optional search-ns docs-p privates-p case-sensitive-p) + "Send \"apropos\" request for regexp QUERY. + +Optional arguments include SEARCH-NS, DOCS-P, PRIVATES-P, CASE-SENSITIVE-P." + (let* ((query (replace-regexp-in-string "[ \t]+" ".+" query)) + (response (cider-nrepl-send-sync-request + `("op" "apropos" + "ns" ,(cider-current-ns) + "query" ,query + ,@(when search-ns `("search-ns" ,search-ns)) + ,@(when docs-p '("docs?" "t")) + ,@(when privates-p '("privates?" "t")) + ,@(when case-sensitive-p '("case-sensitive?" "t")) + "filter-regexps" ,cider-filtered-namespaces-regexps)))) + (if (member "apropos-regexp-error" (nrepl-dict-get response "status")) + (user-error "Invalid regexp: %s" (nrepl-dict-get response "error-msg")) + (nrepl-dict-get response "apropos-matches")))) + +(defun cider-sync-request:classpath () + "Return a list of classpath entries." + (cider-ensure-op-supported "classpath") + (thread-first (list "op" "classpath") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "classpath"))) + +(defun cider-sync-request:complete (str context) + "Return a list of completions for STR using nREPL's \"complete\" op. +CONTEXT represents a completion context for compliment." + (when-let ((dict (thread-first (list "op" "complete" + "ns" (cider-current-ns) + "symbol" str + "context" context) + (cider-nrepl-send-sync-request nil 'abort-on-input)))) + (nrepl-dict-get dict "completions"))) + +(defun cider-sync-request:info (symbol &optional class member) + "Send \"info\" op with parameters SYMBOL or CLASS and MEMBER." + (let ((var-info (thread-first `("op" "info" + "ns" ,(cider-current-ns) + ,@(when symbol (list "symbol" symbol)) + ,@(when class (list "class" class)) + ,@(when member (list "member" member))) + (cider-nrepl-send-sync-request)))) + (if (member "no-info" (nrepl-dict-get var-info "status")) + nil + var-info))) + +(defun cider-sync-request:eldoc (symbol &optional class member) + "Send \"eldoc\" op with parameters SYMBOL or CLASS and MEMBER." + (when-let ((eldoc (thread-first `("op" "eldoc" + "ns" ,(cider-current-ns) + ,@(when symbol (list "symbol" symbol)) + ,@(when class (list "class" class)) + ,@(when member (list "member" member))) + (cider-nrepl-send-sync-request nil 'abort-on-input)))) + (if (member "no-eldoc" (nrepl-dict-get eldoc "status")) + nil + eldoc))) + +(defun cider-sync-request:ns-list () + "Get a list of the available namespaces." + (thread-first (list "op" "ns-list" + "filter-regexps" cider-filtered-namespaces-regexps) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "ns-list"))) + +(defun cider-sync-request:ns-vars (ns) + "Get a list of the vars in NS." + (thread-first (list "op" "ns-vars" + "ns" ns) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "ns-vars"))) + +(defun cider-sync-request:ns-vars-with-meta (ns) + "Get a map of the vars in NS to its metadata information." + (thread-first (list "op" "ns-vars-with-meta" + "ns" ns) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "ns-vars-with-meta"))) + +(defun cider-sync-request:ns-load-all () + "Load all project namespaces." + (thread-first (list "op" "ns-load-all") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "loaded-ns"))) + +(defun cider-sync-request:resource (name) + "Perform nREPL \"resource\" op with resource name NAME." + (thread-first (list "op" "resource" + "name" name) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "resource-path"))) + +(defun cider-sync-request:resources-list () + "Return a list of all resources on the classpath." + (thread-first (list "op" "resources-list") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "resources-list"))) + +(defun cider-sync-request:format-code (code) + "Perform nREPL \"format-code\" op with CODE." + (thread-first (list "op" "format-code" + "code" code) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "formatted-code"))) + +(defun cider-sync-request:format-edn (edn right-margin) + "Perform \"format-edn\" op with EDN and RIGHT-MARGIN." + (let* ((response (thread-first (list "op" "format-edn" + "edn" edn) + (append (cider--nrepl-pprint-request-plist right-margin)) + (cider-nrepl-send-sync-request))) + (err (nrepl-dict-get response "err"))) + (when err + ;; err will be a stacktrace with a first line that looks like: + ;; "clojure.lang.ExceptionInfo: Unmatched delimiter ]" + (error (car (split-string err "\n")))) + (nrepl-dict-get response "formatted-edn"))) + + +;;; 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-20170129.1941/cider-common.el b/elpa/cider-20170129.1941/cider-common.el new file mode 100644 index 00000000..053100d7 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-common.el @@ -0,0 +1,265 @@ +;;; cider-common.el --- Common use functions -*- lexical-binding: t; -*- + +;; Copyright © 2015-2017 Artur Malabarba + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Common functions that are useful in both Clojure buffers and REPL +;; buffers. + +;;; Code: + +(require 'subr-x) +(require 'cider-compat) +(require 'nrepl-dict) +(require 'cider-util) +(require 'tramp) + +(defcustom cider-prompt-for-symbol t + "Controls when to prompt for symbol when a command requires one. + +When non-nil, always prompt, and use the symbol at point as the default +value at the prompt. + +When nil, attempt to use the symbol at point for the command, and only +prompt if that throws an error." + :type '(choice (const :tag "always" t) + (const :tag "dwim" nil)) + :group 'cider + :package-version '(cider . "0.9.0")) + +(defcustom cider-special-mode-truncate-lines t + "If non-nil, contents of CIDER's special buffers will be line-truncated. +Should be set before loading CIDER." + :type 'boolean + :group 'cider + :package-version '(cider . "0.15.0")) + +(defun cider--should-prompt-for-symbol (&optional invert) + "Return the value of the variable `cider-prompt-for-symbol'. +Optionally invert the value, if INVERT is truthy." + (if invert (not cider-prompt-for-symbol) cider-prompt-for-symbol)) + +(defun cider-prompt-for-symbol-function (&optional invert) + "Prompt for symbol if funcall `cider--should-prompt-for-symbol' is truthy. +Otherwise attempt to use the symbol at point for the command, and only +prompt if that throws an error. + +INVERT is used to invert the semantics of the function `cider--should-prompt-for-symbol'." + (if (cider--should-prompt-for-symbol invert) + #'cider-read-symbol-name + #'cider-try-symbol-at-point)) + +(defun cider--kw-to-symbol (kw) + "Convert the keyword KW to a symbol." + (when kw + (replace-regexp-in-string "\\`:+" "" kw))) + +(declare-function cider-read-from-minibuffer "cider-interaction") + +(defun cider-read-symbol-name (prompt callback) + "Read a symbol name using PROMPT with a default of the one at point. +Use CALLBACK as the completing read var callback." + (funcall callback (cider-read-from-minibuffer + prompt + ;; if the thing at point is a keyword we treat it as symbol + (cider--kw-to-symbol (cider-symbol-at-point 'look-back))))) + +(defun cider-try-symbol-at-point (prompt callback) + "Call CALLBACK with symbol at point. +On failure, read a symbol name using PROMPT and call CALLBACK with that." + (condition-case nil (funcall callback (cider--kw-to-symbol (cider-symbol-at-point 'look-back))) + ('error (funcall callback (cider-read-from-minibuffer prompt))))) + +(declare-function cider-jump-to "cider-interaction") + +(defun cider--find-buffer-for-file (file) + "Return a buffer visiting FILE. +If FILE is a temp buffer name, return that buffer." + (if (string-prefix-p "*" file) + file + (and file + (not (cider--tooling-file-p file)) + (cider-find-file file)))) + +(defun cider--jump-to-loc-from-info (info &optional other-window) + "Jump to location give by INFO. +INFO object is returned by `cider-var-info' or `cider-member-info'. +OTHER-WINDOW is passed to `cider-jump-to'." + (let* ((line (nrepl-dict-get info "line")) + (file (nrepl-dict-get info "file")) + (name (nrepl-dict-get info "name")) + ;; the filename might actually be a REPL buffer name + (buffer (cider--find-buffer-for-file file))) + (if buffer + (cider-jump-to buffer (if line (cons line nil) name) other-window) + (error "No source location")))) + +(declare-function url-filename "url-parse" (cl-x) t) + +(defun cider--url-to-file (url) + "Return the filename from the resource URL. +Uses `url-generic-parse-url' to parse the url. The filename is extracted and +then url decoded. If the decoded filename has a Windows device letter followed +by a colon immediately after the leading '/' then the leading '/' is dropped to +create a valid path." + (let ((filename (url-unhex-string (url-filename (url-generic-parse-url url))))) + (if (string-match "^/\\([a-zA-Z]:/.*\\)" filename) + (match-string 1 filename) + filename))) + +(defun cider-tramp-prefix (&optional buffer) + "Use the filename for BUFFER to determine a tramp prefix. +Defaults to the current buffer. +Return the tramp prefix, or nil if BUFFER is local." + (let* ((buffer (or buffer (current-buffer))) + (name (or (buffer-file-name buffer) + (with-current-buffer buffer + default-directory)))) + (when (tramp-tramp-file-p name) + (let ((vec (tramp-dissect-file-name name))) + (tramp-make-tramp-file-name (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + nil))))) + +(defun cider--client-tramp-filename (name &optional buffer) + "Return the tramp filename for path NAME relative to BUFFER. +If BUFFER has a tramp prefix, it will be added as a prefix to NAME. +If the resulting path is an existing tramp file, it returns the path, +otherwise, nil." + (let* ((buffer (or buffer (current-buffer))) + (name (concat (cider-tramp-prefix buffer) name))) + (if (tramp-handle-file-exists-p name) + name))) + +(defun cider--server-filename (name) + "Return the nREPL server-relative filename for NAME." + (if (tramp-tramp-file-p name) + (with-parsed-tramp-file-name name nil + localname) + name)) + +(defvar cider-from-nrepl-filename-function + (with-no-warnings + (if (eq system-type 'cygwin) + #'cygwin-convert-file-name-from-windows + #'identity)) + "Function to translate nREPL namestrings to Emacs filenames.") + +(defcustom cider-prefer-local-resources nil + "Prefer local resources to remote (tramp) ones when both are available." + :type 'boolean + :group 'cider) + +(defun cider--file-path (path) + "Return PATH's local or tramp path using `cider-prefer-local-resources'. +If no local or remote file exists, return nil." + (let* ((local-path (funcall cider-from-nrepl-filename-function path)) + (tramp-path (and local-path (cider--client-tramp-filename local-path)))) + (cond ((equal local-path "") "") + ((and cider-prefer-local-resources (file-exists-p local-path)) + local-path) + ((and tramp-path (file-exists-p tramp-path)) + tramp-path) + ((and local-path (file-exists-p local-path)) + local-path)))) + +(declare-function archive-extract "arc-mode") +(declare-function archive-zip-extract "arc-mode") + +(defun cider-find-file (url) + "Return a buffer visiting the file URL if it exists, or nil otherwise. +If URL has a scheme prefix, it must represent a fully-qualified file path +or an entry within a zip/jar archive. If URL doesn't contain a scheme +prefix and is an absolute path, it is treated as such. Finally, if URL is +relative, it is expanded within each of the open Clojure buffers till an +existing file ending with URL has been found." + (require 'arc-mode) + (cond ((string-match "^file:\\(.+\\)" url) + (when-let ((file (cider--url-to-file (match-string 1 url))) + (path (cider--file-path file))) + (find-file-noselect path))) + ((string-match "^\\(jar\\|zip\\):\\(file:.+\\)!/\\(.+\\)" url) + (when-let ((entry (match-string 3 url)) + (file (cider--url-to-file (match-string 2 url))) + (path (cider--file-path file)) + (name (format "%s:%s" path entry))) + (or (find-buffer-visiting name) + (if (tramp-tramp-file-p path) + (progn + ;; Use emacs built in archiving + (find-file path) + (goto-char (point-min)) + ;; Make sure the file path is followed by a newline to + ;; prevent eg. clj matching cljs. + (search-forward (concat entry "\n")) + ;; moves up to matching line + (forward-line -1) + (archive-extract) + (current-buffer)) + ;; Use external zip program to just extract the single file + (with-current-buffer (generate-new-buffer + (file-name-nondirectory entry)) + (archive-zip-extract path entry) + (set-visited-file-name name) + (setq-local default-directory (file-name-directory path)) + (setq-local buffer-read-only t) + (set-buffer-modified-p nil) + (set-auto-mode) + (current-buffer)))))) + (t (if-let ((path (cider--file-path url))) + (find-file-noselect path) + (unless (file-name-absolute-p url) + (let ((cider-buffers (cider-util--clojure-buffers)) + (url (file-name-nondirectory url))) + (or (cl-loop for bf in cider-buffers + for path = (with-current-buffer bf + (expand-file-name url)) + if (and path (file-exists-p path)) + return (find-file-noselect path)) + (cl-loop for bf in cider-buffers + if (string= (buffer-name bf) url) + return bf)))))))) + +(defun cider--open-other-window-p (arg) + "Test prefix value ARG to see if it indicates displaying results in other window." + (let ((narg (prefix-numeric-value arg))) + (pcase narg + (-1 t) ; - + (16 t) ; empty empty + (_ nil)))) + +(defun cider-abbreviate-ns (namespace) + "Return a string that abbreviates NAMESPACE." + (when namespace + (let* ((names (reverse (split-string namespace "\\."))) + (lastname (car names))) + (concat (mapconcat (lambda (s) (concat (substring s 0 1) ".")) + (reverse (cdr names)) + "") + lastname)))) + +(defun cider-last-ns-segment (namespace) + "Return the last segment of NAMESPACE." + (when namespace + (car (reverse (split-string namespace "\\."))))) + + +(provide 'cider-common) +;;; cider-common.el ends here diff --git a/elpa/cider-20170129.1941/cider-compat.el b/elpa/cider-20170129.1941/cider-compat.el new file mode 100644 index 00000000..c34bc7bf --- /dev/null +++ b/elpa/cider-20170129.1941/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-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Pretty much everything here's copied from subr-x for compatibility with +;; Emacs 24.4. + +;;; Code: + +(eval-and-compile + + (unless (fboundp 'internal--thread-argument) + (defmacro internal--thread-argument (first? &rest forms) + "Internal implementation for `thread-first' and `thread-last'. +When Argument FIRST? is non-nil argument is threaded first, else +last. FORMS are the expressions to be threaded." + (pcase forms + (`(,x (,f . ,args) . ,rest) + `(internal--thread-argument + ,first? ,(if first? `(,f ,x ,@args) `(,f ,@args ,x)) ,@rest)) + (`(,x ,f . ,rest) `(internal--thread-argument ,first? (,f ,x) ,@rest)) + (_ (car forms))))) + + (unless (fboundp 'thread-first) + (defmacro thread-first (&rest forms) + "Thread FORMS elements as the first argument of their successor. +Example: + (thread-first + 5 + (+ 20) + (/ 25) + - + (+ 40)) +Is equivalent to: + (+ (- (/ (+ 5 20) 25)) 40) +Note how the single `-' got converted into a list before +threading." + (declare (indent 1) + (debug (form &rest [&or symbolp (sexp &rest form)]))) + `(internal--thread-argument t ,@forms))) + + (unless (fboundp 'thread-last) + (defmacro thread-last (&rest forms) + "Thread FORMS elements as the last argument of their successor. +Example: + (thread-last + 5 + (+ 20) + (/ 25) + - + (+ 40)) +Is equivalent to: + (+ 40 (- (/ 25 (+ 20 5)))) +Note how the single `-' got converted into a list before +threading." + (declare (indent 1) (debug thread-first)) + `(internal--thread-argument nil ,@forms)))) + + +(eval-and-compile + + (unless (fboundp 'internal--listify) + + (defsubst internal--listify (elt) + "Wrap ELT in a list if it is not one." + (if (not (listp elt)) + (list elt) + elt))) + + (unless (fboundp 'internal--check-binding) + + (defsubst internal--check-binding (binding) + "Check BINDING is properly formed." + (when (> (length binding) 2) + (signal + 'error + (cons "`let' bindings can have only one value-form" binding))) + binding)) + + (unless (fboundp 'internal--build-binding-value-form) + + (defsubst internal--build-binding-value-form (binding prev-var) + "Build the conditional value form for BINDING using PREV-VAR." + `(,(car binding) (and ,prev-var ,(cadr binding))))) + + (unless (fboundp 'internal--build-binding) + + (defun internal--build-binding (binding prev-var) + "Check and build a single BINDING with PREV-VAR." + (thread-first + binding + internal--listify + internal--check-binding + (internal--build-binding-value-form prev-var)))) + + (unless (fboundp 'internal--build-bindings) + + (defun internal--build-bindings (bindings) + "Check and build conditional value forms for BINDINGS." + (let ((prev-var t)) + (mapcar (lambda (binding) + (let ((binding (internal--build-binding binding prev-var))) + (setq prev-var (car binding)) + binding)) + bindings))))) + +(eval-and-compile + + (unless (fboundp 'if-let) + (defmacro if-let (bindings then &rest else) + "Process BINDINGS and if all values are non-nil eval THEN, else ELSE. +Argument BINDINGS is a list of tuples whose car is a symbol to be +bound and (optionally) used in THEN, and its cadr is a sexp to be +evalled to set symbol's value. In the special case you only want +to bind a single value, BINDINGS can just be a plain tuple." + (declare (indent 2) + (debug ([&or (&rest (symbolp form)) (symbolp form)] form body))) + (when (and (<= (length bindings) 2) + (not (listp (car bindings)))) + ;; Adjust the single binding case + (setq bindings (list bindings))) + `(let* ,(internal--build-bindings bindings) + (if ,(car (internal--listify (car (last bindings)))) + ,then + ,@else)))) + + (unless (fboundp 'when-let) + (defmacro when-let (bindings &rest body) + "Process BINDINGS and if all values are non-nil eval BODY. +Argument BINDINGS is a list of tuples whose car is a symbol to be +bound and (optionally) used in BODY, and its cadr is a sexp to be +evalled to set symbol's value. In the special case you only want +to bind a single value, BINDINGS can just be a plain tuple." + (declare (indent 1) (debug if-let)) + (list 'if-let bindings (macroexp-progn body))))) + +(provide 'cider-compat) +;;; cider-compat.el ends here diff --git a/elpa/cider-20170129.1941/cider-debug.el b/elpa/cider-20170129.1941/cider-debug.el new file mode 100644 index 00000000..9d762cd8 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-debug.el @@ -0,0 +1,753 @@ +;;; cider-debug.el --- CIDER interaction with the cider.debug nREPL middleware -*- lexical-binding: t; -*- + +;; Copyright © 2015-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General 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 'subr-x) +(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) + (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-20170129.1941/cider-doc.el b/elpa/cider-20170129.1941/cider-doc.el new file mode 100644 index 00000000..0ee07f34 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-doc.el @@ -0,0 +1,524 @@ +;;; cider-doc.el --- CIDER documentation functionality -*- lexical-binding: t -*- + +;; Copyright © 2014-2017 Bozhidar Batsov, Jeff Valk and CIDER contributors + +;; Author: Jeff Valk + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Mode for formatting and presenting documentation + +;;; Code: + +(require 'cider-common) +(require 'subr-x) +(require 'cider-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) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t)) + (setq-local electric-indent-chars nil) + (setq-local cider-docview-symbol nil) + (setq-local cider-docview-javadoc-url nil) + (setq-local cider-docview-file nil) + (setq-local cider-docview-line nil)) + + +;;; Interactive functions + +(defun cider-docview-javadoc () + "Open the Javadoc for the current class, if available." + (interactive) + (if cider-docview-javadoc-url + (browse-url cider-docview-javadoc-url) + (error "No Javadoc available for %s" cider-docview-symbol))) + +(defun cider-javadoc-handler (symbol-name) + "Invoke the nREPL \"info\" op on SYMBOL-NAME if available." + (when symbol-name + (let* ((info (cider-var-info symbol-name)) + (url (nrepl-dict-get info "javadoc"))) + (if url + (browse-url url) + (user-error "No Javadoc available for %s" symbol-name))))) + +(defun cider-javadoc (arg) + "Open Javadoc documentation in a popup buffer. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates." + (interactive "P") + (cider-ensure-connected) + (cider-ensure-op-supported "info") + (funcall (cider-prompt-for-symbol-function arg) + "Javadoc for" + #'cider-javadoc-handler)) + +(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-20170129.1941/cider-eldoc.el b/elpa/cider-20170129.1941/cider-eldoc.el new file mode 100644 index 00000000..ed0a8bc4 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-eldoc.el @@ -0,0 +1,440 @@ +;;; cider-eldoc.el --- eldoc support for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; eldoc support for Clojure. + +;;; Code: + +(require 'cider-client) +(require 'cider-common) ; for cider-symbol-at-point +(require 'subr-x) +(require 'cider-compat) +(require 'cider-util) +(require 'nrepl-dict) + +(require 'seq) + +(require 'eldoc) + +(defvar cider-extra-eldoc-commands '("yas-expand") + "Extra commands to be added to eldoc's safe commands list.") + +(defcustom cider-eldoc-max-num-sexps-to-skip 30 + "The maximum number of sexps to skip while searching the beginning of current sexp." + :type 'integer + :group 'cider + :package-version '(cider . "0.10.1")) + +(defvar-local cider-eldoc-last-symbol nil + "The eldoc information for the last symbol we checked.") + +(defcustom cider-eldoc-ns-function #'identity + "A function that returns a ns string to be used by eldoc. +Takes one argument, a namespace name. +For convenience, some functions are already provided for this purpose: +`cider-abbreviate-ns', and `cider-last-ns-segment'." + :type '(choice (const :tag "Full namespace" identity) + (const :tag "Abbreviated namespace" cider-abbreviate-ns) + (const :tag "Last name in namespace" cider-last-ns-segment) + (function :tag "Custom function")) + :group 'cider + :package-version '(cider . "0.13.0")) + +(defcustom cider-eldoc-max-class-names-to-display 3 + "The maximum number of classes to display in an eldoc string. +An eldoc string for Java interop forms can have a number of classes prefixed to +it, when the form belongs to more than 1 class. When, not nil we only display +the names of first `cider-eldoc-max-class-names-to-display' classes and add +a \"& x more\" suffix. Otherwise, all the classes are displayed." + :type 'integer + :safe #'integerp + :group 'cider + :package-version '(cider . "0.13.0")) + +(defcustom cider-eldoc-display-for-symbol-at-point t + "When non-nil, display eldoc for symbol at point if available. +So in (map inc ...) when the cursor is over inc its eldoc would be +displayed. When nil, always display eldoc for first symbol of the sexp." + :type 'boolean + :safe 'booleanp + :group 'cider + :package-version '(cider . "0.13.0")) + +(defun cider--eldoc-format-class-names (class-names) + "Return a formatted CLASS-NAMES prefix string. +CLASS-NAMES is a list of classes to which a Java interop form belongs. +Only keep the first `cider-eldoc-max-class-names-to-display' names, and +add a \"& x more\" suffix. Return nil if the CLASS-NAMES list is empty or +mapping `cider-eldoc-ns-function' on it returns an empty list." + (when-let ((eldoc-class-names (seq-remove #'null (mapcar (apply-partially cider-eldoc-ns-function) class-names))) + (eldoc-class-names-length (length eldoc-class-names))) + (cond + ;; truncate class-names list and then format it + ((and cider-eldoc-max-class-names-to-display + (> eldoc-class-names-length cider-eldoc-max-class-names-to-display)) + (format "(%s & %s more)" + (thread-first eldoc-class-names + (seq-take cider-eldoc-max-class-names-to-display) + (string-join " ") + (cider-propertize 'ns)) + (- eldoc-class-names-length cider-eldoc-max-class-names-to-display))) + + ;; format the whole list but add surrounding parentheses + ((> eldoc-class-names-length 1) + (format "(%s)" + (thread-first eldoc-class-names + (string-join " ") + (cider-propertize 'ns)))) + + ;; don't add the parentheses + (t (format "%s" (car eldoc-class-names)))))) + +(defun cider-eldoc-format-thing (ns symbol thing type) + "Format the eldoc subject defined by NS, SYMBOL and THING. +THING represents the thing at point which triggered eldoc. Normally NS and +SYMBOL are used (they are derived from THING), but when empty we fallback to +THING (e.g. for Java methods). Format it as a function, if FUNCTION-P +is non-nil. Else format it as a variable." + (if-let ((method-name (if (and symbol (not (string= symbol ""))) + symbol + thing)) + (propertized-method-name (cider-propertize method-name type)) + (ns-or-class (if (and ns (stringp ns)) + (funcall cider-eldoc-ns-function ns) + (cider--eldoc-format-class-names ns)))) + (format "%s/%s" + ;; we set font-lock properties of classes in `cider--eldoc-format-class-names' + ;; to avoid font locking the parentheses and "& x more" + ;; so we only propertize ns-or-class if not already done + (if (get-text-property 1 'face ns-or-class) + ;; it is already propertized + ns-or-class + (cider-propertize ns-or-class 'ns)) + propertized-method-name) + ;; in case ns-or-class is nil + propertized-method-name)) + +(defun cider-eldoc-format-sym-doc (var ns docstring) + "Return the formatted eldoc string for VAR and DOCSTRING. + +Consider the value of `eldoc-echo-area-use-multiline-p' while formatting. +If the entire line cannot fit in the echo area, the var name may be +truncated or eliminated entirely from the output to make room for the +description. + +Try to truncate the var with various strategies, so that the var and +the docstring can be displayed in the minibuffer without resizing the window. +We start with `cider-abbreviate-ns' and `cider-last-ns-segment'. +Next, if the var is in current namespace, we remove NS from the eldoc string. +Otherwise, only the docstring is returned." + (let* ((ea-multi eldoc-echo-area-use-multiline-p) + ;; Subtract 1 from window width since emacs will not write + ;; any chars to the last column, or in later versions, will + ;; cause a wraparound and resize of the echo area. + (ea-width (1- (window-width (minibuffer-window)))) + (strip (- (+ (length var) (length docstring)) ea-width)) + (newline (string-match-p "\n" docstring)) + ;; Truncated var can be ea-var long + ;; Subtract 2 to account for the : and / added when including + ;; the namespace prefixed form in eldoc string + (ea-var (- (- ea-width (length docstring)) 2))) + (cond + ((or (eq ea-multi t) + (and (<= strip 0) (null newline)) + (and ea-multi (or (> (length docstring) ea-width) newline))) + (format "%s: %s" var docstring)) + + ;; Now we have to truncate either the docstring or the var + (newline (cider-eldoc-format-sym-doc var ns (substring docstring 0 newline))) + + ;; Only return the truncated docstring + ((> (length docstring) ea-width) + (substring docstring 0 ea-width)) + + ;; Try to truncate the var with cider-abbreviate-ns + ((<= (length (cider-abbreviate-ns var)) ea-var) + (format "%s: %s" (cider-abbreviate-ns var) docstring)) + + ;; Try to truncate var with cider-last-ns-segment + ((<= (length (cider-last-ns-segment var)) ea-var) + (format "%s: %s" (cider-last-ns-segment var) docstring)) + + ;; If the var is in current namespace, we try to truncate the var by + ;; skipping the namespace from the returned eldoc string + ((and (string-equal ns (cider-current-ns)) + (<= (- (length var) (length ns)) ea-var)) + (format "%s: %s" + (replace-regexp-in-string (format "%s/" ns) "" var) + docstring)) + + ;; We couldn't fit the var and docstring in the available space, + ;; so we just display the docstring + (t docstring)))) + +(defun cider-eldoc-format-variable (thing pos eldoc-info) + "Return the formatted eldoc string for a variable. +THING is the variable name. POS will always be 0 here. +ELDOC-INFO is a p-list containing the eldoc information." + (let* ((ns (lax-plist-get eldoc-info "ns")) + (symbol (lax-plist-get eldoc-info "symbol")) + (docstring (lax-plist-get eldoc-info "docstring")) + (formatted-var (cider-eldoc-format-thing ns symbol thing 'var))) + (when docstring + (cider-eldoc-format-sym-doc formatted-var ns docstring)))) + +(defun cider-eldoc-format-function (thing pos eldoc-info) + "Return the formatted eldoc string for a function. +THING is the function name. POS is the argument-index of the functions +arglists. ELDOC-INFO is a p-list containing the eldoc information." + (let ((ns (lax-plist-get eldoc-info "ns")) + (symbol (lax-plist-get eldoc-info "symbol")) + (arglists (lax-plist-get eldoc-info "arglists"))) + (format "%s: %s" + (cider-eldoc-format-thing ns symbol thing 'fn) + (cider-eldoc-format-arglist arglists pos)))) + +(defun cider-highlight-args (arglist pos) + "Format the the function ARGLIST for eldoc. +POS is the index of the currently highlighted argument." + (let* ((rest-pos (cider--find-rest-args-position arglist)) + (i 0)) + (mapconcat + (lambda (arg) + (let ((argstr (format "%s" arg))) + (if (string= arg "&") + argstr + (prog1 + (if (or (= (1+ i) pos) + (and rest-pos + (> (1+ i) rest-pos) + (> pos rest-pos))) + (propertize argstr 'face + 'eldoc-highlight-function-argument) + argstr) + (setq i (1+ i)))))) arglist " "))) + +(defun cider--find-rest-args-position (arglist) + "Find the position of & in the ARGLIST vector." + (seq-position arglist "&")) + +(defun cider-highlight-arglist (arglist pos) + "Format the ARGLIST for eldoc. +POS is the index of the argument to highlight." + (concat "[" (cider-highlight-args arglist pos) "]")) + +(defun cider-eldoc-format-arglist (arglist pos) + "Format all the ARGLIST for eldoc. +POS is the index of current argument." + (concat "(" + (mapconcat (lambda (args) (cider-highlight-arglist args pos)) + arglist + " ") + ")")) + +(defun cider-eldoc-beginning-of-sexp () + "Move to the beginning of current sexp. + +Return the number of nested sexp the point was over or after. Return nil +if the maximum number of sexps to skip is exceeded." + (let ((parse-sexp-ignore-comments t) + (num-skipped-sexps 0)) + (condition-case _ + (progn + ;; First account for the case the point is directly over a + ;; beginning of a nested sexp. + (condition-case _ + (let ((p (point))) + (forward-sexp -1) + (forward-sexp 1) + (when (< (point) p) + (setq num-skipped-sexps 1))) + (error)) + (while + (let ((p (point))) + (forward-sexp -1) + (when (< (point) p) + (setq num-skipped-sexps + (unless (and cider-eldoc-max-num-sexps-to-skip + (>= num-skipped-sexps + cider-eldoc-max-num-sexps-to-skip)) + ;; Without the above guard, + ;; `cider-eldoc-beginning-of-sexp' could traverse the + ;; whole buffer when the point is not within a + ;; list. This behavior is problematic especially with + ;; a buffer containing a large number of + ;; non-expressions like a REPL buffer. + (1+ num-skipped-sexps))))))) + (error)) + num-skipped-sexps)) + +(defun cider-eldoc-thing-type (eldoc-info) + "Return the type of the thing being displayed by eldoc. +It can be a function or var now." + (pcase (lax-plist-get eldoc-info "type") + ("function" 'fn) + ("variable" 'var))) + +(defun cider-eldoc-info-at-point () + "Return eldoc info at point. +First go to the beginning of the sexp and check if the eldoc is to be +considered (i.e sexp is a method call) and not a map or vector literal. +Then go back to the point and return its eldoc." + (save-excursion + (unless (cider-in-comment-p) + (let* ((current-point (point))) + (cider-eldoc-beginning-of-sexp) + (unless (member (or (char-before (point)) 0) '(?\" ?\{ ?\[)) + (goto-char current-point) + (when-let (eldoc-info (cider-eldoc-info + (cider--eldoc-remove-dot (cider-symbol-at-point)))) + (list "eldoc-info" eldoc-info + "thing" (cider-symbol-at-point) + "pos" 0))))))) + +(defun cider-eldoc-info-at-sexp-beginning () + "Return eldoc info for first symbol in the sexp." + (save-excursion + (when-let ((beginning-of-sexp (cider-eldoc-beginning-of-sexp)) + ;; If we are at the beginning of function name, this will be -1 + (argument-index (max 0 (1- beginning-of-sexp)))) + (unless (or (memq (or (char-before (point)) 0) + '(?\" ?\{ ?\[)) + (cider-in-comment-p)) + (when-let (eldoc-info (cider-eldoc-info + (cider--eldoc-remove-dot (cider-symbol-at-point)))) + (list "eldoc-info" eldoc-info + "thing" (cider-symbol-at-point) + "pos" argument-index)))))) + +(defun cider-eldoc-info-in-current-sexp () + "Return eldoc information from the sexp. +If `cider-eldoc-display-for-symbol-at-poin' is non-nil and +the symbol at point has a valid eldoc available, return that. +Otherwise return the eldoc of the first symbol of the sexp." + (or (when cider-eldoc-display-for-symbol-at-point + (cider-eldoc-info-at-point)) + (cider-eldoc-info-at-sexp-beginning))) + +(defun cider-eldoc--convert-ns-keywords (thing) + "Convert THING values that match ns macro keywords to function names." + (pcase thing + (":import" "clojure.core/import") + (":refer-clojure" "clojure.core/refer-clojure") + (":use" "clojure.core/use") + (":refer" "clojure.core/refer") + (_ thing))) + +(defun cider-eldoc-info (thing) + "Return the info for THING. +This includes the arglist and ns and symbol name (if available)." + (let ((thing (cider-eldoc--convert-ns-keywords thing))) + (when (and (cider-nrepl-op-supported-p "eldoc") + thing + ;; ignore empty strings + (not (string= thing "")) + ;; ignore strings + (not (string-prefix-p "\"" thing)) + ;; ignore regular expressions + (not (string-prefix-p "#" thing)) + ;; ignore chars + (not (string-prefix-p "\\" thing)) + ;; ignore numbers + (not (string-match-p "^[0-9]" thing))) + ;; check if we can used the cached eldoc info + (cond + ;; handle keywords for map access + ((string-prefix-p ":" thing) (list "symbol" thing + "type" "function" + "arglists" '(("map") ("map" "not-found")))) + ;; handle Classname. by displaying the eldoc for new + ((string-match-p "^[A-Z].+\\.$" thing) (list "symbol" thing + "type" "function" + "arglists" '(("args*")))) + ;; generic case + (t (if (equal thing (car cider-eldoc-last-symbol)) + (cadr cider-eldoc-last-symbol) + (when-let ((eldoc-info (cider-sync-request:eldoc thing))) + (let* ((arglists (nrepl-dict-get eldoc-info "eldoc")) + (docstring (nrepl-dict-get eldoc-info "docstring")) + (type (nrepl-dict-get eldoc-info "type")) + (ns (nrepl-dict-get eldoc-info "ns")) + (class (nrepl-dict-get eldoc-info "class")) + (name (nrepl-dict-get eldoc-info "name")) + (member (nrepl-dict-get eldoc-info "member")) + (ns-or-class (if (and ns (not (string= ns ""))) + ns + class)) + (name-or-member (if (and name (not (string= name ""))) + name + (format ".%s" member))) + (eldoc-plist (list "ns" ns-or-class + "symbol" name-or-member + "arglists" arglists + "docstring" docstring + "type" type))) + ;; middleware eldoc lookups are expensive, so we + ;; cache the last lookup. This eliminates the need + ;; for extra middleware requests within the same sexp. + (setq cider-eldoc-last-symbol (list thing eldoc-plist)) + eldoc-plist)))))))) + +(defun cider--eldoc-remove-dot (sym) + "Remove the preceding \".\" from a namespace qualified SYM and return sym. +Only useful for interop forms. Clojure forms would be returned unchanged." + (when sym (replace-regexp-in-string "/\\." "/" sym))) + +(defun cider--eldoc-edn-file-p (file-name) + "Check whether FILE-NAME is representing an EDN file." + (and file-name (equal (file-name-extension file-name) "edn"))) + +(defun cider-eldoc () + "Backend function for eldoc to show argument list in the echo area." + (when (and (cider-connected-p) + ;; don't clobber an error message in the minibuffer + (not (member last-command '(next-error previous-error))) + ;; don't try to provide eldoc in EDN buffers + (not (cider--eldoc-edn-file-p buffer-file-name))) + (let* ((sexp-eldoc-info (cider-eldoc-info-in-current-sexp)) + (eldoc-info (lax-plist-get sexp-eldoc-info "eldoc-info")) + (pos (lax-plist-get sexp-eldoc-info "pos")) + (thing (lax-plist-get sexp-eldoc-info "thing"))) + (when eldoc-info + (if (equal (cider-eldoc-thing-type eldoc-info) 'fn) + (cider-eldoc-format-function thing pos eldoc-info) + (cider-eldoc-format-variable thing pos eldoc-info)))))) + +(defun cider-eldoc-setup () + "Setup eldoc in the current buffer. +eldoc mode has to be enabled for this to have any effect." + (setq-local eldoc-documentation-function #'cider-eldoc) + (apply #'eldoc-add-command cider-extra-eldoc-commands)) + +(provide 'cider-eldoc) + +;;; cider-eldoc.el ends here diff --git a/elpa/cider-20170129.1941/cider-grimoire.el b/elpa/cider-20170129.1941/cider-grimoire.el new file mode 100644 index 00000000..20ac4eff --- /dev/null +++ b/elpa/cider-20170129.1941/cider-grimoire.el @@ -0,0 +1,119 @@ +;;; cider-grimoire.el --- Grimoire integration -*- lexical-binding: t -*- + +;; Copyright © 2014-2017 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 'subr-x) +(require 'cider-compat) +(require 'cider-popup) + +(require 'nrepl-dict) + +(require 'url-vars) + +(defconst cider-grimoire-url "http://conj.io/") + +(defconst cider-grimoire-buffer "*cider-grimoire*") + +(defun cider-grimoire-replace-special (name) + "Convert the dashes in NAME to a grimoire friendly format." + (thread-last name + (replace-regexp-in-string "\\?" "_QMARK_") + (replace-regexp-in-string "\\." "_DOT_") + (replace-regexp-in-string "\\/" "_SLASH_") + (replace-regexp-in-string "\\(\\`_\\)\\|\\(_\\'\\)" ""))) + +(defun cider-grimoire-url (name ns) + "Generate a grimoire search v0 url from NAME, NS." + (let ((base-url cider-grimoire-url)) + (when (and name ns) + (concat base-url "search/v0/" ns "/" (cider-grimoire-replace-special name) "/")))) + +(defun cider-grimoire-web-lookup (symbol) + "Open the grimoire documentation for SYMBOL in a web browser." + (if-let ((var-info (cider-var-info symbol))) + (let ((name (nrepl-dict-get var-info "name")) + (ns (nrepl-dict-get var-info "ns"))) + (browse-url (cider-grimoire-url name ns))) + (error "Symbol %s not resolved" symbol))) + +;;;###autoload +(defun cider-grimoire-web (&optional arg) + "Open grimoire documentation in the default web browser. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates." + (interactive "P") + (funcall (cider-prompt-for-symbol-function arg) + "Grimoire doc for" + #'cider-grimoire-web-lookup)) + +(defun cider-create-grimoire-buffer (content) + "Create a new grimoire buffer with CONTENT." + (with-current-buffer (cider-popup-buffer cider-grimoire-buffer t) + (read-only-mode -1) + (insert content) + (read-only-mode +1) + (goto-char (point-min)) + (current-buffer))) + +(defun cider-grimoire-lookup (symbol) + "Look up the grimoire documentation for SYMBOL." + (if-let ((var-info (cider-var-info symbol))) + (let ((name (nrepl-dict-get var-info "name")) + (ns (nrepl-dict-get var-info "ns")) + (url-request-method "GET") + (url-request-extra-headers `(("Content-Type" . "text/plain")))) + (url-retrieve (cider-grimoire-url name ns) + (lambda (_status) + ;; we need to strip the http header + (goto-char (point-min)) + (re-search-forward "^$") + (delete-region (point-min) (point)) + (delete-blank-lines) + ;; and create a new buffer with whatever is left + (pop-to-buffer (cider-create-grimoire-buffer (buffer-string)))))) + (error "Symbol %s not resolved" symbol))) + +;;;###autoload +(defun cider-grimoire (&optional arg) + "Open grimoire documentation in a popup buffer. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates." + (interactive "P") + (when (derived-mode-p 'clojurescript-mode) + (user-error "`cider-grimoire' doesn't support ClojureScript")) + (funcall (cider-prompt-for-symbol-function arg) + "Grimoire doc for" + #'cider-grimoire-lookup)) + +(provide 'cider-grimoire) + +;;; cider-grimoire.el ends here diff --git a/elpa/cider-20170129.1941/cider-inspector.el b/elpa/cider-20170129.1941/cider-inspector.el new file mode 100644 index 00000000..b173d21d --- /dev/null +++ b/elpa/cider-20170129.1941/cider-inspector.el @@ -0,0 +1,391 @@ +;;; cider-inspector.el --- Object inspector -*- lexical-binding: t -*- + +;; Copyright © 2013-2017 Vital Reactor, LLC +;; Copyright © 2014-2017 Bozhidar Batsov and CIDER contributors + +;; Author: Ian Eslick +;; 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")) + +(defcustom cider-inspector-fill-frame nil + "Controls whether the cider inspector window fills its frame." + :type 'boolean + :group 'cider-inspector + :package-version '(cider . "0.15.0")) + +(defvar cider-inspector-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map cider-popup-buffer-mode-map) + (define-key map (kbd "RET") #'cider-inspector-operate-on-point) + (define-key map [mouse-1] #'cider-inspector-operate-on-click) + (define-key map "l" #'cider-inspector-pop) + (define-key map "g" #'cider-inspector-refresh) + ;; Page-up/down + (define-key map [next] #'cider-inspector-next-page) + (define-key map [prior] #'cider-inspector-prev-page) + (define-key map " " #'cider-inspector-next-page) + (define-key map (kbd "M-SPC") #'cider-inspector-prev-page) + (define-key map (kbd "S-SPC") #'cider-inspector-prev-page) + (define-key map "s" #'cider-inspector-set-page-size) + (define-key map [tab] #'cider-inspector-next-inspectable-object) + (define-key map "\C-i" #'cider-inspector-next-inspectable-object) + (define-key map [(shift tab)] #'cider-inspector-previous-inspectable-object) + ;; Emacs translates S-TAB to BACKTAB on X. + (define-key map [backtab] #'cider-inspector-previous-inspectable-object) + map)) + +(define-derived-mode cider-inspector-mode special-mode "Inspector" + "Major mode for inspecting Clojure data structures. + +\\{cider-inspector-mode-map}" + (set-syntax-table clojure-mode-syntax-table) + (setq buffer-read-only t) + (setq-local electric-indent-chars nil) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t))) + +;;;###autoload +(defun cider-inspect-last-sexp () + "Inspect the result of the the expression preceding point." + (interactive) + (cider-inspect-expr (cider-last-sexp) (cider-current-ns))) + +;;;###autoload +(defun cider-inspect-defun-at-point () + "Inspect the result of the \"top-level\" expression at point." + (interactive) + (cider-inspect-expr (cider-defun-at-point) (cider-current-ns))) + +;;;###autoload +(defun cider-inspect-last-result () + "Inspect the most recent eval result." + (interactive) + (cider-inspect-expr "*1" (cider-current-ns))) + +;;;###autoload +(defun cider-inspect (&optional arg) + "Inspect the result of the preceding sexp. + +With a prefix argument ARG it inspects the result of the \"top-level\" form. +With a second prefix argument it prompts for an expression to eval and inspect." + (interactive "p") + (pcase arg + (1 (cider-inspect-last-sexp)) + (4 (cider-inspect-defun-at-point)) + (16 (call-interactively #'cider-inspect-expr)))) + +(defvar cider-inspector-location-stack nil + "A stack used to save point locations in inspector buffers. +These locations are used to emulate save-excursion between +`cider-inspector-push' and `cider-inspector-pop' operations.") + +(defvar cider-inspector-page-location-stack nil + "A stack used to save point locations in inspector buffers. +These locations are used to emulate save-excursion between +`cider-inspector-next-page' and `cider-inspector-prev-page' operations.") + +(defvar cider-inspector-last-command nil + "Contains the value of the most recently used `cider-inspector-*' command. +This is used as an alternative to the built-in `last-command'. Whenever we +invoke any command through M-x and its variants, the value of `last-command' +is not set to the command it invokes.") + +;; Operations +;;;###autoload +(defun cider-inspect-expr (expr ns) + "Evaluate EXPR in NS and inspect its value. +Interactively, EXPR is read from the minibuffer, and NS the +current buffer's namespace." + (interactive (list (cider-read-from-minibuffer "Inspect expression: " (cider-sexp-at-point)) + (cider-current-ns))) + (when-let (value (cider-sync-request:inspect-expr expr ns (or cider-inspector-page-size 32))) + (cider-inspector--render-value value))) + +(defun cider-inspector-pop () + (interactive) + (setq cider-inspector-last-command 'cider-inspector-pop) + (when-let (value (cider-sync-request:inspect-pop)) + (cider-inspector--render-value value))) + +(defun cider-inspector-push (idx) + (push (point) cider-inspector-location-stack) + (when-let (value (cider-sync-request:inspect-push idx)) + (cider-inspector--render-value value))) + +(defun cider-inspector-refresh () + (interactive) + (when-let (value (cider-sync-request:inspect-refresh)) + (cider-inspector--render-value value))) + +(defun cider-inspector-next-page () + "Jump to the next page when inspecting a paginated sequence/map. + +Does nothing if already on the last page." + (interactive) + (push (point) cider-inspector-page-location-stack) + (when-let (value (cider-sync-request:inspect-next-page)) + (cider-inspector--render-value value))) + +(defun cider-inspector-prev-page () + "Jump to the previous page when expecting a paginated sequence/map. + +Does nothing if already on the first page." + (interactive) + (setq cider-inspector-last-command 'cider-inspector-prev-page) + (when-let (value (cider-sync-request:inspect-prev-page)) + (cider-inspector--render-value value))) + +(defun cider-inspector-set-page-size (page-size) + "Set the page size in pagination mode to the specified PAGE-SIZE. + +Current page will be reset to zero." + (interactive "nPage size: ") + (when-let (value (cider-sync-request:inspect-set-page-size page-size)) + (cider-inspector--render-value value))) + +;; nREPL interactions +(defun cider-sync-request:inspect-pop () + "Move one level up in the inspector stack." + (thread-first (list "op" "inspect-pop") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "value"))) + +(defun cider-sync-request:inspect-push (idx) + "Inspect the inside value specified by IDX." + (thread-first (list "op" "inspect-push" + "idx" idx) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "value"))) + +(defun cider-sync-request:inspect-refresh () + "Re-render the currently inspected value." + (thread-first (list "op" "inspect-refresh") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "value"))) + +(defun cider-sync-request:inspect-next-page () + "Jump to the next page in paginated collection view." + (thread-first (list "op" "inspect-next-page") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "value"))) + +(defun cider-sync-request:inspect-prev-page () + "Jump to the previous page in paginated collection view." + (thread-first (list "op" "inspect-prev-page") + (cider-nrepl-send-sync-request) + (nrepl-dict-get "value"))) + +(defun cider-sync-request:inspect-set-page-size (page-size) + "Set the page size in paginated view to PAGE-SIZE." + (thread-first (list "op" "inspect-set-page-size" + "page-size" page-size) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "value"))) + +(defun cider-sync-request:inspect-expr (expr ns page-size) + "Evaluate EXPR in context of NS and inspect its result. +Set the page size in paginated view to PAGE-SIZE." + (thread-first (append (nrepl--eval-request expr ns) + (list "inspect" "true" + "page-size" page-size)) + (cider-nrepl-send-sync-request) + (nrepl-dict-get "value"))) + +;; Render Inspector from Structured Values +(defun cider-inspector--render-value (value) + (cider-make-popup-buffer cider-inspector-buffer 'cider-inspector-mode) + (cider-inspector-render cider-inspector-buffer value) + (cider-popup-buffer-display cider-inspector-buffer t) + (when cider-inspector-fill-frame (delete-other-windows)) + (with-current-buffer cider-inspector-buffer + (when (eq cider-inspector-last-command 'cider-inspector-pop) + (setq cider-inspector-last-command nil) + ;; Prevents error message being displayed when we try to pop + ;; from the top-level of a data struture + (when cider-inspector-location-stack + (goto-char (pop cider-inspector-location-stack)))) + + (when (eq cider-inspector-last-command 'cider-inspector-prev-page) + (setq cider-inspector-last-command nil) + ;; Prevents error message being displayed when we try to + ;; go to a prev-page from the first page + (when cider-inspector-page-location-stack + (goto-char (pop cider-inspector-page-location-stack)))))) + +(defun cider-inspector-render (buffer str) + (with-current-buffer buffer + (cider-inspector-mode) + (let ((inhibit-read-only t)) + (condition-case nil + (cider-inspector-render* (car (read-from-string str))) + (error (insert "\nInspector error for: " str)))) + (goto-char (point-min)))) + +(defun cider-inspector-render* (elements) + (dolist (el elements) + (cider-inspector-render-el* el))) + +(defun cider-inspector-render-el* (el) + (cond ((symbolp el) (insert (symbol-name el))) + ((stringp el) (insert (propertize el 'font-lock-face 'font-lock-keyword-face))) + ((and (consp el) (eq (car el) :newline)) + (insert "\n")) + ((and (consp el) (eq (car el) :value)) + (cider-inspector-render-value (cadr el) (cl-caddr el))) + (t (message "Unrecognized inspector object: %s" el)))) + +(defun cider-inspector-render-value (value idx) + (cider-propertize-region + (list 'cider-value-idx idx + 'mouse-face 'highlight) + (cider-inspector-render-el* (cider-font-lock-as-clojure value)))) + + +;; =================================================== +;; Inspector Navigation (lifted from SLIME inspector) +;; =================================================== + +(defun cider-find-inspectable-object (direction limit) + "Find the next/previous inspectable object. +DIRECTION can be either 'next or 'prev. +LIMIT is the maximum or minimum position in the current buffer. + +Return a list of two values: If an object could be found, the +starting position of the found object and T is returned; +otherwise LIMIT and NIL is returned." + (let ((finder (cl-ecase direction + (next 'next-single-property-change) + (prev 'previous-single-property-change)))) + (let ((prop nil) (curpos (point))) + (while (and (not prop) (not (= curpos limit))) + (let ((newpos (funcall finder curpos 'cider-value-idx nil limit))) + (setq prop (get-text-property newpos 'cider-value-idx)) + (setq curpos newpos))) + (list curpos (and prop t))))) + +(defun cider-inspector-next-inspectable-object (arg) + "Move point to the next inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move backwards." + (interactive "p") + (let ((maxpos (point-max)) (minpos (point-min)) + (previously-wrapped-p nil)) + ;; Forward. + (while (> arg 0) + (seq-let (pos foundp) (cider-find-inspectable-object 'next maxpos) + (if foundp + (progn (goto-char pos) (setq arg (1- arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char minpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))) + ;; Backward. + (while (< arg 0) + (seq-let (pos foundp) (cider-find-inspectable-object 'prev minpos) + ;; CIDER-OPEN-INSPECTOR inserts the title of an inspector page + ;; as a presentation at the beginning of the buffer; skip + ;; that. (Notice how this problem can not arise in ``Forward.'') + (if (and foundp (/= pos minpos)) + (progn (goto-char pos) (setq arg (1+ arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char maxpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))))) + +(defun cider-inspector-previous-inspectable-object (arg) + "Move point to the previous inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move forwards." + (interactive "p") + (cider-inspector-next-inspectable-object (- arg))) + +(defun cider-inspector-property-at-point () + (let* ((properties '(cider-value-idx cider-range-button + cider-action-number)) + (find-property + (lambda (point) + (cl-loop for property in properties + for value = (get-text-property point property) + when value + return (list property value))))) + (or (funcall find-property (point)) + (funcall find-property (1- (point)))))) + +(defun cider-inspector-operate-on-point () + "Invoke the command for the text at point. +1. If point is on a value then recursively call the inspector on +that value. +2. If point is on an action then call that action. +3. If point is on a range-button fetch and insert the range." + (interactive) + (seq-let (property value) (cider-inspector-property-at-point) + (cl-case property + (cider-value-idx + (cider-inspector-push value)) + ;; TODO: range and action handlers + (t (error "No object at point"))))) + +(defun cider-inspector-operate-on-click (event) + "Move to EVENT's position and operate the part." + (interactive "@e") + (let ((point (posn-point (event-end event)))) + (cond ((and point + (or (get-text-property point 'cider-value-idx))) + (goto-char point) + (cider-inspector-operate-on-point)) + (t + (error "No clickable part here"))))) + +;;;###autoload +(define-obsolete-function-alias 'cider-inspect-read-and-inspect + 'cider-inspect-expr "0.13.0") + +(provide 'cider-inspector) + +;;; cider-inspector.el ends here diff --git a/elpa/cider-20170129.1941/cider-interaction.el b/elpa/cider-20170129.1941/cider-interaction.el new file mode 100644 index 00000000..d08d6d09 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-interaction.el @@ -0,0 +1,1828 @@ +;;; cider-interaction.el --- IDE for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; 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 'subr-x) +(require 'cider-compat) + +(require 'clojure-mode) +(require 'thingatpt) +(require 'arc-mode) +(require 'ansi-color) +(require 'cl-lib) +(require 'compile) +(require 'etags) ; for find-tags-marker-ring +(require 'tramp) + +(defconst cider-read-eval-buffer "*cider-read-eval*") +(defconst cider-result-buffer "*cider-result*") +(defconst cider-nrepl-session-buffer "*cider-nrepl-session*") +(add-to-list 'cider-ancillary-buffers cider-nrepl-session-buffer) + +(defcustom cider-show-error-buffer t + "Control the popup behavior of cider stacktraces. +The following values are possible t or 'always, 'except-in-repl, +'only-in-repl. Any other value, including nil, will cause the stacktrace +not to be automatically shown. + +Irespective of the value of this variable, the `cider-error-buffer' is +always generated in the background. Use `cider-visit-error-buffer' to +navigate to this buffer." + :type '(choice (const :tag "always" t) + (const except-in-repl) + (const only-in-repl) + (const :tag "never" nil)) + :group 'cider) + +(defcustom cider-auto-jump-to-error t + "Control the cursor jump behaviour in compilation error buffer. + +When non-nil automatically jump to error location during interactive +compilation. When set to 'errors-only, don't jump to warnings. +When set to nil, don't jump at all." + :type '(choice (const :tag "always" t) + (const errors-only) + (const :tag "never" nil)) + :group 'cider + :package-version '(cider . "0.7.0")) + +(defcustom cider-auto-select-error-buffer t + "Controls whether to auto-select the error popup buffer." + :type 'boolean + :group 'cider) + +(defcustom cider-prompt-save-file-on-load t + "Controls whether to prompt to save the file when loading a buffer. +If nil, files are not saved. +If t, the user is prompted to save the file if it's been modified. +If the symbol `always-save', save the file without confirmation." + :type '(choice (const t :tag "Prompt to save the file if it's been modified") + (const nil :tag "Don't save the file") + (const always-save :tag "Save the file without confirmation")) + :group 'cider + :package-version '(cider . "0.6.0")) + +(defcustom cider-completion-use-context t + "When true, uses context at point to improve completion suggestions." + :type 'boolean + :group 'cider + :package-version '(cider . "0.7.0")) + +(defcustom cider-annotate-completion-candidates t + "When true, annotate completion candidates with some extra information." + :type 'boolean + :group 'cider + :package-version '(cider . "0.8.0")) + +(defcustom cider-annotate-completion-function + #'cider-default-annotate-completion-function + "Controls how the annotations for completion candidates are formatted. + +Must be a function that takes two arguments: the abbreviation of the +candidate type according to `cider-completion-annotations-alist' and the +candidate's namespace." + :type 'function + :group 'cider + :package-version '(cider . "0.9.0")) + +(defcustom cider-completion-annotations-alist + '(("class" "c") + ("field" "fi") + ("function" "f") + ("import" "i") + ("keyword" "k") + ("local" "l") + ("macro" "m") + ("method" "me") + ("namespace" "n") + ("protocol" "p") + ("protocol-function" "pf") + ("record" "r") + ("special-form" "s") + ("static-field" "sf") + ("static-method" "sm") + ("type" "t") + ("var" "v")) + "Controls the abbreviations used when annotating completion candidates. + +Must be a list of elements with the form (TYPE . ABBREVIATION), where TYPE +is a possible value of the candidate's type returned from the completion +backend, and ABBREVIATION is a short form of that type." + :type '(alist :key-type string :value-type string) + :group 'cider + :package-version '(cider . "0.9.0")) + +(defcustom cider-completion-annotations-include-ns 'unqualified + "Controls passing of namespaces to `cider-annotate-completion-function'. + +When set to 'always, the candidate's namespace will always be passed if it +is available. When set to 'unqualified, the namespace will only be passed +if the candidate is not namespace-qualified." + :type '(choice (const always) + (const unqualified) + (const :tag "never" nil)) + :group 'cider + :package-version '(cider . "0.9.0")) + +(defconst cider-refresh-log-buffer "*cider-refresh-log*") + +(defcustom cider-refresh-show-log-buffer nil + "Controls when to display the refresh log buffer. + +If non-nil, the log buffer will be displayed every time `cider-refresh' is +called. + +If nil, the log buffer will still be written to, but will never be +displayed automatically. Instead, the most relevant information will be +displayed in the echo area." + :type '(choice (const :tag "always" t) + (const :tag "never" nil)) + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-refresh-before-fn nil + "Clojure function for `cider-refresh' to call before reloading. + +If nil, nothing will be invoked before reloading. Must be a +namespace-qualified function of zero arity. Any thrown exception will +prevent reloading from occurring." + :type 'string + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-refresh-after-fn nil + "Clojure function for `cider-refresh' to call after reloading. + +If nil, nothing will be invoked after reloading. Must be a +namespace-qualified function of zero arity." + :type 'string + :group 'cider + :package-version '(cider . "0.10.0")) + +(defconst cider-output-buffer "*cider-out*") + +(defcustom cider-interactive-eval-output-destination 'repl-buffer + "The destination for stdout and stderr produced from interactive evaluation." + :type '(choice (const output-buffer) + (const repl-buffer)) + :group 'cider + :package-version '(cider . "0.7.0")) + +(defface cider-error-highlight-face + '((((supports :underline (:style wave))) + (:underline (:style wave :color "red") :inherit unspecified)) + (t (:inherit font-lock-warning-face :underline t))) + "Face used to highlight compilation errors in Clojure buffers." + :group 'cider) + +(defface cider-warning-highlight-face + '((((supports :underline (:style wave))) + (:underline (:style wave :color "yellow") :inherit unspecified)) + (t (:inherit font-lock-warning-face :underline (:color "yellow")))) + "Face used to highlight compilation warnings in Clojure buffers." + :group 'cider) + +(defconst cider-clojure-artifact-id "org.clojure/clojure" + "Artifact identifier for Clojure.") + +(defconst cider-minimum-clojure-version "1.7.0" + "Minimum supported version of Clojure.") + +(defconst cider-latest-clojure-version "1.8.0" + "Latest supported version of Clojure.") + +(defconst cider-required-nrepl-version "0.2.12" + "The minimum nREPL version that's known to work properly with CIDER.") + +;;; Minibuffer +(defvar cider-minibuffer-history '() + "History list of expressions read from the minibuffer.") + +(defvar cider-minibuffer-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map (kbd "TAB") #'complete-symbol) + (define-key map (kbd "M-TAB") #'complete-symbol) + map) + "Minibuffer keymap used for reading Clojure expressions.") + +(defvar-local cider-connection-created-with 'jack-in + "Save how the connection was created. +Its value can be either 'jack-in or 'connect.") + +(defun cider-read-from-minibuffer (prompt &optional value) + "Read a string from the minibuffer, prompting with PROMPT. +If VALUE is non-nil, it is inserted into the minibuffer as initial-input. + +PROMPT need not end with \": \". If it doesn't, VALUE is displayed on the +prompt as a default value (used if the user doesn't type anything) and is +not used as initial input (input is left empty)." + (minibuffer-with-setup-hook + (lambda () + (set-syntax-table clojure-mode-syntax-table) + (add-hook 'completion-at-point-functions + #'cider-complete-at-point nil t) + (setq-local eldoc-documentation-function #'cider-eldoc) + (run-hooks 'eval-expression-minibuffer-setup-hook)) + (let* ((has-colon (string-match ": \\'" prompt)) + (input (read-from-minibuffer (cond + (has-colon prompt) + (value (format "%s (default %s): " prompt value)) + (t (format "%s: " prompt))) + (when has-colon value) ; initial-input + cider-minibuffer-map nil + 'cider-minibuffer-history + (unless has-colon value)))) ; default-value + (if (and (equal input "") value (not has-colon)) + value + input)))) + + +;;; Utilities + +(defun cider--clear-compilation-highlights () + "Remove compilation highlights." + (remove-overlays (point-min) (point-max) 'cider-note-p t)) + +(defun cider-clear-compilation-highlights (&optional arg) + "Remove compilation highlights. + +When invoked with a prefix ARG the command doesn't prompt for confirmation." + (interactive "P") + (when (or arg (y-or-n-p "Are you sure you want to clear the compilation highlights? ")) + (cider--clear-compilation-highlights))) + +(defun cider--quit-error-window () + "Buries the `cider-error-buffer' and quits its containing window." + (when-let ((error-win (get-buffer-window cider-error-buffer))) + (quit-window nil error-win))) + +;;; +(declare-function cider-mode "cider-mode") + +(defun cider-jump-to (buffer &optional pos other-window) + "Push current point onto marker ring, and jump to BUFFER and POS. +POS can be either a number, a cons, or a symbol. +If a number, it is the character position (the point). +If a cons, it specifies the position as (LINE . COLUMN). COLUMN can be nil. +If a symbol, `cider-jump-to' searches for something that looks like the +symbol's definition in the file. +If OTHER-WINDOW is non-nil don't reuse current window." + (with-no-warnings + (ring-insert find-tag-marker-ring (point-marker))) + (if other-window + (pop-to-buffer buffer) + ;; like switch-to-buffer, but reuse existing window if BUFFER is visible + (pop-to-buffer buffer '((display-buffer-reuse-window display-buffer-same-window)))) + (with-current-buffer buffer + (widen) + (goto-char (point-min)) + (cider-mode +1) + (cond + ;; Line-column specification. + ((consp pos) + (forward-line (1- (or (car pos) 1))) + (if (cdr pos) + (move-to-column (cdr pos)) + (back-to-indentation))) + ;; Point specification. + ((numberp pos) + (goto-char pos)) + ;; Symbol or string. + (pos + ;; Try to find (def full-name ...). + (if (or (save-excursion + (search-forward-regexp (format "(def.*\\s-\\(%s\\)" (regexp-quote pos)) + nil 'noerror)) + (let ((name (replace-regexp-in-string ".*/" "" pos))) + ;; Try to find (def name ...). + (or (save-excursion + (search-forward-regexp (format "(def.*\\s-\\(%s\\)" (regexp-quote name)) + nil 'noerror)) + ;; Last resort, just find the first occurrence of `name'. + (save-excursion + (search-forward name nil 'noerror))))) + (goto-char (match-beginning 0)) + (message "Can't find %s in %s" pos (buffer-file-name)))) + (t nil)))) + +(defun cider-find-dwim-other-window (symbol-file) + "Jump to SYMBOL-FILE at point, place results in other window." + (interactive (cider--find-dwim-interactive "Jump to: ")) + (cider--find-dwim symbol-file 'cider-find-dwim-other-window t)) + +(defun cider-find-dwim (symbol-file) + "Find and display the SYMBOL-FILE at point. + +SYMBOL-FILE could be a var or a resource. If thing at point is empty +then show dired on project. If var is not found, try to jump to resource +of the same name. When called interactively, a prompt is given according +to the variable `cider-prompt-for-symbol'. A single or double prefix argument +inverts the meaning. A prefix of `-' or a double prefix argument causes the +results to be displayed in a different window. +A default value of thing at point is given when prompted." + (interactive (cider--find-dwim-interactive "Jump to: ")) + (cider--find-dwim symbol-file `cider-find-dwim + (cider--open-other-window-p current-prefix-arg))) + +(defun cider--find-dwim (symbol-file callback &optional other-window) + "Find the SYMBOL-FILE at point. + +CALLBACK upon failure to invoke prompt if not prompted previously. +Show results in a different window if OTHER-WINDOW is true." + (if-let ((info (cider-var-info symbol-file))) + (cider--jump-to-loc-from-info info other-window) + (progn + (cider-ensure-op-supported "resource") + (if-let ((resource (cider-sync-request:resource symbol-file)) + (buffer (cider-find-file resource))) + (cider-jump-to buffer 0 other-window) + (if (cider--prompt-for-symbol-p current-prefix-arg) + (error "Resource or var %s not resolved" symbol-file) + (let ((current-prefix-arg (if current-prefix-arg nil '(4)))) + (call-interactively callback))))))) + +(defun cider--find-dwim-interactive (prompt) + "Get interactive arguments for jump-to functions using PROMPT as needed." + (if (cider--prompt-for-symbol-p current-prefix-arg) + (list + (cider-read-from-minibuffer prompt (thing-at-point 'filename))) + (list (or (thing-at-point 'filename) "")))) ; No prompt. + +(defun cider-find-resource (path) + "Find the resource at PATH. + +Prompt for input as indicated by the variable `cider-prompt-for-symbol'. +A single or double prefix argument inverts the meaning of +`cider-prompt-for-symbol'. A prefix argument of `-` or a double prefix +argument causes the results to be displayed in other window. The default +value is thing at point." + (interactive + (list + (if (cider--prompt-for-symbol-p current-prefix-arg) + (completing-read "Resource: " + (cider-sync-request:resources-list) + nil nil + (thing-at-point 'filename)) + (or (thing-at-point 'filename) "")))) + (cider-ensure-op-supported "resource") + (when (= (length path) 0) + (error "Cannot find resource for empty path")) + (if-let ((resource (cider-sync-request:resource path)) + (buffer (cider-find-file resource))) + (cider-jump-to buffer nil (cider--open-other-window-p current-prefix-arg)) + (if (cider--prompt-for-symbol-p current-prefix-arg) + (error "Cannot find resource %s" path) + (let ((current-prefix-arg (cider--invert-prefix-arg current-prefix-arg))) + (call-interactively `cider-find-resource))))) + +(defun cider--invert-prefix-arg (arg) + "Invert the effect of prefix value ARG on `cider-prompt-for-symbol'. + +This function preserves the `other-window' meaning of ARG." + (let ((narg (prefix-numeric-value arg))) + (pcase narg + (16 -1) ; empty empty -> - + (-1 16) ; - -> empty empty + (4 nil) ; empty -> no-prefix + (_ 4)))) ; no-prefix -> empty + +(defun cider--prefix-invert-prompt-p (arg) + "Test prefix value ARG for its effect on `cider-prompt-for-symbol`." + (let ((narg (prefix-numeric-value arg))) + (pcase narg + (16 t) ; empty empty + (4 t) ; empty + (_ nil)))) + +(defun cider--prompt-for-symbol-p (&optional prefix) + "Check if cider should prompt for symbol. + +Tests againsts PREFIX and the value of `cider-prompt-for-symbol'. +Invert meaning of `cider-prompt-for-symbol' if PREFIX indicates it should be." + (if (cider--prefix-invert-prompt-p prefix) + (not cider-prompt-for-symbol) cider-prompt-for-symbol)) + +(defun cider-sync-request:ns-path (ns) + "Get the path to the file containing NS." + (thread-first (list "op" "ns-path" + "ns" ns) + cider-nrepl-send-sync-request + (nrepl-dict-get "path"))) + +(defun cider--find-ns (ns &optional other-window) + "Find the file containing NS's definition. +Optionally open it in a different window if OTHER-WINDOW is truthy." + (if-let ((path (cider-sync-request:ns-path ns))) + (cider-jump-to (cider-find-file path) nil other-window) + (user-error "Can't find %s" ns))) + +(defun cider-find-ns (&optional arg ns) + "Find the file containing NS. + +A prefix ARG of `-` or a double prefix argument causes +the results to be displayed in a different window." + (interactive "P") + (cider-ensure-connected) + (cider-ensure-op-supported "ns-path") + (if ns + (cider--find-ns ns) + (let* ((namespaces (cider-sync-request:ns-list)) + (ns (completing-read "Find namespace: " namespaces))) + (cider--find-ns ns (cider--open-other-window-p arg))))) + +(defvar cider-completion-last-context nil) + +(defun cider-completion-symbol-start-pos () + "Find the starting position of the symbol at point, unless inside a string." + (let ((sap (symbol-at-point))) + (when (and sap (not (nth 3 (syntax-ppss)))) + (car (bounds-of-thing-at-point 'symbol))))) + +(defun cider-completion-get-context-at-point () + "Extract the context at point. +If point is not inside the list, returns nil; otherwise return \"top-level\" +form, with symbol at point replaced by __prefix__." + (when (save-excursion + (condition-case _ + (progn + (up-list) + (check-parens) + t) + (scan-error nil) + (user-error nil))) + (save-excursion + (let* ((pref-end (point)) + (pref-start (cider-completion-symbol-start-pos)) + (context (cider-defun-at-point)) + (_ (beginning-of-defun)) + (expr-start (point))) + (concat (when pref-start (substring context 0 (- pref-start expr-start))) + "__prefix__" + (substring context (- pref-end expr-start))))))) + +(defun cider-completion-get-context () + "Extract context depending on `cider-completion-use-context' and major mode." + (let ((context (if (and cider-completion-use-context + ;; Important because `beginning-of-defun' and + ;; `ending-of-defun' work incorrectly in the REPL + ;; buffer, so context extraction fails there. + (derived-mode-p 'clojure-mode)) + (or (cider-completion-get-context-at-point) + "nil") + "nil"))) + (if (string= cider-completion-last-context context) + ":same" + (setq cider-completion-last-context context) + context))) + +(defun cider-completion--parse-candidate-map (candidate-map) + (let ((candidate (nrepl-dict-get candidate-map "candidate")) + (type (nrepl-dict-get candidate-map "type")) + (ns (nrepl-dict-get candidate-map "ns"))) + (put-text-property 0 1 'type type candidate) + (put-text-property 0 1 'ns ns candidate) + candidate)) + +(defun cider-complete (str) + "Complete STR with context at point." + (let* ((context (cider-completion-get-context)) + (candidates (cider-sync-request:complete str context))) + (mapcar #'cider-completion--parse-candidate-map candidates))) + +(defun cider-completion--get-candidate-type (symbol) + (let ((type (get-text-property 0 'type symbol))) + (or (cadr (assoc type cider-completion-annotations-alist)) + type))) + +(defun cider-completion--get-candidate-ns (symbol) + (when (or (eq 'always cider-completion-annotations-include-ns) + (and (eq 'unqualified cider-completion-annotations-include-ns) + (not (cider-namespace-qualified-p symbol)))) + (get-text-property 0 'ns symbol))) + +(defun cider-default-annotate-completion-function (type ns) + (concat (when ns (format " (%s)" ns)) + (when type (format " <%s>" type)))) + +(defun cider-annotate-symbol (symbol) + "Return a string suitable for annotating SYMBOL. + +If SYMBOL has a text property `type` whose value is recognised, its +abbreviation according to `cider-completion-annotations-alist' will be +used. If `type` is present but not recognised, its value will be used +unaltered. + +If SYMBOL has a text property `ns`, then its value will be used according +to `cider-completion-annotations-include-ns'. + +The formatting is performed by `cider-annotate-completion-function'." + (when cider-annotate-completion-candidates + (let* ((type (cider-completion--get-candidate-type symbol)) + (ns (cider-completion--get-candidate-ns symbol))) + (funcall cider-annotate-completion-function type ns)))) + +(defun cider-complete-at-point () + "Complete the symbol at point." + (when-let ((bounds (bounds-of-thing-at-point 'symbol))) + (when (and (cider-connected-p) + (not (or (cider-in-string-p) (cider-in-comment-p)))) + (list (car bounds) (cdr bounds) + (completion-table-dynamic #'cider-complete) + :annotation-function #'cider-annotate-symbol + :company-doc-buffer #'cider-create-doc-buffer + :company-location #'cider-company-location + :company-docsig #'cider-company-docsig)))) + +(defun cider-company-location (var) + "Open VAR's definition in a buffer. + +Returns the cons of the buffer itself and the location of VAR's definition +in the buffer." + (when-let ((info (cider-var-info var)) + (file (nrepl-dict-get info "file")) + (line (nrepl-dict-get info "line")) + (buffer (cider-find-file file))) + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (cons buffer (point)))))) + +(defun cider-company-docsig (thing) + "Return signature for THING." + (let* ((eldoc-info (cider-eldoc-info thing)) + (ns (lax-plist-get eldoc-info "ns")) + (symbol (lax-plist-get eldoc-info "symbol")) + (arglists (lax-plist-get eldoc-info "arglists"))) + (when eldoc-info + (format "%s: %s" + (cider-eldoc-format-thing ns symbol thing + (cider-eldoc-thing-type eldoc-info)) + (cider-eldoc-format-arglist arglists 0))))) + +;; Fuzzy completion for company-mode + +(defun cider-company-unfiltered-candidates (string table predicate point) + "Return CIDER completion candidates as is, without filtering them by prefix." + (cider-complete string)) + +(add-to-list 'completion-styles-alist + '(cider + cider-company-unfiltered-candidates + cider-company-unfiltered-candidates + "CIDER backend-driven completion style.")) + +(defun cider-company-enable-fuzzy-completion () + "Enable backend-driven fuzzy completion in the current buffer." + (setq-local completion-styles '(cider))) + +(defun cider-stdin-handler (&optional buffer) + "Make a stdin response handler for BUFFER." + (nrepl-make-response-handler (or buffer (current-buffer)) + (lambda (buffer value) + (cider-repl-emit-result buffer value t)) + (lambda (buffer out) + (cider-repl-emit-stdout buffer out)) + (lambda (buffer err) + (cider-repl-emit-stderr buffer err)) + nil)) + +(defun cider-insert-eval-handler (&optional buffer) + "Make an nREPL evaluation handler for the BUFFER. +The handler simply inserts the result value in BUFFER." + (let ((eval-buffer (current-buffer))) + (nrepl-make-response-handler (or buffer eval-buffer) + (lambda (_buffer value) + (with-current-buffer buffer + (insert value))) + (lambda (_buffer out) + (cider-repl-emit-interactive-stdout out)) + (lambda (_buffer err) + (cider-handle-compilation-errors err eval-buffer)) + '()))) + +(defun cider--emit-interactive-eval-output (output repl-emit-function) + "Emit output resulting from interactive code evaluation. + +The OUTPUT can be sent to either a dedicated output buffer or the current +REPL buffer. This is controlled by `cider-interactive-eval-output-destination'. +REPL-EMIT-FUNCTION emits the OUTPUT." + (pcase cider-interactive-eval-output-destination + (`output-buffer (let ((output-buffer (or (get-buffer cider-output-buffer) + (cider-popup-buffer cider-output-buffer t)))) + (cider-emit-into-popup-buffer output-buffer output) + (pop-to-buffer output-buffer))) + (`repl-buffer (funcall repl-emit-function output)) + (_ (error "Unsupported value %s for `cider-interactive-eval-output-destination'" + cider-interactive-eval-output-destination)))) + +(defun cider-emit-interactive-eval-output (output) + "Emit OUTPUT resulting from interactive code evaluation. + +The output can be send to either a dedicated output buffer or the current +REPL buffer. This is controlled via +`cider-interactive-eval-output-destination'." + (cider--emit-interactive-eval-output output 'cider-repl-emit-interactive-stdout)) + +(defun cider-emit-interactive-eval-err-output (output) + "Emit err OUTPUT resulting from interactive code evaluation. + +The output can be send to either a dedicated output buffer or the current +REPL buffer. This is controlled via +`cider-interactive-eval-output-destination'." + (cider--emit-interactive-eval-output output 'cider-repl-emit-interactive-stderr)) + +(defun cider--make-fringe-overlays-for-region (beg end) + "Place eval indicators on all sexps between BEG and END." + (with-current-buffer (if (markerp end) + (marker-buffer end) + (current-buffer)) + (save-excursion + (goto-char beg) + (condition-case nil + (while (progn (clojure-forward-logical-sexp) + (and (<= (point) end) + (not (eobp)))) + (cider--make-fringe-overlay (point))) + (scan-error nil))))) + +(defun cider-interactive-eval-handler (&optional buffer place) + "Make an interactive eval handler for BUFFER. +PLACE is used to display the evaluation result. +If non-nil, it can be the position where the evaluated sexp ends, +or it can be a list with (START END) of the evaluated region." + (let* ((eval-buffer (current-buffer)) + (beg (car-safe place)) + (end (or (car-safe (cdr-safe place)) place)) + (beg (when beg (copy-marker beg))) + (end (when end (copy-marker end)))) + (nrepl-make-response-handler (or buffer eval-buffer) + (lambda (_buffer value) + (if beg + (cider--make-fringe-overlays-for-region beg end) + (cider--make-fringe-overlay end)) + (cider--display-interactive-eval-result value end)) + (lambda (_buffer out) + (cider-emit-interactive-eval-output out)) + (lambda (_buffer err) + (cider-emit-interactive-eval-err-output err) + (cider-handle-compilation-errors err eval-buffer)) + '()))) + +(defun cider-load-file-handler (&optional buffer) + "Make a load file handler for BUFFER." + (let ((eval-buffer (current-buffer))) + (nrepl-make-response-handler (or buffer eval-buffer) + (lambda (buffer value) + (cider--display-interactive-eval-result value) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (cider--make-fringe-overlays-for-region (point-min) (point-max)) + (run-hooks 'cider-file-loaded-hook)))) + (lambda (_buffer value) + (cider-emit-interactive-eval-output value)) + (lambda (_buffer err) + (cider-emit-interactive-eval-err-output err) + (cider-handle-compilation-errors err eval-buffer)) + '() + (lambda () + (funcall nrepl-err-handler))))) + +(defun cider-eval-print-handler (&optional buffer) + "Make a handler for evaluating and printing result in BUFFER." + (nrepl-make-response-handler (or buffer (current-buffer)) + (lambda (buffer value) + (with-current-buffer buffer + (insert + (if (derived-mode-p 'cider-clojure-interaction-mode) + (format "\n%s\n" value) + value)))) + (lambda (_buffer out) + (cider-emit-interactive-eval-output out)) + (lambda (_buffer err) + (cider-emit-interactive-eval-err-output err)) + '())) + +(defun cider-eval-print-with-comment-handler (buffer location comment-prefix) + "Make a handler for evaluating and printing commented results in BUFFER. + +LOCATION is the location at which to insert. +COMMENT-PREFIX is the comment prefix to use." + (nrepl-make-response-handler buffer + (lambda (buffer value) + (with-current-buffer buffer + (save-excursion + (goto-char location) + (insert (concat comment-prefix + value "\n"))))) + (lambda (_buffer out) + (cider-emit-interactive-eval-output out)) + (lambda (_buffer err) + (cider-emit-interactive-eval-err-output err)) + '())) + +(defun cider-popup-eval-out-handler (&optional buffer) + "Make a handler for evaluating and printing stdout/stderr in popup BUFFER. + +This is used by pretty-printing commands and intentionally discards their results." + (nrepl-make-response-handler (or buffer (current-buffer)) + '() + ;; stdout handler + (lambda (buffer str) + (cider-emit-into-popup-buffer buffer (ansi-color-apply str))) + ;; stderr handler + (lambda (buffer str) + (cider-emit-into-popup-buffer buffer (ansi-color-apply str))) + '())) + +(defun cider-visit-error-buffer () + "Visit the `cider-error-buffer' (usually *cider-error*) if it exists." + (interactive) + (if-let ((buffer (get-buffer cider-error-buffer))) + (cider-popup-buffer-display buffer cider-auto-select-error-buffer) + (user-error "No %s buffer" cider-error-buffer))) + +(defun cider-find-property (property &optional backward) + "Find the next text region which has the specified PROPERTY. +If BACKWARD is t, then search backward. +Returns the position at which PROPERTY was found, or nil if not found." + (let ((p (if backward + (previous-single-char-property-change (point) property) + (next-single-char-property-change (point) property)))) + (when (and (not (= p (point-min))) (not (= p (point-max)))) + p))) + +(defun cider-jump-to-compilation-error (&optional _arg _reset) + "Jump to the line causing the current compilation error. +_ARG and _RESET are ignored, as there is only ever one compilation error. +They exist for compatibility with `next-error'." + (interactive) + (cl-labels ((goto-next-note-boundary + () + (let ((p (or (cider-find-property 'cider-note-p) + (cider-find-property 'cider-note-p t)))) + (when p + (goto-char p) + (message "%s" (get-char-property p 'cider-note)))))) + ;; if we're already on a compilation error, first jump to the end of + ;; it, so that we find the next error. + (when (get-char-property (point) 'cider-note-p) + (goto-next-note-boundary)) + (goto-next-note-boundary))) + +(defun cider--show-error-buffer-p () + "Return non-nil if the error buffer must be shown on error. + +Takes into account both the value of `cider-show-error-buffer' and the +currently selected buffer." + (let* ((selected-buffer (window-buffer (selected-window))) + (replp (with-current-buffer selected-buffer (derived-mode-p 'cider-repl-mode)))) + (memq cider-show-error-buffer + (if replp + '(t always only-in-repl) + '(t always except-in-repl))))) + +(defun cider-new-error-buffer (&optional mode error-types) + "Return an empty error buffer using MODE. + +When deciding whether to display the buffer, takes into account not only +the value of `cider-show-error-buffer' and the currently selected buffer +but also the ERROR-TYPES of the error, which is checked against the +`cider-stacktrace-suppressed-errors' set. + +When deciding whether to select the buffer, takes into account the value of +`cider-auto-select-error-buffer'." + (if (and (cider--show-error-buffer-p) + (not (cider-stacktrace-some-suppressed-errors-p error-types))) + (cider-popup-buffer cider-error-buffer cider-auto-select-error-buffer mode) + (cider-make-popup-buffer cider-error-buffer mode))) + +(defun cider--handle-err-eval-response (response) + "Render eval RESPONSE into a new error buffer. + +Uses the value of the `out' slot in RESPONSE." + (nrepl-dbind-response response (out) + (when out + (let ((error-buffer (cider-new-error-buffer))) + (cider-emit-into-color-buffer error-buffer out) + (with-current-buffer error-buffer + (compilation-minor-mode +1)))))) + +(defun cider-default-err-eval-handler () + "Display the last exception without middleware support." + (cider--handle-err-eval-response + (cider-nrepl-sync-request:eval + "(clojure.stacktrace/print-cause-trace *e)"))) + +(defun cider--render-stacktrace-causes (causes &optional error-types) + "If CAUSES is non-nil, render its contents into a new error buffer. +Optional argument ERROR-TYPES contains a list which should determine the +op/situation that originated this error." + (when causes + (let ((error-buffer (cider-new-error-buffer #'cider-stacktrace-mode error-types))) + (cider-stacktrace-render error-buffer (reverse causes) error-types)))) + +(defun cider--handle-stacktrace-response (response causes) + "Handle stacktrace op RESPONSE, aggregating the result into CAUSES. + +If RESPONSE contains a cause, cons it onto CAUSES and return that. If +RESPONSE is the final message (i.e. it contains a status), render CAUSES +into a new error buffer." + (nrepl-dbind-response response (class status) + (cond (class (cons response causes)) + (status (cider--render-stacktrace-causes causes))))) + +(defun cider-default-err-op-handler () + "Display the last exception, with middleware support." + ;; Causes are returned as a series of messages, which we aggregate in `causes' + (let (causes) + (cider-nrepl-send-request + (append + (list "op" "stacktrace") + (when (cider--pprint-fn) + (list "pprint-fn" (cider--pprint-fn))) + (when cider-stacktrace-print-length + (list "print-length" cider-stacktrace-print-length)) + (when cider-stacktrace-print-level + (list "print-level" cider-stacktrace-print-level))) + (lambda (response) + ;; While the return value of `cider--handle-stacktrace-response' is not + ;; meaningful for the last message, we do not need the value of `causes' + ;; after it has been handled, so it's fine to set it unconditionally here + (setq causes (cider--handle-stacktrace-response response causes)))))) + +(defun cider-default-err-handler () + "This function determines how the error buffer is shown. +It delegates the actual error content to the eval or op handler." + (if (cider-nrepl-op-supported-p "stacktrace") + (cider-default-err-op-handler) + (cider-default-err-eval-handler))) + +(defvar cider-compilation-regexp + '("\\(?:.*\\(warning, \\)\\|.*?\\(, compiling\\):(\\)\\(.*?\\):\\([[:digit:]]+\\)\\(?::\\([[:digit:]]+\\)\\)?\\(\\(?: - \\(.*\\)\\)\\|)\\)" 3 4 5 (1)) + "Specifications for matching errors and warnings in Clojure stacktraces. +See `compilation-error-regexp-alist' for help on their format.") + +(add-to-list 'compilation-error-regexp-alist-alist + (cons 'cider cider-compilation-regexp)) +(add-to-list 'compilation-error-regexp-alist 'cider) + +(defun cider-extract-error-info (regexp message) + "Extract error information with REGEXP against MESSAGE." + (let ((file (nth 1 regexp)) + (line (nth 2 regexp)) + (col (nth 3 regexp)) + (type (nth 4 regexp)) + (pat (car regexp))) + (when (string-match pat message) + ;; special processing for type (1.2) style + (setq type (if (consp type) + (or (and (car type) (match-end (car type)) 1) + (and (cdr type) (match-end (cdr type)) 0) + 2))) + (list + (when file + (let ((val (match-string-no-properties file message))) + (unless (string= val "NO_SOURCE_PATH") val))) + (when line (string-to-number (match-string-no-properties line message))) + (when col + (let ((val (match-string-no-properties col message))) + (when val (string-to-number val)))) + (aref [cider-warning-highlight-face + cider-warning-highlight-face + cider-error-highlight-face] + (or type 2)) + message)))) + +(defun cider--goto-expression-start () + "Go to the beginning a list, vector, map or set outside of a string. + +We do so by starting and the current position and proceeding backwards +until we find a delimiters that's not inside a string." + (if (and (looking-back "[])}]" (line-beginning-position)) + (null (nth 3 (syntax-ppss)))) + (backward-sexp) + (while (or (not (looking-at-p "[({[]")) + (nth 3 (syntax-ppss))) + (backward-char)))) + +(defun cider--find-last-error-location (message) + "Return the location (begin end buffer) from the Clojure error MESSAGE. +If location could not be found, return nil." + (save-excursion + (let ((info (cider-extract-error-info cider-compilation-regexp message))) + (when info + (let ((file (nth 0 info)) + (line (nth 1 info)) + (col (nth 2 info))) + (unless (or (not (stringp file)) + (cider--tooling-file-p file)) + (when-let ((buffer (cider-find-file file))) + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- line)) + (move-to-column (or col 0)) + (let ((begin (progn (if col (cider--goto-expression-start) (back-to-indentation)) + (point))) + (end (progn (if col (forward-list) (move-end-of-line nil)) + (point)))) + (list begin end buffer)))))))))))) + +(defun cider-handle-compilation-errors (message eval-buffer) + "Highlight and jump to compilation error extracted from MESSAGE. +EVAL-BUFFER is the buffer that was current during user's interactive +evaluation command. Honor `cider-auto-jump-to-error'." + (when-let ((loc (cider--find-last-error-location message)) + (overlay (make-overlay (nth 0 loc) (nth 1 loc) (nth 2 loc))) + (info (cider-extract-error-info cider-compilation-regexp message))) + (let* ((face (nth 3 info)) + (note (nth 4 info)) + (auto-jump (if (eq cider-auto-jump-to-error 'errors-only) + (not (eq face 'cider-warning-highlight-face)) + cider-auto-jump-to-error))) + (overlay-put overlay 'cider-note-p t) + (overlay-put overlay 'font-lock-face face) + (overlay-put overlay 'cider-note note) + (overlay-put overlay 'help-echo note) + (overlay-put overlay 'modification-hooks + (list (lambda (o &rest _args) (delete-overlay o)))) + (when auto-jump + (with-current-buffer eval-buffer + (push-mark) + ;; At this stage selected window commonly is *cider-error* and we need to + ;; re-select the original user window. If eval-buffer is not + ;; visible it was probably covered as a result of a small screen or user + ;; configuration (https://github.com/clojure-emacs/cider/issues/847). In + ;; that case we don't jump at all in order to avoid covering *cider-error* + ;; buffer. + (when-let ((win (get-buffer-window eval-buffer))) + (with-selected-window win + (cider-jump-to (nth 2 loc) (car loc))))))))) + +(defun cider-need-input (buffer) + "Handle an need-input request from BUFFER." + (with-current-buffer buffer + (nrepl-request:stdin (concat (read-from-minibuffer "Stdin: ") "\n") + (cider-stdin-handler buffer) + (cider-current-connection)))) + +(defun cider-emit-into-color-buffer (buffer value) + "Emit into color BUFFER the provided VALUE." + (with-current-buffer buffer + (let ((inhibit-read-only t) + (buffer-undo-list t)) + (goto-char (point-max)) + (insert (format "%s" value)) + (ansi-color-apply-on-region (point-min) (point-max))) + (goto-char (point-min)))) + + +;;; Evaluation + +(defvar cider-to-nrepl-filename-function + (with-no-warnings + (if (eq system-type 'cygwin) + #'cygwin-convert-file-name-to-windows + #'identity)) + "Function to translate Emacs filenames to nREPL namestrings.") + +(defvar-local cider--ns-form-cache (make-hash-table :test 'equal) + "ns form cache for the current buffer. + +The cache is a hash where the keys are connection names and the values +are ns forms. This allows every connection to keep track of the ns +form independently.") + +(defun cider--cache-ns-form () + "Cache the form in the current buffer for the current connection." + (puthash (cider-current-connection) + (cider-ns-form) + cider--ns-form-cache)) + +(defun cider--cached-ns-form () + "Retrieve the cached ns form for the current buffer & connection." + (gethash (cider-current-connection) cider--ns-form-cache)) + +(defun cider--prep-interactive-eval (form) + "Prepare the environment for an interactive eval of FORM. + +If FORM is an ns-form, ensure that it is evaluated in the `user` +namespace. Otherwise, ensure the current ns declaration has been +evaluated (so that the ns containing FORM exists). + +Clears any compilation highlights and kills the error window." + (cider--clear-compilation-highlights) + (cider--quit-error-window) + (let ((cur-ns-form (cider-ns-form))) + (when (and cur-ns-form + (not (string= cur-ns-form (cider--cached-ns-form))) + (not (cider-ns-form-p form))) + ;; TODO: check for evaluation errors + (cider-eval-ns-form 'sync) + (cider--cache-ns-form)))) + +(defvar-local cider-interactive-eval-override nil + "Function to call instead of `cider-interactive-eval'.") + +(defun cider-interactive-eval (form &optional callback bounds additional-params) + "Evaluate FORM and dispatch the response to CALLBACK. +If the code to be evaluated comes from a buffer, it is preferred to use a +nil FORM, and specify the code via the BOUNDS argument instead. + +This function is the main entry point in CIDER's interactive evaluation +API. Most other interactive eval functions should rely on this function. +If CALLBACK is nil use `cider-interactive-eval-handler'. +BOUNDS, if non-nil, is a list of two numbers marking the start and end +positions of FORM in its buffer. +ADDITIONAL-PARAMS is a plist to be appended to the request message. + +If `cider-interactive-eval-override' is a function, call it with the same +arguments and only proceed with evaluation if it returns nil." + (let ((form (or form (apply #'buffer-substring bounds))) + (start (car-safe bounds)) + (end (car-safe (cdr-safe bounds)))) + (when (and start end) + (remove-overlays start end 'cider-temporary t)) + (unless (and cider-interactive-eval-override + (functionp cider-interactive-eval-override) + (funcall cider-interactive-eval-override form callback bounds)) + (cider-map-connections #'ignore :any) + (cider--prep-interactive-eval form) + (cider-nrepl-request:eval + form + (or callback (cider-interactive-eval-handler nil bounds)) + ;; always eval ns forms in the user namespace + ;; otherwise trying to eval ns form for the first time will produce an error + (if (cider-ns-form-p form) "user" (cider-current-ns)) + (when start (line-number-at-pos start)) + (when start (cider-column-number-at-pos start)) + additional-params)))) + +(defun cider-eval-region (start end) + "Evaluate the region between START and END." + (interactive "r") + (cider-interactive-eval nil nil (list start end))) + +(defun cider-eval-last-sexp (&optional prefix) + "Evaluate the expression preceding point. +If invoked with a PREFIX argument, print the result in the current buffer." + (interactive "P") + (cider-interactive-eval nil + (when prefix (cider-eval-print-handler)) + (cider-last-sexp 'bounds))) + +(defun cider-eval-last-sexp-and-replace () + "Evaluate the expression preceding point and replace it with its result." + (interactive) + (let ((last-sexp (cider-last-sexp))) + ;; we have to be sure the evaluation won't result in an error + (cider-nrepl-sync-request:eval last-sexp) + ;; seems like the sexp is valid, so we can safely kill it + (backward-kill-sexp) + (cider-interactive-eval last-sexp (cider-eval-print-handler)))) + +(defun cider-eval-sexp-at-point (&optional prefix) + "Evaluate the expression around point. +If invoked with a PREFIX argument, print the result in the current buffer." + (interactive "P") + (save-excursion + (goto-char (cadr (cider-sexp-at-point 'bounds))) + (cider-eval-last-sexp prefix))) + +(defun cider-eval-defun-to-comment (loc) + "Evaluate the \"top-level\" form and insert result as comment at LOC. + +With a prefix arg, LOC, insert before the form, otherwise afterwards." + (interactive "P") + (let* ((bounds (cider-defun-at-point 'bounds)) + (insertion-point (nth (if loc 0 1) bounds))) + (cider-interactive-eval nil + (cider-eval-print-with-comment-handler + (current-buffer) insertion-point ";; => ") + bounds))) + +(declare-function cider-switch-to-repl-buffer "cider-mode") + +(defun cider-eval-last-sexp-to-repl (&optional prefix) + "Evaluate the expression preceding point and insert its result in the REPL. +If invoked with a PREFIX argument, switch to the REPL buffer." + (interactive "P") + (cider-interactive-eval nil + (cider-insert-eval-handler (cider-current-connection)) + (cider-last-sexp 'bounds)) + (when prefix + (cider-switch-to-repl-buffer))) + +(defun cider-pprint-eval-last-sexp-to-repl (&optional prefix) + "Evaluate the expression preceding point and insert its pretty-printed result in the REPL. +If invoked with a PREFIX argument, switch to the REPL buffer." + (interactive "P") + (let* ((conn-buffer (cider-current-connection))) + (cider-interactive-eval nil + (cider-insert-eval-handler conn-buffer) + (cider-last-sexp 'bounds) + (cider--nrepl-pprint-request-plist (cider--pretty-print-width)))) + (when prefix + (cider-switch-to-repl-buffer))) + +(defun cider-eval-print-last-sexp () + "Evaluate the expression preceding point. +Print its value into the current buffer." + (interactive) + (cider-interactive-eval nil + (cider-eval-print-handler) + (cider-last-sexp 'bounds))) + +(defun cider--pprint-eval-form (form) + "Pretty print FORM in popup buffer." + (let* ((result-buffer (cider-popup-buffer cider-result-buffer nil 'clojure-mode)) + (handler (cider-popup-eval-out-handler result-buffer))) + (cider-interactive-eval (when (stringp form) form) + handler + (when (consp form) form) + (cider--nrepl-pprint-request-plist (cider--pretty-print-width))))) + +(defun cider-pprint-eval-last-sexp () + "Evaluate the sexp preceding point and pprint its value in a popup buffer." + (interactive) + (cider--pprint-eval-form (cider-last-sexp 'bounds))) + +(defun cider--prompt-and-insert-inline-dbg () + "Insert a #dbg button at the current sexp." + (save-excursion + (let ((beg)) + (skip-chars-forward "\r\n[:blank:]") + (unless (looking-at-p "(") + (ignore-errors (backward-up-list))) + (setq beg (point)) + (let* ((cond (cider-read-from-minibuffer "Condition for debugging (leave empty for \"always\"): ")) + (button (propertize (concat "#dbg" + (unless (equal cond "") + (format " ^{:break/when %s}" cond))) + 'font-lock-face 'cider-fragile-button-face))) + (when (> (current-column) 30) + (insert "\n") + (indent-according-to-mode)) + (insert button) + (when (> (current-column) 40) + (insert "\n") + (indent-according-to-mode))) + (make-button beg (point) + 'help-echo "Breakpoint. Reevaluate this form to remove it." + :type 'cider-fragile)))) + +(defun cider-eval-defun-at-point (&optional debug-it) + "Evaluate the current toplevel form, and print result in the minibuffer. +With DEBUG-IT prefix argument, also debug the entire form as with the +command `cider-debug-defun-at-point'." + (interactive "P") + (let ((inline-debug (eq 16 (car-safe debug-it)))) + (when debug-it + (when (derived-mode-p 'clojurescript-mode) + (when (y-or-n-p (concat "The debugger doesn't support ClojureScript yet, and we need help with that." + " \nWould you like to read the Feature Request?")) + (browse-url "https://github.com/clojure-emacs/cider/issues/1416")) + (user-error "The debugger does not support ClojureScript")) + (when inline-debug + (cider--prompt-and-insert-inline-dbg))) + (cider-interactive-eval (when (and debug-it (not inline-debug)) + (concat "#dbg\n" (cider-defun-at-point))) + nil (cider-defun-at-point 'bounds)))) + +(defun cider-pprint-eval-defun-at-point () + "Evaluate the \"top-level\" form at point and pprint its value in a popup buffer." + (interactive) + (cider--pprint-eval-form (cider-defun-at-point 'bounds))) + +(defun cider-eval-ns-form (&optional sync) + "Evaluate the current buffer's namespace form. + +When SYNC is true the form is evaluated synchronously, +otherwise it's evaluated interactively." + (interactive) + (when (clojure-find-ns) + (save-excursion + (goto-char (match-beginning 0)) + (if sync + ;; The first interactive eval on a file can load a lot of libs. This + ;; can easily lead to more than 10 sec. + (let ((nrepl-sync-request-timeout 30)) + (cider-nrepl-sync-request:eval (cider-defun-at-point))) + (cider-eval-defun-at-point))))) + +(defun cider-read-and-eval (&optional value) + "Read a sexp from the minibuffer and output its result to the echo area. +If VALUE is non-nil, it is inserted into the minibuffer as initial input." + (interactive) + (let* ((form (cider-read-from-minibuffer "Clojure Eval: " value)) + (override cider-interactive-eval-override) + (ns-form (if (cider-ns-form-p form) "" (format "(ns %s)" (cider-current-ns))))) + (with-current-buffer (get-buffer-create cider-read-eval-buffer) + (erase-buffer) + (clojure-mode) + (unless (string= "" ns-form) + (insert ns-form "\n\n")) + (insert form) + (let ((cider-interactive-eval-override override)) + (cider-interactive-eval form))))) + +(defun cider-read-and-eval-defun-at-point () + "Insert the toplevel form at point in the minibuffer and output its result. +The point is placed next to the function name in the minibuffer to allow +passing arguments." + (interactive) + (let* ((fn-name (cadr (split-string (cider-defun-at-point)))) + (form (concat "(" fn-name ")"))) + (cider-read-and-eval (cons form (length form))))) + +;; Eval keymap + +(defvar cider-eval-commands-map + (let ((map (define-prefix-command 'cider-eval-commands-map))) + ;; single key bindings defined last for display in menu + (define-key map (kbd "w") #'cider-eval-last-sexp-and-replace) + (define-key map (kbd "r") #'cider-eval-region) + (define-key map (kbd "n") #'cider-eval-ns-form) + (define-key map (kbd "v") #'cider-eval-sexp-at-point) + (define-key map (kbd ".") #'cider-read-and-eval-defun-at-point) + ;; duplicates with C- for convenience + (define-key map (kbd "C-w") #'cider-eval-last-sexp-and-replace) + (define-key map (kbd "C-r") #'cider-eval-region) + (define-key map (kbd "C-n") #'cider-eval-ns-form) + (define-key map (kbd "C-v") #'cider-eval-sexp-at-point) + (define-key map (kbd "C-.") #'cider-read-and-eval-defun-at-point))) + + +;; 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" + "ns" (cider-current-ns) + "sym" symbol) + (cider-nrepl-send-sync-request))) + +(defun cider--toggle-trace-var (sym) + "Toggle var tracing for SYM." + (let* ((trace-response (cider-sync-request:toggle-trace-var sym)) + (var-name (nrepl-dict-get trace-response "var-name")) + (var-status (nrepl-dict-get trace-response "var-status"))) + (pcase var-status + ("not-found" (error "Var %s not found" (cider-propertize sym 'fn))) + ("not-traceable" (error "Var %s can't be traced because it's not bound to a function" (cider-propertize var-name 'fn))) + (_ (message "Var %s %s" (cider-propertize var-name 'fn) var-status))))) + +(defun cider-toggle-trace-var (arg) + "Toggle var tracing. + +Prompts for the symbol to use, or uses the symbol at point, depending on +the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the +opposite of what that option dictates." + (interactive "P") + (cider-ensure-op-supported "toggle-trace-var") + (funcall (cider-prompt-for-symbol-function arg) + "Toggle trace for var" + #'cider--toggle-trace-var)) + +(defun cider-sync-request:toggle-trace-ns (ns) + "Toggle namespace tracing for NS." + (thread-first (list "op" "toggle-trace-ns" + "ns" ns) + (cider-nrepl-send-sync-request))) + +(defun cider-toggle-trace-ns (query) + "Toggle ns tracing. +Defaults to the current ns. With prefix arg QUERY, prompts for a ns." + (interactive "P") + (cider-map-connections + (lambda (conn) + (with-current-buffer conn + (cider-ensure-op-supported "toggle-trace-ns") + (let ((ns (if query + (completing-read "Toggle trace for ns: " + (cider-sync-request:ns-list)) + (cider-current-ns)))) + (let* ((trace-response (cider-sync-request:toggle-trace-ns ns)) + (ns-status (nrepl-dict-get trace-response "ns-status"))) + (pcase ns-status + ("not-found" (error "Namespace %s not found" (cider-propertize ns 'ns))) + (_ (message "Namespace %s %s" (cider-propertize ns 'ns) ns-status))))))) + :clj)) + +(defun cider-undef () + "Undefine a symbol from the current ns." + (interactive) + (cider-ensure-op-supported "undef") + (cider-read-symbol-name + "Undefine symbol: " + (lambda (sym) + (cider-nrepl-send-request + (list "op" "undef" + "ns" (cider-current-ns) + "symbol" sym) + (cider-interactive-eval-handler (current-buffer)))))) + +(defun cider-refresh--handle-response (response log-buffer) + (nrepl-dbind-response response (out err reloading status error error-ns after before) + (cl-flet* ((log (message &optional face) + (cider-emit-into-popup-buffer log-buffer message face)) + + (log-echo (message &optional face) + (log message face) + (unless cider-refresh-show-log-buffer + (let ((message-truncate-lines t)) + (message "cider-refresh: %s" message))))) + (cond + (out + (log out)) + + (err + (log err 'font-lock-warning-face)) + + ((member "invoking-before" status) + (log-echo (format "Calling %s\n" before) 'font-lock-string-face)) + + ((member "invoked-before" status) + (log-echo (format "Successfully called %s\n" before) 'font-lock-string-face)) + + ((member "invoked-not-resolved" status) + (log-echo "Could not resolve refresh function\n" 'font-lock-string-face)) + + (reloading + (log-echo (format "Reloading %s\n" reloading) 'font-lock-string-face)) + + ((member "reloading" (nrepl-dict-keys response)) + (log-echo "Nothing to reload\n" 'font-lock-string-face)) + + ((member "ok" status) + (log-echo "Reloading successful\n" 'font-lock-string-face)) + + (error-ns + (log-echo (format "Error reloading %s\n" error-ns) 'font-lock-warning-face)) + + ((member "invoking-after" status) + (log-echo (format "Calling %s\n" after) 'font-lock-string-face)) + + ((member "invoked-after" status) + (log-echo (format "Successfully called %s\n" after) 'font-lock-string-face)))) + + (with-selected-window (or (get-buffer-window cider-refresh-log-buffer) + (selected-window)) + (with-current-buffer cider-refresh-log-buffer + (goto-char (point-max)))) + + (when (member "error" status) + (cider--render-stacktrace-causes error)))) + +(defun cider-refresh (&optional mode) + "Reload modified and unloaded namespaces on the classpath. + +With a single prefix argument, or if MODE is `refresh-all', reload all +namespaces on the classpath unconditionally. + +With a double prefix argument, or if MODE is `clear', clear the state of +the namespace tracker before reloading. This is useful for recovering from +some classes of error (for example, those caused by circular dependencies) +that a normal reload would not otherwise recover from. The trade-off of +clearing is that stale code from any deleted files may not be completely +unloaded. + +With a negative prefix argument, or if MODE is `inhibit-fns', prevent any +refresh functions (defined in `cider-refresh-before-fn' and +`cider-refresh-after-fn') from being invoked." + (interactive "p") + (cider-ensure-connected) + (cider-ensure-op-supported "refresh") + (let ((clear? (member mode '(clear 16))) + (refresh-all? (member mode '(refresh-all 4))) + (inhibit-refresh-fns (member mode '(inhibit-fns -1)))) + (cider-map-connections + (lambda (conn) + ;; Inside the lambda, so the buffer is not created if we error out. + (let ((log-buffer (or (get-buffer cider-refresh-log-buffer) + (cider-make-popup-buffer cider-refresh-log-buffer)))) + (when cider-refresh-show-log-buffer + (cider-popup-buffer-display log-buffer)) + (when inhibit-refresh-fns + (cider-emit-into-popup-buffer log-buffer "inhibiting refresh functions\n")) + (when clear? + (cider-nrepl-send-sync-request (list "op" "refresh-clear") conn)) + (cider-nrepl-send-request + (append (list "op" (if refresh-all? "refresh-all" "refresh") + "print-length" cider-stacktrace-print-length + "print-level" cider-stacktrace-print-level) + (when (cider--pprint-fn) (list "pprint-fn" (cider--pprint-fn))) + (when (and (not inhibit-refresh-fns) cider-refresh-before-fn) + (list "before" cider-refresh-before-fn)) + (when (and (not inhibit-refresh-fns) cider-refresh-after-fn) + (list "after" cider-refresh-after-fn))) + (lambda (response) + (cider-refresh--handle-response response log-buffer)) + conn))) + :clj 'any-mode))) + +(defun cider-file-string (file) + "Read the contents of a FILE and return as a string." + (with-current-buffer (find-file-noselect file) + (substring-no-properties (buffer-string)))) + +(defun cider-load-buffer (&optional buffer) + "Load (eval) BUFFER's file in nREPL. +If no buffer is provided the command acts on the current buffer. + +If the buffer is for a cljc or cljx file, and both a Clojure and +ClojureScript REPL exists for the project, it is evaluated in both REPLs." + (interactive) + (check-parens) + (cider-ensure-connected) + (setq buffer (or buffer (current-buffer))) + (with-current-buffer buffer + (unless buffer-file-name + (user-error "Buffer `%s' is not associated with a file" (current-buffer))) + (when (and cider-prompt-save-file-on-load + (buffer-modified-p) + (or (eq cider-prompt-save-file-on-load 'always-save) + (y-or-n-p (format "Save file %s? " buffer-file-name)))) + (save-buffer)) + (remove-overlays nil nil 'cider-temporary t) + (cider--clear-compilation-highlights) + (cider--quit-error-window) + (cider--cache-ns-form) + (let ((filename (buffer-file-name))) + (cider-map-connections + (lambda (connection) + (cider-request:load-file (cider-file-string filename) + (funcall cider-to-nrepl-filename-function + (cider--server-filename filename)) + (file-name-nondirectory filename) + connection)) + :both) + (message "Loading %s..." filename)))) + +(defun cider-load-file (filename) + "Load (eval) the Clojure file FILENAME in nREPL. + +If the file is a cljc or cljx file, and both a Clojure and ClojureScript +REPL exists for the project, it is evaluated in both REPLs. + +The heavy lifting is done by `cider-load-buffer'." + (interactive (list + (read-file-name "Load file: " nil nil nil + (when (buffer-file-name) + (file-name-nondirectory + (buffer-file-name)))))) + (if-let ((buffer (find-buffer-visiting filename))) + (cider-load-buffer buffer) + (find-file filename) + (cider-load-buffer (current-buffer)))) + +(defalias 'cider-eval-file 'cider-load-file + "A convenience alias as some people are confused by the load-* names.") + +(defalias 'cider-eval-buffer 'cider-load-buffer + "A convenience alias as some people are confused by the load-* names.") + +(defun cider--format-buffer (formatter) + "Format the contents of the current buffer. + +Uses FORMATTER, a function of one argument, to convert the string contents +of the buffer into a formatted string." + (let* ((original (substring-no-properties (buffer-string))) + (formatted (funcall formatter original))) + (unless (equal original formatted) + (erase-buffer) + (insert formatted)))) + +(defun cider-format-buffer () + "Format the Clojure code in the current buffer." + (interactive) + (cider-ensure-connected) + (cider--format-buffer #'cider-sync-request:format-code)) + +(defun cider-format-edn-buffer () + "Format the EDN data in the current buffer." + (interactive) + (cider-ensure-connected) + (cider--format-buffer (lambda (edn) + (cider-sync-request:format-edn edn (cider--pretty-print-width))))) + +(defun cider--format-reindent (formatted start) + "Reindent FORMATTED to align with buffer position START." + (let* ((start-column (save-excursion (goto-char start) (current-column))) + (indent-line (concat "\n" (make-string start-column ? )))) + (replace-regexp-in-string "\n" indent-line formatted))) + +(defun cider--format-region (start end formatter) + "Format the contents of the given region. + +START and END represent the region's boundaries. +FORMATTER is a function of one argument which is used to convert +the string contents of the region into a formatted string." + (let* ((original (buffer-substring-no-properties start end)) + (formatted (funcall formatter original)) + (indented (cider--format-reindent formatted start))) + (unless (equal original indented) + (delete-region start end) + (insert indented)))) + +(defun cider-format-region (start end) + "Format the Clojure code in the current region. +START and END represent the region's boundaries." + (interactive "r") + (cider-ensure-connected) + (cider--format-region start end #'cider-sync-request:format-code)) + +(defun cider-format-edn-region (start end) + "Format the EDN data in the current region. +START and END represent the region's boundaries." + (interactive "r") + (cider-ensure-connected) + (let* ((start-column (save-excursion (goto-char start) (current-column))) + (right-margin (- (cider--pretty-print-width) start-column))) + (cider--format-region start end + (lambda (edn) + (cider-sync-request:format-edn edn right-margin))))) + +(defun cider-format-defun () + "Format the code in the current defun." + (interactive) + (cider-ensure-connected) + (save-excursion + (mark-defun) + (cider-format-region (region-beginning) (region-end)))) + +;;; interrupt evaluation +(defun cider-interrupt-handler (buffer) + "Create an interrupt response handler for BUFFER." + (nrepl-make-response-handler buffer nil nil nil nil)) + +(defun cider-describe-nrepl-session () + "Describe an nREPL session." + (interactive) + (cider-ensure-connected) + (let ((selected-session (completing-read "Describe nREPL session: " (nrepl-sessions (cider-current-connection))))) + (when (and selected-session (not (equal selected-session ""))) + (let* ((session-info (nrepl-sync-request:describe (cider-current-connection))) + (ops (nrepl-dict-keys (nrepl-dict-get session-info "ops"))) + (session-id (nrepl-dict-get session-info "session")) + (session-type (cond + ((equal session-id (cider-current-session)) "Active eval") + ((equal session-id (cider-current-tooling-session)) "Active tooling") + (t "Unknown")))) + (with-current-buffer (cider-popup-buffer cider-nrepl-session-buffer) + (read-only-mode -1) + (insert (format "Session: %s\n" session-id) + (format "Type: %s session\n" session-type) + (format "Supported ops:\n")) + (mapc (lambda (op) (insert (format " * %s\n" op))) ops))) + (display-buffer cider-nrepl-session-buffer)))) + +(defun cider-close-nrepl-session () + "Close an nREPL session for the current connection." + (interactive) + (cider-ensure-connected) + (nrepl-sync-request:close (cider-current-connection)) + (message "Closed nREPL session")) + +;;; quiting +(defun cider--close-buffer (buffer) + "Close the BUFFER and kill its associated process (if any)." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when-let ((proc (get-buffer-process buffer))) + (when (process-live-p proc) + (when (or (not nrepl-server-buffer) + ;; Sync request will hang if the server is dead. + (process-live-p (get-buffer-process nrepl-server-buffer))) + (when (or nrepl-session nrepl-tooling-session) + (nrepl-sync-request:close buffer))) + (when proc (delete-process proc))))) + (kill-buffer buffer))) + +(defun cider-close-ancillary-buffers () + "Close buffers that are shared across connections." + (interactive) + (dolist (buf-name cider-ancillary-buffers) + (when (get-buffer buf-name) + (kill-buffer buf-name)))) + +(defun cider--quit-connection (conn) + "Quit the connection CONN." + (when conn + (cider--close-connection-buffer conn) + ;; clean the cached ns forms for this connection in all Clojure buffers + (dolist (clojure-buffer (cider-util--clojure-buffers)) + (with-current-buffer clojure-buffer + (remhash conn cider--ns-form-cache))))) + +(defun cider-quit (&optional quit-all) + "Quit the currently active CIDER connection. + +With a prefix argument QUIT-ALL the command will kill all connections +and all ancillary CIDER buffers." + (interactive "P") + (cider-ensure-connected) + (if (and quit-all (y-or-n-p "Are you sure you want to quit all CIDER connections? ")) + (progn + (dolist (connection cider-connections) + (cider--quit-connection connection)) + (message "All active nREPL connections were closed")) + (let ((connection (cider-current-connection))) + (when (y-or-n-p (format "Are you sure you want to quit the current CIDER connection %s? " + (cider-propertize (buffer-name connection) 'bold))) + (cider--quit-connection connection)))) + ;; if there are no more connections we can kill all ancillary buffers + (unless (cider-connected-p) + (cider-close-ancillary-buffers))) + +(defun cider--restart-connection (conn) + "Restart the connection CONN." + (let ((project-dir (with-current-buffer conn nrepl-project-dir)) + (buf-name (buffer-name conn)) + ;; save these variables before we kill the connection + (conn-creation-method (with-current-buffer conn cider-connection-created-with)) + (conn-endpoint (with-current-buffer conn nrepl-endpoint))) + (cider--quit-connection conn) + ;; Workaround for a nasty race condition https://github.com/clojure-emacs/cider/issues/439 + ;; TODO: Find a better way to ensure `cider-quit' has finished + (message "Waiting for CIDER connection %s to quit..." + (cider-propertize buf-name 'bold)) + (sleep-for 2) + (pcase conn-creation-method + (`connect (apply #'cider-connect conn-endpoint)) + (`jack-in (if project-dir + (let ((default-directory project-dir)) + (cider-jack-in)) + (error "Can't restart CIDER connection for unknown project"))) + (_ (error "Unexpected value %S for `cider-connection-created-with'" + conn-creation-method))))) + +(defun cider-restart (&optional restart-all) + "Restart the currently active CIDER connection. +If RESTART-ALL is t, then restarts all connections." + (interactive "P") + (cider-ensure-connected) + (if restart-all + (dolist (conn cider-connections) + (cider--restart-connection conn)) + (cider--restart-connection (cider-current-connection)))) + +(defvar cider--namespace-history nil + "History of user input for namespace prompts.") + +(defun cider--var-namespace (var) + "Return the namespace of VAR. +VAR is a fully qualified Clojure variable name as a string." + (replace-regexp-in-string "\\(?:#'\\)?\\(.*\\)/.*" "\\1" var)) + +(defun cider-load-all-project-ns () + "Load all namespaces in the current project." + (interactive) + (cider-ensure-connected) + (cider-ensure-op-supported "ns-load-all") + (when (y-or-n-p "Are you sure you want to load all namespaces in the project? ") + (message "Loading all project namespaces...") + (let ((loaded-ns-count (length (cider-sync-request:ns-load-all)))) + (message "Loaded %d namespaces" loaded-ns-count)))) + +(defun cider-run (&optional function) + "Run -main or FUNCTION, prompting for its namespace if necessary. +With a prefix argument, prompt for function to run instead of -main." + (interactive (list (when current-prefix-arg (read-string "Function name: ")))) + (cider-ensure-connected) + (let ((name (or function "-main"))) + (when-let ((response (cider-nrepl-send-sync-request + (list "op" "ns-list-vars-by-name" "name" name)))) + (if-let ((vars (split-string (substring (nrepl-dict-get response "var-list") 1 -1)))) + (cider-interactive-eval + (if (= (length vars) 1) + (concat "(" (car vars) ")") + (let* ((completions (mapcar #'cider--var-namespace vars)) + (def (or (car cider--namespace-history) + (car completions)))) + (format "(#'%s/%s)" + (completing-read (format "Namespace (%s): " def) + completions nil t nil + 'cider--namespace-history def) + name)))) + (user-error "No %s var defined in any namespace" (cider-propertize name 'fn)))))) + +(provide 'cider-interaction) + +;;; cider-interaction.el ends here diff --git a/elpa/cider-20170129.1941/cider-macroexpansion.el b/elpa/cider-20170129.1941/cider-macroexpansion.el new file mode 100644 index 00000000..d0ca9db9 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-macroexpansion.el @@ -0,0 +1,208 @@ +;;; cider-macroexpansion.el --- Macro expansion support -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Macro expansion support. + +;;; Code: + +(require 'cider-mode) +(require 'subr-x) +(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-20170129.1941/cider-mode.el b/elpa/cider-20170129.1941/cider-mode.el new file mode 100644 index 00000000..7bc0a98c --- /dev/null +++ b/elpa/cider-20170129.1941/cider-mode.el @@ -0,0 +1,859 @@ +;;; cider-mode.el --- Minor mode for REPL interactions -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; 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 'subr-x) +(require 'cider-compat) + +(defcustom cider-mode-line-show-connection t + "If the mode-line lighter should detail the connection." + :group 'cider + :type 'boolean + :package-version '(cider "0.10.0")) + +(defun cider--modeline-info () + "Return info for the `cider-mode' modeline. + +Info contains project name and host:port endpoint." + (if-let ((current-connection (ignore-errors (cider-current-connection)))) + (with-current-buffer current-connection + (concat + cider-repl-type + (when cider-mode-line-show-connection + (format ":%s@%s:%s" + (or (cider--project-name nrepl-project-dir) "") + (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-*-repl' to change the ClojureScript REPL to use for your build tool."] + ["Create a ClojureScript REPL from a Clojure REPL" cider-create-sibling-cljs-repl] + ["Form for launching a ClojureScript REPL via Leiningen" (customize-variable 'cider-cljs-lein-repl)] + ["Form for launching a ClojureScript REPL via Boot" (customize-variable 'cider-cljs-boot-repl)] + ["Form for launching a ClojureScript REPL via Gradle" (customize-variable 'cider-cljs-gradle-repl)]) + "--" + ["Connection info" cider-display-connection-info + :active cider-connections] + ["Rotate default connection" cider-rotate-default-connection + :active (cdr cider-connections)] + ["Select any CIDER buffer" cider-selector] + "--" + ["Configure CIDER" (customize-group 'cider)] + "--" + ["A sip of CIDER" cider-drink-a-sip] + ["View manual online" cider-view-manual] + ["View refcard online" cider-view-refcard] + ["Report a bug" cider-report-bug] + ["Version info" cider-version] + "--" + ["Close ancillary buffers" cider-close-ancillary-buffers + :active (seq-remove #'null cider-ancillary-buffers)] + ("nREPL" :active cider-connections + ["Describe session" cider-describe-nrepl-session] + ["Close session" cider-close-nrepl-session] + ["Toggle message logging" nrepl-toggle-message-logging])) + "Menu for CIDER mode") + +(defconst cider-mode-eval-menu + '("CIDER Eval" :visible cider-connections + ["Eval top-level sexp" cider-eval-defun-at-point] + ["Eval current sexp" cider-eval-sexp-at-point] + ["Eval last sexp" cider-eval-last-sexp] + ["Eval selected region" cider-eval-region] + ["Eval ns form" cider-eval-ns-form] + "--" + ["Interrupt evaluation" cider-interrupt] + "--" + ["Eval last sexp and insert" cider-eval-print-last-sexp + :keys "\\[universal-argument] \\[cider-eval-last-sexp]"] + ["Eval last sexp in popup buffer" cider-pprint-eval-last-sexp] + ["Eval last sexp and replace" cider-eval-last-sexp-and-replace] + ["Eval last sexp to REPL" cider-eval-last-sexp-to-repl] + ["Eval last sexp and pretty-print to REPL" cider-pprint-eval-last-sexp-to-repl] + ["Insert last sexp in REPL" cider-insert-last-sexp-in-repl] + ["Eval top-level sexp to comment" cider-eval-defun-to-comment] + "--" + ["Load this buffer" cider-load-buffer] + ["Load another file" cider-load-file] + ["Load all project files" cider-load-all-project-ns] + ["Refresh loaded code" cider-refresh] + ["Run project (-main function)" cider-run]) + "Menu for CIDER mode eval commands.") + +(defconst cider-mode-interactions-menu + `("CIDER Interactions" :visible cider-connections + ["Complete symbol" complete-symbol] + "--" + ("REPL" + ["Set REPL to this ns" cider-repl-set-ns] + ["Switch to REPL" cider-switch-to-repl-buffer] + ["REPL Pretty Print" cider-repl-toggle-pretty-printing + :style toggle :selected cider-repl-use-pretty-printing] + ["Clear latest output" cider-find-and-clear-repl-output] + ["Clear all output" (cider-find-and-clear-repl-output t) + :keys "\\[universal-argument] \\[cider-find-and-clear-repl-output]"] + "--" + ["Configure the REPL" (customize-group 'cider-repl)]) + ,cider-doc-menu + ("Find (jump to)" + ["Find definition" cider-find-var] + ["Find resource" cider-find-resource] + ["Go back" cider-pop-back]) + ("Macroexpand" + ["Macroexpand-1" cider-macroexpand-1] + ["Macroexpand-all" cider-macroexpand-all]) + ,cider-test-menu + ("Debug" + ["Inspect" cider-inspect] + ["Toggle var tracing" cider-toggle-trace-var] + ["Toggle ns tracing" cider-toggle-trace-ns] + "--" + ["Debug top-level form" cider-debug-defun-at-point + :keys "\\[universal-argument] \\[cider-eval-defun-at-point]"] + ["List instrumented defs" cider-browse-instrumented-defs] + "--" + ["Configure the Debugger" (customize-group 'cider-debug)]) + ("Browse" + ["Browse namespace" cider-browse-ns] + ["Browse all namespaces" cider-browse-ns-all] + ["Browse REPL input history" cider-repl-history] + ["Browse classpath" cider-classpath] + ["Browse classpath entry" cider-open-classpath-entry])) + "Menu for CIDER interactions.") + +(defconst cider-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-d") 'cider-doc-map) + (define-key map (kbd "M-.") #'cider-find-var) + (define-key map (kbd "C-c C-.") #'cider-find-ns) + (define-key map (kbd "M-,") #'cider-pop-back) + (define-key map (kbd "C-c M-.") #'cider-find-resource) + (define-key map (kbd "M-TAB") #'complete-symbol) + (define-key map (kbd "C-M-x") #'cider-eval-defun-at-point) + (define-key map (kbd "C-c C-c") #'cider-eval-defun-at-point) + (define-key map (kbd "C-x C-e") #'cider-eval-last-sexp) + (define-key map (kbd "C-c C-e") #'cider-eval-last-sexp) + (define-key map (kbd "C-c C-v") 'cider-eval-commands-map) + (define-key map (kbd "C-c M-;") #'cider-eval-defun-to-comment) + (define-key map (kbd "C-c M-e") #'cider-eval-last-sexp-to-repl) + (define-key map (kbd "C-c M-p") #'cider-insert-last-sexp-in-repl) + (define-key map (kbd "C-c C-p") #'cider-pprint-eval-last-sexp) + (define-key map (kbd "C-c C-f") #'cider-pprint-eval-defun-at-point) + (define-key map (kbd "C-c M-:") #'cider-read-and-eval) + (define-key map (kbd "C-c C-u") #'cider-undef) + (define-key map (kbd "C-c C-m") #'cider-macroexpand-1) + (define-key map (kbd "C-c M-m") #'cider-macroexpand-all) + (define-key map (kbd "C-c M-n") #'cider-repl-set-ns) + (define-key map (kbd "C-c M-i") #'cider-inspect) + (define-key map (kbd "C-c M-t v") #'cider-toggle-trace-var) + (define-key map (kbd "C-c M-t n") #'cider-toggle-trace-ns) + (define-key map (kbd "C-c C-z") #'cider-switch-to-repl-buffer) + (define-key map (kbd "C-c M-z") #'cider-load-buffer-and-switch-to-repl-buffer) + (define-key map (kbd "C-c C-o") #'cider-find-and-clear-repl-output) + (define-key map (kbd "C-c C-k") #'cider-load-buffer) + (define-key map (kbd "C-c C-l") #'cider-load-file) + (define-key map (kbd "C-c C-b") #'cider-interrupt) + (define-key map (kbd "C-c ,") 'cider-test-commands-map) + (define-key map (kbd "C-c C-t") 'cider-test-commands-map) + (define-key map (kbd "C-c M-s") #'cider-selector) + (define-key map (kbd "C-c M-r") #'cider-rotate-default-connection) + (define-key map (kbd "C-c M-d") #'cider-display-connection-info) + (define-key map (kbd "C-c C-x") #'cider-refresh) + (define-key map (kbd "C-c C-q") #'cider-quit) + (dolist (variable '(cider-mode-interactions-menu + cider-mode-eval-menu + cider-mode-menu)) + (easy-menu-do-define (intern (format "%s-open" variable)) + map + (get variable 'variable-documentation) + (cider--menu-add-help-strings (symbol-value variable)))) + map)) + +;; This menu works as an easy entry-point into CIDER. Even if cider.el isn't +;; loaded yet, this will be shown in Clojure buffers next to the "Clojure" +;; menu. +;;;###autoload +(eval-after-load 'clojure-mode + '(easy-menu-define cider-clojure-mode-menu-open clojure-mode-map + "Menu for Clojure mode. + This is displayed in `clojure-mode' buffers, if `cider-mode' is not active." + `("CIDER" :visible (not cider-mode) + ["Start a REPL" cider-jack-in + :help "Starts an nREPL server (with lein, boot, or maven) and connects a REPL to it."] + ["Connect to a REPL" cider-connect + :help "Connects to a REPL that's already running."] + ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clojurescript + :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL. + Configure `cider-cljs-lein-repl', `cider-cljs-boot-repl' and `cider-cljs-gradle-repl' to change the ClojureScript REPL to use."] + "--" + ["View manual online" cider-view-manual]))) + +;;; Dynamic indentation +(defcustom cider-dynamic-indentation t + "Whether CIDER should aid Clojure(Script) indentation. +If non-nil, CIDER uses runtime information (such as the \":style/indent\" +metadata) to improve standard `clojure-mode' indentation. +If nil, CIDER won't interfere with `clojure-mode's indentation. + +Toggling this variable only takes effect after a file is closed and +re-visited." + :type 'boolean + :package-version '(cider . "0.11.0") + :group 'cider) + +(defun cider--get-symbol-indent (symbol-name) + "Return the indent metadata for SYMBOL-NAME in the current namespace." + (let* ((ns (cider-current-ns))) + (if-let ((meta (cider-resolve-var ns symbol-name)) + (indent (or (nrepl-dict-get meta "style/indent") + (nrepl-dict-get meta "indent")))) + (let ((format (format ":indent metadata on ‘%s’ is unreadable! \nERROR: %%s" + symbol-name))) + (with-demoted-errors format + (cider--deep-vector-to-list (read indent)))) + ;; There's no indent metadata, but there might be a clojure-mode + ;; indent-spec with fully-qualified namespace. + (when (string-match cider-resolve--prefix-regexp symbol-name) + (when-let ((sym (intern-soft (replace-match (save-match-data + (cider-resolve-alias ns (match-string 1 symbol-name))) + t t symbol-name 1)))) + (get sym 'clojure-indent-function)))))) + + +;;; Dynamic font locking +(defcustom cider-font-lock-dynamically '(macro core deprecated) + "Specifies how much dynamic font-locking CIDER should use. +Dynamic font-locking this refers to applying syntax highlighting to vars +defined in the currently active nREPL connection. This is done in addition +to `clojure-mode's usual (static) font-lock, so even if you set this +variable to nil you'll still see basic syntax highlighting. + +The value is a list of symbols, each one indicates a different type of var +that should be font-locked: + `macro' (default): Any defined macro gets the `font-lock-builtin-face'. + `function': Any defined function gets the `font-lock-function-face'. + `var': Any non-local var gets the `font-lock-variable-face'. + `deprecated' (default): Any deprecated var gets the `cider-deprecated-face' + face. + `core' (default): Any symbol from clojure.core (face depends on type). + +The value can also be t, which means to font-lock as much as possible." + :type '(choice (set :tag "Fine-tune font-locking" + (const :tag "Any defined macro" macro) + (const :tag "Any defined function" function) + (const :tag "Any defined var" var) + (const :tag "Any defined deprecated" deprecated) + (const :tag "Any symbol from clojure.core" core)) + (const :tag "Font-lock as much as possible" t)) + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-font-lock-reader-conditionals t + "Apply font-locking to unused reader conditional expressions depending on the buffer CIDER connection type." + :type 'boolean + :group 'cider + :package-version '(cider . "0.15.0")) + +(defface cider-deprecated-face + '((((background light)) :background "light goldenrod") + (((background dark)) :background "#432")) + "Face used on deprecated vars." + :group 'cider) + +(defface cider-instrumented-face + '((((type graphic)) :box (:color "#c00" :line-width -1)) + (t :underline t :background "#800")) + "Face used to mark code being debugged." + :group 'cider-debug + :group 'cider + :package-version '(cider . "0.10.0")) + +(defface cider-traced-face + '((((type graphic)) :box (:color "cyan" :line-width -1)) + (t :underline t :background "#066")) + "Face used to mark code being traced." + :group 'cider + :package-version '(cider . "0.11.0")) + +(defface cider-reader-conditional-face + '((t (:inherit font-lock-comment-face))) + "Face used to mark unused reader conditional expressions." + :group 'cider + :package-version '(cider . "0.15.0")) + +(defconst cider-reader-conditionals-regexp "\\(?:#\\?@?[[:space:]\n]*(\\)" + "Regexp for matching reader conditionals with a non-capturing group. + +Starts from the reader macro characters to the opening parentheses.") + +(defvar cider--reader-conditionals-match-data (list nil nil) + "Reusable list for `match-data` in reader conditionals font lock matchers.") + +(defun cider--search-reader-conditionals (limit) + "Matcher for finding reader conditionals. + +Search is done with the given LIMIT." + (when (and cider-font-lock-reader-conditionals + (cider-connected-p)) + (when (search-forward-regexp cider-reader-conditionals-regexp limit t) + (let ((start (match-beginning 0)) + (state (syntax-ppss))) + (if (or (nth 3 state) (nth 4 state)) ; inside string or comment? + (cider--search-reader-conditionals limit) + (when (<= (point) limit) + (ignore-errors + (let ((md (match-data nil cider--reader-conditionals-match-data))) + (setf (nth 0 md) start) + (setf (nth 1 md) (point)) + (set-match-data md) + t)))))))) + +(defun cider--anchored-search-suppressed-forms-internal (limit) + "Helper function for `cider--anchored-search-suppressed-forms`. + +LIMIT is the same as the LIMIT in `cider--anchored-search-suppressed-forms`" + (let ((expr (read (current-buffer))) + (start (save-excursion (backward-sexp) (point)))) + (when (<= (point) limit) + (forward-sexp) + (if (not (string-equal (symbol-name expr) (concat ":" (cider-connection-type-for-buffer)))) + (ignore-errors + (cl-assert (<= (point) limit)) + (let ((md (match-data nil cider--reader-conditionals-match-data))) + (setf (nth 0 md) start) + (setf (nth 1 md) (point)) + (set-match-data md) + t)) + (cider--anchored-search-suppressed-forms-internal limit))))) + +(defun cider--anchored-search-suppressed-forms (limit) + "Matcher for finding unused reader conditional expressions. + +An unused reader conditional expression is an expression for a platform +that does not match the CIDER connection for the buffer. Search is done +with the given LIMIT." + (let ((result 'retry)) + (while (and (eq result 'retry) (<= (point) limit)) + (condition-case condition + (setq result (cider--anchored-search-suppressed-forms-internal limit)) + (invalid-read-syntax + (setq result 'retry)) + (wrong-type-argument + (setq result 'retry)) + (scan-error + (setq result 'retry)) + (end-of-file + (setq result nil)) + (error + (setq result nil) + (display-warning + '(cider warning) + (format + (concat "Caught error during fontification while searching for forms\n" + "that are suppressed by reader-conditionals. The error was: %S.") + condition))))) + (if (eq result 'retry) (setq result nil)) + result)) + +(defconst cider--reader-conditionals-font-lock-keywords + '((cider--search-reader-conditionals + (cider--anchored-search-suppressed-forms + (save-excursion + (let* ((state (syntax-ppss)) + (list-pt (nth 1 state))) + (when list-pt + (goto-char list-pt) + (forward-list) + (backward-char) + (point)))) + nil + (0 'cider-reader-conditional-face t)))) + "Font Lock keywords for unused reader conditionals in CIDER mode.") + +(defun cider--unless-local-match (value) + "Return VALUE, unless `match-string' is a local var." + (unless (or (get-text-property (point) 'cider-block-dynamic-font-lock) + (member (match-string 0) + (get-text-property (point) 'cider-locals))) + value)) + +(defun cider--compile-font-lock-keywords (symbols-plist core-plist) + "Return a list of font-lock rules for the symbols in SYMBOLS-PLIST and CORE-PLIST." + (let ((cider-font-lock-dynamically (if (eq cider-font-lock-dynamically t) + '(function var macro core deprecated) + cider-font-lock-dynamically)) + deprecated enlightened + macros functions vars instrumented traced) + (cl-labels ((handle-plist + (plist) + (let ((do-function (memq 'function cider-font-lock-dynamically)) + (do-var (memq 'var cider-font-lock-dynamically)) + (do-macro (memq 'macro cider-font-lock-dynamically)) + (do-deprecated (memq 'deprecated cider-font-lock-dynamically))) + (while plist + (let ((sym (pop plist)) + (meta (pop plist))) + (pcase (nrepl-dict-get meta "cider.nrepl.middleware.util.instrument/breakfunction") + (`nil nil) + (`"#'cider.nrepl.middleware.debug/breakpoint-if-interesting" + (push sym instrumented)) + (`"#'cider.nrepl.middleware.enlighten/light-form" + (push sym enlightened))) + ;; The ::traced keywords can be inlined by MrAnderson, so + ;; we catch that case too. + ;; FIXME: This matches values too, not just keys. + (when (seq-find (lambda (k) (and (stringp k) + (string-match (rx "clojure.tools.trace/traced" eos) k))) + meta) + (push sym traced)) + (when (and do-deprecated (nrepl-dict-get meta "deprecated")) + (push sym deprecated)) + (cond ((and do-macro (nrepl-dict-get meta "macro")) + (push sym macros)) + ((and do-function (nrepl-dict-get meta "arglists")) + (push sym functions)) + (do-var (push sym vars)))))))) + (when (memq 'core cider-font-lock-dynamically) + (let ((cider-font-lock-dynamically '(function var macro core deprecated))) + (handle-plist core-plist))) + (handle-plist symbols-plist)) + `( + ,@(when macros + `((,(concat (rx (or "(" "#'")) ; Can't take the value of macros. + "\\(" (regexp-opt macros 'symbols) "\\)") + 1 (cider--unless-local-match font-lock-keyword-face)))) + ,@(when functions + `((,(regexp-opt functions 'symbols) 0 + (cider--unless-local-match font-lock-function-name-face)))) + ,@(when vars + `((,(regexp-opt vars 'symbols) 0 + (cider--unless-local-match font-lock-variable-name-face)))) + ,@(when deprecated + `((,(regexp-opt deprecated 'symbols) 0 + (cider--unless-local-match 'cider-deprecated-face) append))) + ,@(when enlightened + `((,(regexp-opt enlightened 'symbols) 0 + (cider--unless-local-match 'cider-enlightened-face) append))) + ,@(when instrumented + `((,(regexp-opt instrumented 'symbols) 0 + (cider--unless-local-match 'cider-instrumented-face) append))) + ,@(when traced + `((,(regexp-opt traced 'symbols) 0 + (cider--unless-local-match 'cider-traced-face) append)))))) + +(defconst cider--static-font-lock-keywords + (eval-when-compile + `((,(regexp-opt '("#break" "#dbg" "#light") 'symbols) 0 font-lock-warning-face))) + "Default expressions to highlight in CIDER mode.") + +(defvar-local cider--dynamic-font-lock-keywords nil) + +(defun cider-refresh-dynamic-font-lock (&optional ns) + "Ensure that the current buffer has up-to-date font-lock rules. +NS defaults to `cider-current-ns', and it can also be a dict describing the +namespace itself." + (interactive) + (when (and cider-font-lock-dynamically + font-lock-mode) + (font-lock-remove-keywords nil cider--dynamic-font-lock-keywords) + (when-let ((ns (or ns (cider-current-ns))) + (symbols (cider-resolve-ns-symbols ns))) + (setq-local cider--dynamic-font-lock-keywords + (cider--compile-font-lock-keywords + symbols (cider-resolve-ns-symbols (cider-resolve-core-ns)))) + (font-lock-add-keywords nil cider--dynamic-font-lock-keywords 'end)) + (cider--font-lock-flush))) + + +;;; 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-add-keywords nil cider--reader-conditionals-font-lock-keywords) + ;; `font-lock-mode' might get enabled after `cider-mode'. + (add-hook 'font-lock-mode-hook #'cider-refresh-dynamic-font-lock nil 'local) + (setq-local font-lock-fontify-region-function + (cider--wrap-fontify-locals font-lock-fontify-region-function)) + ;; GTK tooltips look bad, and we have no control over the face. + (setq-local x-gtk-use-system-tooltips nil) + ;; `tooltip' has variable-width by default, which looks terrible. + (set-face-attribute 'tooltip nil :inherit 'unspecified) + (when cider-dynamic-indentation + (setq-local clojure-get-indent-function #'cider--get-symbol-indent)) + (setq-local clojure-expected-ns-function #'cider-expected-ns) + (setq next-error-function #'cider-jump-to-compilation-error)) + (mapc #'kill-local-variable '(completion-at-point-functions + next-error-function + x-gtk-use-system-tooltips + font-lock-fontify-region-function + clojure-get-indent-function)) + (remove-hook 'font-lock-mode-hook #'cider-refresh-dynamic-font-lock 'local) + (font-lock-add-keywords nil cider--reader-conditionals-font-lock-keywords) + (font-lock-remove-keywords nil cider--dynamic-font-lock-keywords) + (font-lock-remove-keywords nil cider--static-font-lock-keywords) + (cider--font-lock-flush))) + +(defun cider-set-buffer-ns (ns) + "Set this buffer's namespace to NS and refresh font-locking." + (setq-local cider-buffer-ns ns) + (when (or cider-mode (derived-mode-p 'cider-repl-mode)) + (cider-refresh-dynamic-font-lock ns))) + +(provide 'cider-mode) + +;;; cider-mode.el ends here diff --git a/elpa/cider-20170129.1941/cider-overlays.el b/elpa/cider-20170129.1941/cider-overlays.el new file mode 100644 index 00000000..627785a7 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-overlays.el @@ -0,0 +1,312 @@ +;;; cider-overlays.el --- Managing CIDER overlays -*- lexical-binding: t; -*- + +;; Copyright © 2015-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Use `cider--make-overlay' to place a generic overlay at point. Or use +;; `cider--make-result-overlay' to place an interactive eval result overlay at +;; the end of a specified line. + +;;; Code: + +(require 'cider-common) +(require 'subr-x) +(require '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-20170129.1941/cider-pkg.el b/elpa/cider-20170129.1941/cider-pkg.el new file mode 100644 index 00000000..77fcff34 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-pkg.el @@ -0,0 +1,12 @@ +(define-package "cider" "20170129.1941" "Clojure Interactive Development Environment that Rocks" + '((emacs "24.4") + (clojure-mode "5.6.0") + (pkg-info "0.4") + (queue "0.1.1") + (spinner "1.7") + (seq "2.16")) + :url "http://www.github.com/clojure-emacs/cider" :keywords + '("languages" "clojure" "cider")) +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/cider-20170129.1941/cider-popup.el b/elpa/cider-20170129.1941/cider-popup.el new file mode 100644 index 00000000..c0069bd1 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-popup.el @@ -0,0 +1,130 @@ +;;; cider-popup.el --- Creating and quitting popup buffers -*- lexical-binding: t; -*- + +;; Copyright © 2015-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Common functionality for dealing with popup buffers. + +;;; Code: + +(require 'subr-x) +(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-20170129.1941/cider-repl-history.el b/elpa/cider-20170129.1941/cider-repl-history.el new file mode 100644 index 00000000..3f6242ed --- /dev/null +++ b/elpa/cider-20170129.1941/cider-repl-history.el @@ -0,0 +1,729 @@ +;;; cider-repl-history.el --- REPL input history browser + +;; Copyright (c) 2017 John Valente and browse-kill-ring authors + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;; Based heavily on browse-kill-ring +;; https://github.com/browse-kill-ring/browse-kill-ring + +;;; Commentary: + +;; REPL input history browser for CIDER. + +;; Allows you to browse the full input history for your REPL buffer, and +;; insert previous commands at the prompt. + +;;; Code: + +(require 'cl-lib) +(require 'cider-compat) +(require 'cider-popup) +(require 'clojure-mode) +(require 'derived) +(require 'pulse) + +(defconst cider-repl-history-buffer "*cider-repl-history*") +(add-to-list 'cider-ancillary-buffers cider-repl-history-buffer) + +(defgroup cider-repl-history nil + "A package for browsing and inserting the items in the CIDER command history." + :prefix "cider-repl-history-" + :group 'cider) + +(defvar cider-repl-history-display-styles + '((separated . cider-repl-history-insert-as-separated) + (one-line . cider-repl-history-insert-as-one-line))) + +(defcustom cider-repl-history-display-style 'separated + "How to display the CIDER command history items. + +If `one-line', then replace newlines with \"\\n\" for display. + +If `separated', then display `cider-repl-history-separator' between +entries." + :type '(choice (const :tag "One line" one-line) + (const :tag "Separated" separated)) + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-quit-action 'quit-window + "What action to take when `cider-repl-history-quit' is called. + +If `bury-buffer', then simply bury the *cider-repl-history* buffer, but keep +the window. + +If `bury-and-delete-window', then bury the buffer, and (if there is +more than one window) delete the window. + +If `delete-and-restore', then restore the window configuration to what it was +before `cider-repl-history' was called, and kill the *cider-repl-history* buffer. + +If `quit-window', then restore the window configuration to what +it was before `cider-repl-history' was called, and bury *cider-repl-history*. +This is the default. + +If `kill-and-delete-window', then kill the *cider-repl-history* buffer, and +delete the window on close. + +Otherwise, it should be a function to call." + ;; Note, if you use one of the non-"delete" options, after you "quit", + ;; the *cider-repl-history* buffer is still available. If you are using + ;; `cider-repl-history-show-preview', and you switch to *cider-repl-history* (i.e., + ;; with C-x b), it will not give the preview unless and until you "update" + ;; the *cider-repl-history* buffer. + ;; + ;; This really should not be an issue, because there's no reason to "switch" + ;; back to the buffer. If you want to get it back, you can just do C-c M-p + ;; from the REPL buffer. + + ;; If you get in this situation and find it annoying, you can either disable + ;; the preview, or set `cider-repl-history-quit-action' to 'delete-and-restore. + ;; Then you will simply not have the *cider-repl-history* buffer after you quit, + ;; and it won't be an issue. + + :type '(choice (const :tag "Bury buffer" + :value bury-buffer) + (const :tag "Bury buffer and delete window" + :value bury-and-delete-window) + (const :tag "Delete window" + :value delete-and-restore) + (const :tag "Save and restore" + :value quit-window) + (const :tag "Kill buffer and delete window" + :value kill-and-delete-window) + function) + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-resize-window nil + "Whether to resize the `cider-repl-history' window to fit its contents. +Value is either t, meaning yes, or a cons pair of integers, + (MAXIMUM . MINIMUM) for the size of the window. MAXIMUM defaults to +the window size chosen by `pop-to-buffer'; MINIMUM defaults to +`window-min-height'." + :type '(choice (const :tag "No" nil) + (const :tag "Yes" t) + (cons (integer :tag "Maximum") (integer :tag "Minimum"))) + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-separator ";;;;;;;;;;" + "The string separating entries in the `separated' style. +See `cider-repl-history-display-style'." + ;; The (default) separator is a Clojure comment, to preserve fontification + ;; in the buffer. + :type 'string + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-recenter nil + "If non-nil, then always keep the current entry at the top of the window." + :type 'boolean + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-highlight-current-entry nil + "If non-nil, highlight the currently selected command history entry." + :type 'boolean + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-highlight-inserted-item nil + "If non-nil, then temporarily highlight the inserted command history entry. +The value selected controls how the inserted item is highlighted, +possible values are `solid' (highlight the inserted text for a +fixed period of time), or `pulse' (fade out the highlighting gradually). +Setting this variable to the value t will select the default +highlighting style, which currently `pulse'. + +The variable `cider-repl-history-inserted-item-face' contains the +face used for highlighting." + :type '(choice (const nil) (const t) (const solid) (const pulse)) + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-separator-face 'bold + "The face in which to highlight the `cider-repl-history-separator'." + :type 'face + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-current-entry-face 'highlight + "The face in which to highlight the command history current entry." + :type 'face + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-inserted-item-face 'highlight + "The face in which to highlight the inserted item." + :type 'face + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-maximum-display-length nil + "Whether or not to limit the length of displayed items. + +If this variable is an integer, the display of the command history will be +limited to that many characters. +Setting this variable to nil means no limit." + :type '(choice (const :tag "None" nil) + integer) + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-display-duplicates t + "If non-nil, then display duplicate items in the command history." + :type 'boolean + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-display-duplicate-highest t + "When `cider-repl-history-display-duplicates' is nil, then display highest (most recent) duplicate items in the command history." + :type 'boolean + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-text-properties nil + "If non-nil, maintain text properties of the command history items." + :type 'boolean + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-hook nil + "A list of functions to call after `cider-repl-history'." + :type 'hook + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-history-show-preview nil + "If non-nil, show a preview of the inserted text in the REPL buffer. + +The REPL buffer would show a preview of what the buffer would look like +if the item under point were inserted." + + :type 'boolean + :group 'cider-repl-history + :package-version '(cider . "0.15.0")) + +(defvar cider-repl-history-repl-window nil + "The window in which chosen command history data will be inserted. +It is probably not a good idea to set this variable directly; simply +call `cider-repl-history' again.") + +(defvar cider-repl-history-repl-buffer nil + "The buffer in which chosen command history data will be inserted. +It is probably not a good idea to set this variable directly; simply +call `cider-repl-history' again.") + +(defvar cider-repl-history-preview-overlay nil + "The overlay used to preview what would happen if the user inserted the given text.") + +(defvar cider-repl-history-previous-overlay nil + "Previous overlay within *cider-repl-history* buffer.") + + +(defun cider-repl-history-get-history () + "Function to retrieve history from the REPL buffer." + (if cider-repl-history-repl-buffer + (buffer-local-value + 'cider-repl-input-history + cider-repl-history-repl-buffer) + (error "Variable `cider-repl-history-repl-buffer' not bound to a buffer"))) + +(defun cider-repl-history-resize-window () + "If variable `cider-repl-history-resize-window' is non-nil, resize the *cider-repl-history* window." + (when cider-repl-history-resize-window + (apply #'fit-window-to-buffer (selected-window) + (if (consp cider-repl-history-resize-window) + (list (car cider-repl-history-resize-window) + (or (cdr cider-repl-history-resize-window) + window-min-height)) + (list nil window-min-height))))) + +(defun cider-repl-history-read-regexp (msg use-default-p) + "Get a regular expression from the user, prompting with MSG; previous entry is default if USE-DEFAULT-P." + (let* ((default (car regexp-history)) + (input + (read-from-minibuffer + (if (and default use-default-p) + (format "%s for regexp (default `%s'): " + msg + default) + (format "%s (regexp): " msg)) + nil + nil + nil + 'regexp-history + (if use-default-p nil default)))) + (if (equal input "") + (if use-default-p default nil) + input))) + +(defun cider-repl-history-clear-preview () + "Clear the preview, if one is present." + (interactive) + (when cider-repl-history-preview-overlay + (cl-assert (overlayp cider-repl-history-preview-overlay)) + (delete-overlay cider-repl-history-preview-overlay))) + +(defun cider-repl-history-cleanup-on-exit () + "Function called when the user is finished with `cider-repl-history'. +This function performs any cleanup that is required when the user +has finished interacting with the *cider-repl-history* buffer. For now +the only cleanup performed is to remove the preview overlay, if +it's turned on." + (cider-repl-history-clear-preview)) + +(defun cider-repl-history-quit () + "Take the action specified by `cider-repl-history-quit-action'." + (interactive) + (cider-repl-history-cleanup-on-exit) + (pcase cider-repl-history-quit-action + (`delete-and-restore + (quit-restore-window (selected-window) 'kill)) + (`quit-window + (quit-window)) + (`kill-and-delete-window + (kill-buffer (current-buffer)) + (unless (= (count-windows) 1) + (delete-window))) + (`bury-and-delete-window + (bury-buffer) + (unless (= (count-windows) 1) + (delete-window))) + (_ + (funcall cider-repl-history-quit-action)))) + +(defun cider-repl-history-preview-overlay-setup (orig-buf) + "Setup the preview overlay in ORIG-BUF." + (when cider-repl-history-show-preview + (with-current-buffer orig-buf + (let* ((will-replace (region-active-p)) + (start (if will-replace + (min (point) (mark)) + (point))) + (end (if will-replace + (max (point) (mark)) + (point)))) + (cider-repl-history-clear-preview) + (setq cider-repl-history-preview-overlay + (make-overlay start end orig-buf)) + (overlay-put cider-repl-history-preview-overlay + 'invisible t))))) + +(defun cider-repl-history-highlight-inserted (start end) + "Insert the text between START and END." + (pcase cider-repl-history-highlight-inserted-item + ((or `pulse `t) + (let ((pulse-delay .05) (pulse-iterations 10)) + (with-no-warnings + (pulse-momentary-highlight-region + start end cider-repl-history-inserted-item-face)))) + (`solid + (let ((o (make-overlay start end))) + (overlay-put o 'face cider-repl-history-inserted-item-face) + (sit-for 0.5) + (delete-overlay o))))) + +(defun cider-repl-history-insert-and-highlight (str) + "Helper function to insert STR at point, highlighting it if appropriate." + (let ((before-insert (point))) + (let (deactivate-mark) + (insert-for-yank str)) + (cider-repl-history-highlight-inserted + before-insert + (point)))) + +(defun cider-repl-history-target-overlay-at (position &optional no-error) + "Return overlay at POSITION that has property `cider-repl-history-target'. +If no such overlay, raise an error unless NO-ERROR is true, in which +case retun nil." + (let ((ovs (overlays-at (point)))) + (catch 'cider-repl-history-target-overlay-at + (dolist (ov ovs) + (when (overlay-get ov 'cider-repl-history-target) + (throw 'cider-repl-history-target-overlay-at ov))) + (unless no-error + (error "No CIDER history item here"))))) + +(defun cider-repl-history-current-string (pt &optional no-error) + "Find the string to insert into the REPL by looking for the overlay at PT; might error unless NO-ERROR set." + (let ((o (cider-repl-history-target-overlay-at pt t))) + (if o + (overlay-get o 'cider-repl-history-target) + (unless no-error + (error "No CIDER history item in this buffer"))))) + +(defun cider-repl-history-do-insert (buf pt) + "Helper function to insert text from BUF at PT into the REPL buffer and kill *cider-repl-history*." + ;; Note: as mentioned at the top, this file is based on browse-kill-ring, + ;; which has numerous insertion options. The functionality of + ;; browse-kill-ring allows users to insert at point, and move point to the end + ;; of the inserted text; or insert at the beginning or end of the buffer, + ;; while leaving point alone. And each of these had the option of leaving the + ;; history buffer in place, or getting rid of it. That was appropriate for a + ;; generic paste tool, but for inserting a previous command into an + ;; interpreter, I felt the only useful option would be inserting it at the end + ;; and quitting the history buffer, so that is all that's provided. + (let ((str (cider-repl-history-current-string pt))) + (cider-repl-history-quit) + (with-selected-window cider-repl-history-repl-window + (with-current-buffer cider-repl-history-repl-buffer + (let ((max (point-max))) + (if (= max (point)) + (cider-repl-history-insert-and-highlight str) + (save-excursion + (goto-char max) + (cider-repl-history-insert-and-highlight str)))))))) + +(defun cider-repl-history-insert-and-quit () + "Insert the item into the REPL buffer, and close the *cider-repl-history* buffer. + +The text is always inserted at the very bottom of the REPL buffer. If your +cursor is already at the bottom, it is advanced to the end of the inserted +text. If your cursor is somewhere else, the cursor is not moved, but the +text is still inserted at the end." + (interactive) + (cider-repl-history-do-insert (current-buffer) (point))) + +(defun cider-repl-history-mouse-insert (e) + "Insert the item at E into the REPL buffer, and close the *cider-repl-history*. + +The text is always inserted at the very bottom of the REPL buffer. If your +cursor is already at the bottom, it is advanced to the end of the inserted +text. If your cursor is somewhere else, the cursor is not moved, but the +text is still inserted at the end." + (interactive "e") + (let* ((data (save-excursion + (mouse-set-point e) + (cons (current-buffer) (point)))) + (buf (car data)) + (pt (cdr data))) + (cider-repl-history-do-insert buf pt))) + +(defun cider-repl-history-clear-highlighed-entry () + "Clear the highlighted entry, when one exists." + (when cider-repl-history-previous-overlay + (cl-assert (overlayp cider-repl-history-previous-overlay) + t "not an overlay") + (overlay-put cider-repl-history-previous-overlay 'face nil))) + +(defun cider-repl-history-update-highlighed-entry () + "Update highlighted entry, when feature is turned on." + (when cider-repl-history-highlight-current-entry + (if-let ((current-overlay (cider-repl-history-target-overlay-at (point) t))) + (unless (equal cider-repl-history-previous-overlay current-overlay) + ;; We've changed overlay. Clear current highlighting, + ;; and highlight the new overlay. + (cl-assert (overlay-get current-overlay 'cider-repl-history-target) t) + (cider-repl-history-clear-highlighed-entry) + (setq cider-repl-history-previous-overlay current-overlay) + (overlay-put current-overlay 'face + cider-repl-history-current-entry-face)) + ;; No overlay at point. Just clear all current highlighting. + (cider-repl-history-clear-highlighed-entry)))) + +(defun cider-repl-history-forward (&optional arg) + "Move forward by ARG command history entries." + (interactive "p") + (beginning-of-line) + (while (not (zerop arg)) + (let ((o (cider-repl-history-target-overlay-at (point) t))) + (cond + ((>= arg 0) + (setq arg (1- arg)) + ;; We're on a cider-repl-history overlay, skip to the end of it. + (when o + (goto-char (overlay-end o)) + (setq o nil)) + (while (not (or o (eobp))) + (goto-char (next-overlay-change (point))) + (setq o (cider-repl-history-target-overlay-at (point) t)))) + (t + (setq arg (1+ arg)) + (when o + (goto-char (overlay-start o)) + (setq o nil)) + (while (not (or o (bobp))) + (goto-char (previous-overlay-change (point))) + (setq o (cider-repl-history-target-overlay-at (point) t))))))) + (when cider-repl-history-recenter + (recenter 1))) + +(defun cider-repl-history-previous (&optional arg) + "Move backward by ARG command history entries." + (interactive "p") + (cider-repl-history-forward (- arg))) + +(defun cider-repl-history-search-forward (regexp &optional backwards) + "Move to the next command history entry matching REGEXP from point. +If optional arg BACKWARDS is non-nil, move to the previous matching +entry." + (interactive + (list (cider-repl-history-read-regexp "Search forward" t) + current-prefix-arg)) + (let ((orig (point))) + (cider-repl-history-forward (if backwards -1 1)) + (let ((over (cider-repl-history-target-overlay-at (point) t))) + (while (and over + (not (if backwards (bobp) (eobp))) + (not (string-match regexp + (overlay-get over + 'cider-repl-history-target)))) + (cider-repl-history-forward (if backwards -1 1)) + (setq over (cider-repl-history-target-overlay-at (point) t))) + (unless (and over + (string-match regexp + (overlay-get over + 'cider-repl-history-target))) + (goto-char orig) + (message "No more command history entries matching %s" regexp))))) + +(defun cider-repl-history-search-backward (regexp) + "Move to the previous command history entry matching REGEXP from point." + (interactive + (list (cider-repl-history-read-regexp "Search backward" t))) + (cider-repl-history-search-forward regexp t)) + +(defun cider-repl-history-elide (str) + "If STR is too long, abbreviate it with an ellipsis; otherwise, return it unchanged." + (if (and cider-repl-history-maximum-display-length + (> (length str) + cider-repl-history-maximum-display-length)) + (concat (substring str 0 (- cider-repl-history-maximum-display-length 3)) + (propertize "..." 'cider-repl-history-extra t)) + str)) + +(defmacro cider-repl-history-add-overlays-for (item &rest body) + "Add overlays for ITEM, and execute BODY." + (let ((beg (cl-gensym "cider-repl-history-add-overlays-")) + (end (cl-gensym "cider-repl-history-add-overlays-"))) + `(let ((,beg (point)) + (,end + (progn + ,@body + (point)))) + (let ((o (make-overlay ,beg ,end))) + (overlay-put o 'cider-repl-history-target ,item) + (overlay-put o 'mouse-face 'highlight))))) + +(defun cider-repl-history-insert-as-separated (items) + "Insert ITEMS into the current buffer, with separators between items." + (while items + (let* ((origitem (car items)) + (item (cider-repl-history-elide origitem)) + (len (length item))) + (cider-repl-history-add-overlays-for origitem (insert item)) + ;; When the command history has items with read-only text property at + ;; **the end of** string, cider-repl-history-setup fails with error + ;; `Text is read-only'. So inhibit-read-only here. + ;; See http://bugs.debian.org/225082 + (let ((inhibit-read-only t)) + (insert "\n") + (when (cdr items) + (insert (propertize cider-repl-history-separator + 'cider-repl-history-extra t + 'cider-repl-history-separator t)) + (insert "\n")))) + (setq items (cdr items)))) + +(defun cider-repl-history-insert-as-one-line (items) + "Insert ITEMS into the current buffer, formatting each item as a single line. + +An explicit newline character will replace newlines so that the text retains its +spacing when it's actually inserted into the REPL buffer." + (dolist (item items) + (cider-repl-history-add-overlays-for + item + (let* ((item (cider-repl-history-elide item)) + (len (length item)) + (start 0) + (newl (propertize "\\n" 'cider-repl-history-extra t))) + (while (and (< start len) + (string-match "\n" item start)) + (insert (substring item start (match-beginning 0)) + newl) + (setq start (match-end 0))) + (insert (substring item start len)))) + (insert "\n"))) + +(defun cider-repl-history-preview-update-text (preview-text) + "Update `cider-repl-history-preview-overlay' to show `PREVIEW-TEXT`." + ;; If preview-text is nil, replacement should be nil too. + (cl-assert (overlayp cider-repl-history-preview-overlay)) + (let ((replacement (when preview-text + (propertize preview-text 'face 'highlight)))) + (overlay-put cider-repl-history-preview-overlay + 'before-string replacement))) + +(defun cider-repl-history-preview-update-by-position (&optional pt) + "Update `cider-repl-history-preview-overlay' to match item at PT. + +This function is called whenever the selection in the *cider-repl-history* +buffer is adjusted, the `cider-repl-history-preview-overlay' +is udpated to preview the text of the selection at PT (or the +current point if not specified)." + (let ((new-text (cider-repl-history-current-string + (or pt (point)) t))) + (cider-repl-history-preview-update-text new-text))) + +(defun cider-repl-history-undo-other-window () + "Undo the most recent change in the other window's buffer. +You most likely want to use this command for undoing an insertion of +text from the *cider-repl-history* buffer." + (interactive) + (with-current-buffer cider-repl-history-repl-buffer + (undo))) + +(defun cider-repl-history-setup (repl-win repl-buf history-buf &optional regexp) + "Setup: REPL-WIN and REPL-BUF are where to insert commands, HISTORY-BUF is the history, and optional arg REGEXP is a filter." + (cider-repl-history-preview-overlay-setup repl-buf) + (with-current-buffer history-buf + (unwind-protect + (progn + (cider-repl-history-mode) + (setq buffer-read-only nil) + (when (eq 'one-line cider-repl-history-display-style) + (setq truncate-lines t)) + (let ((inhibit-read-only t)) + (erase-buffer)) + (setq cider-repl-history-repl-buffer repl-buf) + (setq cider-repl-history-repl-window repl-win) + (let* ((cider-repl-history-maximum-display-length + (if (and cider-repl-history-maximum-display-length + (<= cider-repl-history-maximum-display-length 3)) + 4 + cider-repl-history-maximum-display-length)) + (cider-command-history (cider-repl-history-get-history)) + (items (mapcar + (if cider-repl-history-text-properties + #'copy-sequence + #'substring-no-properties) + cider-command-history))) + (when (not cider-repl-history-display-duplicates) + ;; display highest or lowest duplicate. + ;; if `cider-repl-history-display-duplicate-highest' is t, + ;; display highest (most recent) duplicate. + (cl-delete-duplicates + items + :test #'equal + :from-end cider-repl-history-display-duplicate-highest)) + (when (stringp regexp) + (setq items (delq nil + (mapcar + #'(lambda (item) + (when (string-match regexp item) + item)) + items)))) + (funcall (or (cdr (assq cider-repl-history-display-style + cider-repl-history-display-styles)) + (error "Invalid `cider-repl-history-display-style': %s" + cider-repl-history-display-style)) + items) + (when cider-repl-history-show-preview + (cider-repl-history-preview-update-by-position (point-min)) + ;; Local post-command-hook, only happens in *cider-repl-history* + (add-hook 'post-command-hook + 'cider-repl-history-preview-update-by-position + nil t) + (add-hook 'kill-buffer-hook + 'cider-repl-history-cleanup-on-exit + nil t)) + (when cider-repl-history-highlight-current-entry + (add-hook 'post-command-hook + 'cider-repl-history-update-highlighed-entry + nil t)) + (message + (let ((entry (if (= 1 (length cider-command-history)) + "entry" + "entries"))) + (concat + (if (and (not regexp) + cider-repl-history-display-duplicates) + (format "%s %s in the command history." + (length cider-command-history) entry) + (format "%s (of %s) %s in the command history shown." + (length items) (length cider-command-history) entry)) + (substitute-command-keys + (concat " Type \\[cider-repl-history-quit] to quit. " + "\\[describe-mode] for help."))))) + (set-buffer-modified-p nil) + (goto-char (point-min)) + (cider-repl-history-forward 0) + (setq mode-name (if regexp + (concat "History [" regexp "]") + "History")) + (run-hooks 'cider-repl-history-hook))) + (setq buffer-read-only t)))) + +(defun cider-repl-history-update () + "Update the history buffer to reflect the latest state of the command history." + (interactive) + (cl-assert (eq major-mode 'cider-repl-history-mode)) + (cider-repl-history-setup cider-repl-history-repl-window + cider-repl-history-repl-buffer + (current-buffer)) + (cider-repl-history-resize-window)) + +(defun cider-repl-history-occur (regexp) + "Display all command history entries matching REGEXP." + (interactive + (list (cider-repl-history-read-regexp + "Display command history entries matching" nil))) + (cl-assert (eq major-mode 'cider-repl-history-mode)) + (cider-repl-history-setup cider-repl-history-repl-window + cider-repl-history-repl-buffer + (current-buffer) + regexp) + (cider-repl-history-resize-window)) + +(put 'cider-repl-history-mode 'mode-class 'special) +(define-derived-mode cider-repl-history-mode clojure-mode "History" + "Major mode for browsing the entries in the command input history. + +\\{cider-repl-history-mode-map}" + (define-key cider-repl-history-mode-map (kbd "n") 'cider-repl-history-forward) + (define-key cider-repl-history-mode-map (kbd "p") 'cider-repl-history-previous) + (define-key cider-repl-history-mode-map (kbd "SPC") 'cider-repl-history-insert-and-quit) + (define-key cider-repl-history-mode-map (kbd "RET") 'cider-repl-history-insert-and-quit) + (define-key cider-repl-history-mode-map [(mouse-2)] 'cider-repl-history-mouse-insert) + (define-key cider-repl-history-mode-map (kbd "l") 'cider-repl-history-occur) + (define-key cider-repl-history-mode-map (kbd "s") 'cider-repl-history-search-forward) + (define-key cider-repl-history-mode-map (kbd "r") 'cider-repl-history-search-backward) + (define-key cider-repl-history-mode-map (kbd "g") 'cider-repl-history-update) + (define-key cider-repl-history-mode-map (kbd "q") 'cider-repl-history-quit) + (define-key cider-repl-history-mode-map (kbd "U") 'cider-repl-history-undo-other-window) + (define-key cider-repl-history-mode-map (kbd "?") 'describe-mode) + (define-key cider-repl-history-mode-map (kbd "h") 'describe-mode)) + +;;;###autoload +(defun cider-repl-history () + "Display items in the CIDER command history in another buffer." + (interactive) + (when (eq major-mode 'cider-repl-history-mode) + (user-error "Already viewing the CIDER command history")) + + (let* ((repl-win (selected-window)) + (repl-buf (window-buffer repl-win)) + (buf (get-buffer-create cider-repl-history-buffer))) + (cider-repl-history-setup repl-win repl-buf buf) + (pop-to-buffer buf) + (cider-repl-history-resize-window))) + +(provide 'cider-repl-history) + +;;; cider-repl-history.el ends here diff --git a/elpa/cider-20170129.1941/cider-repl.el b/elpa/cider-20170129.1941/cider-repl.el new file mode 100644 index 00000000..23c778a8 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-repl.el @@ -0,0 +1,1402 @@ +;;; cider-repl.el --- REPL interactions -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; 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 'subr-x) +(require 'cider-compat) +(require 'cider-util) +(require 'cider-resolve) + +(require 'clojure-mode) +(require 'easymenu) +(require 'cl-lib) + +(eval-when-compile + (defvar paredit-version) + (defvar paredit-space-for-delimiter-predicates)) + + +(defgroup cider-repl nil + "Interaction with the REPL." + :prefix "cider-repl-" + :group 'cider) + +(defface cider-repl-prompt-face + '((t (:inherit font-lock-keyword-face))) + "Face for the prompt in the REPL buffer." + :group 'cider-repl) + +(defface cider-repl-stdout-face + '((t (:inherit font-lock-string-face))) + "Face for STDOUT output in the REPL buffer." + :group 'cider-repl) + +(defface cider-repl-stderr-face + '((t (:inherit font-lock-warning-face))) + "Face for STDERR output in the REPL buffer." + :group 'cider-repl + :package-version '(cider . "0.6.0")) + +(defface cider-repl-input-face + '((t (:bold t))) + "Face for previous input in the REPL buffer." + :group 'cider-repl) + +(defface cider-repl-result-face + '((t ())) + "Face for the result of an evaluation in the REPL buffer." + :group 'cider-repl) + +(defcustom cider-repl-pop-to-buffer-on-connect t + "Controls whether to pop to the REPL buffer on connect. + +When set to nil the buffer will only be created, and not displayed. When +set to `display-only' the buffer will be displayed, but it will not become +focused. Otherwise the buffer is displayed and focused." + :type '(choice (const :tag "Create the buffer, but don't display it" nil) + (const :tag "Create and display the buffer, but don't focus it" + display-only) + (const :tag "Create, display, and focus the buffer" t)) + :group 'cider-repl) + +(defcustom cider-repl-display-in-current-window nil + "Controls whether the REPL buffer is displayed in the current window." + :type 'boolean + :group 'cider-repl) + +(defcustom cider-repl-scroll-on-output t + "Controls whether the REPL buffer auto-scrolls on new output. + +When set to t (the default), if the REPL buffer contains more lines than the +size of the window, the buffer is automatically re-centered upon completion +of evaluating an expression, so that the bottom line of output is on the +bottom line of the window. + +If this is set to nil, no re-centering takes place." + :type 'boolean + :group 'cider-repl + :package-version '(cider . "0.11.0")) + +(defcustom cider-repl-use-pretty-printing nil + "Control whether the results in REPL are pretty-printed or not. +The `cider-toggle-pretty-printing' command can be used to interactively +change the setting's value." + :type 'boolean + :group 'cider-repl) + +(defcustom cider-repl-pretty-print-width nil + "Control the width of pretty printing on the REPL. +This sets the wrap point for pretty printing on the repl. If nil, it +defaults to the variable `fill-column'." + :type '(restricted-sexp :match-alternatives + (integerp 'nil)) + :group 'cider-repl + :package-version '(cider . "0.15.0")) + +(defcustom cider-repl-use-clojure-font-lock t + "Non-nil means to use Clojure mode font-locking for input and result. +Nil means that `cider-repl-input-face' and `cider-repl-result-face' +will be used." + :type 'boolean + :group 'cider-repl + :package-version '(cider . "0.10.0")) + +(defcustom cider-repl-result-prefix "" + "The prefix displayed in the REPL before a result value." + :type 'string + :group 'cider + :package-version '(cider . "0.5.0")) + +(defcustom cider-repl-tab-command 'cider-repl-indent-and-complete-symbol + "Select the command to be invoked by the TAB key. +The default option is `cider-repl-indent-and-complete-symbol'. If +you'd like to use the default Emacs behavior use +`indent-for-tab-command'." + :type 'symbol + :group 'cider-repl) + +(defcustom cider-repl-display-help-banner t + "When non-nil a bit of help text will be displayed on REPL start." + :type 'boolean + :group 'cider-repl + :package-version '(cider . "0.11.0")) + + +;;;; 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))) + (pcase cider-repl-pop-to-buffer-on-connect + (`display-only (display-buffer buffer)) + ((pred identity) (pop-to-buffer buffer))) + (cider-remember-clojure-buffer cider-current-clojure-buffer) + buffer) + +(defun cider-repl--banner () + "Generate the welcome REPL buffer banner." + (let ((host (cider--connection-host (current-buffer))) + (port (cider--connection-port (current-buffer)))) + (format ";; Connected to nREPL server - nrepl://%s:%s +;; CIDER %s, nREPL %s +;; Clojure %s, Java %s +;; Docs: (doc function-name) +;; (find-doc part-of-name) +;; Source: (source function-name) +;; Javadoc: (javadoc java-object-or-class) +;; Exit: +;; 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 (cider--pretty-print-width)))))) + +(defun cider-repl-return (&optional end-of-input) + "Evaluate the current input string, or insert a newline. +Send the current input ony if a whole expression has been entered, +i.e. the parenthesis are matched. +When END-OF-INPUT is non-nil, send the input even if the parentheses +are not balanced." + (interactive "P") + (cond + (end-of-input + (cider-repl--send-input)) + ((and (get-text-property (point) 'cider-old-input) + (< (point) cider-repl-input-start-mark)) + (cider-repl--grab-old-input end-of-input) + (cider-repl--recenter-if-needed)) + ((cider-repl--input-complete-p cider-repl-input-start-mark (point-max)) + (cider-repl--send-input t)) + (t + (cider-repl-newline-and-indent) + (message "[input not complete]")))) + +(defun cider-repl--recenter-if-needed () + "Make sure that the point is visible." + (unless (pos-visible-in-window-p (point-max)) + (save-excursion + (goto-char (point-max)) + (recenter -1)))) + +(defun cider-repl--grab-old-input (replace) + "Resend the old REPL input at point. +If REPLACE is non-nil the current input is replaced with the old +input; otherwise the new input is appended. The old input has the +text property `cider-old-input'." + (cl-multiple-value-bind (beg end) (cider-property-bounds 'cider-old-input) + (let ((old-input (buffer-substring beg end)) ;;preserve + ;;properties, they will be removed later + (offset (- (point) beg))) + ;; Append the old input or replace the current input + (cond (replace (goto-char cider-repl-input-start-mark)) + (t (goto-char (point-max)) + (unless (eq (char-before) ?\ ) + (insert " ")))) + (delete-region (point) (point-max)) + (save-excursion + (insert old-input) + (when (equal (char-before) ?\n) + (delete-char -1))) + (forward-char offset)))) + +(defun cider-repl-closing-return () + "Evaluate the current input string after closing all open parenthesized or bracketed expressions." + (interactive) + (goto-char (point-max)) + (save-restriction + (narrow-to-region cider-repl-input-start-mark (point)) + (let ((matching-delimiter nil)) + (while (ignore-errors (save-excursion + (backward-up-list 1) + (setq matching-delimiter (cdr (syntax-after (point))))) t) + (insert-char matching-delimiter)))) + (cider-repl-return)) + +(defun cider-repl-toggle-pretty-printing () + "Toggle pretty-printing in the REPL." + (interactive) + (setq cider-repl-use-pretty-printing (not cider-repl-use-pretty-printing)) + (message "Pretty printing in REPL %s." + (if cider-repl-use-pretty-printing "enabled" "disabled"))) + +(defun cider--pretty-print-width () + "Returns the width to use for pretty-printing." + (or cider-repl-pretty-print-width + fill-column + 80)) + +(defun cider-repl-switch-to-other () + "Switch between the Clojure and ClojureScript REPLs for the current project." + (interactive) + (if-let (other-connection (cider-other-connection)) + (switch-to-buffer other-connection) + (message "There's no other REPL for the current project"))) + +(defvar cider-repl-clear-buffer-hook) + +(defun cider-repl--clear-region (start end) + "Delete the output and its overlays between START and END." + (mapc #'delete-overlay (overlays-in start end)) + (delete-region start end)) + +(defun cider-repl-clear-buffer () + "Delete the output generated by the Clojure process." + (interactive) + (let ((inhibit-read-only t)) + (cider-repl--clear-region (point-min) cider-repl-prompt-start-mark) + (cider-repl--clear-region cider-repl-output-start cider-repl-output-end) + (when (< (point) cider-repl-input-start-mark) + (goto-char cider-repl-input-start-mark)) + (recenter t)) + (run-hooks 'cider-repl-clear-buffer-hook)) + +(defun cider-repl--end-of-line-before-input-start () + "Return the position of the end of the line preceding the beginning of input." + (1- (previous-single-property-change cider-repl-input-start-mark 'field nil + (1+ (point-min))))) + +(defun cider-repl-clear-output (&optional clear-repl) + "Delete the output inserted since the last input. +With a prefix argument CLEAR-REPL it will clear the entire REPL buffer instead." + (interactive "P") + (if clear-repl + (cider-repl-clear-buffer) + (let ((start (save-excursion + (cider-repl-previous-prompt) + (ignore-errors (forward-sexp)) + (forward-line) + (point))) + (end (cider-repl--end-of-line-before-input-start))) + (when (< start end) + (let ((inhibit-read-only t)) + (cider-repl--clear-region start end) + (save-excursion + (goto-char start) + (insert + (propertize ";; output cleared" 'font-lock-face 'font-lock-comment-face)))))))) + +(defun cider-repl-clear-banners () + "Delete the REPL banners." + (interactive) + ;; TODO: Improve the boundaries detecting logic + ;; probably it should be based on text properties + ;; the current implemetation will clear warnings as well + (let ((start (point-min)) + (end (save-excursion + (goto-char (point-min)) + (cider-repl-next-prompt) + (forward-line -1) + (end-of-line) + (point)))) + (when (< start end) + (let ((inhibit-read-only t)) + (cider-repl--clear-region start (1+ end)))))) + +(defun cider-repl-clear-help-banner () + "Delete the help REPL banner." + (interactive) + ;; TODO: Improve the boundaries detecting logic + ;; probably it should be based on text properties + (let ((start (save-excursion + (goto-char (point-min)) + (search-forward ";; =") + (beginning-of-line) + (point))) + (end (save-excursion + (goto-char (point-min)) + (cider-repl-next-prompt) + (search-backward ";; =") + (end-of-line) + (point)))) + (when (< start end) + (let ((inhibit-read-only t)) + (cider-repl--clear-region start (1+ end)))))) + +(defun cider-repl-switch-ns-handler (buffer) + "Make an nREPL evaluation handler for the REPL BUFFER's ns switching." + (nrepl-make-response-handler buffer + (lambda (_buffer _value)) + (lambda (buffer out) + (cider-repl-emit-stdout buffer out)) + (lambda (buffer err) + (cider-repl-emit-stderr buffer err)) + (lambda (buffer) + (cider-repl-emit-prompt buffer)))) + +(defun cider-repl-set-ns (ns) + "Switch the namespace of the REPL buffer to NS. + +If called from a cljc or cljx buffer act on both the Clojure and +ClojureScript REPL if there are more than one REPL present. + +If invoked in a REPL buffer the command will prompt for the name of the +namespace to switch to." + (interactive (list (if (or (derived-mode-p 'cider-repl-mode) + (null (cider-ns-form))) + (completing-read "Switch to namespace: " + (cider-sync-request:ns-list)) + (cider-current-ns)))) + (when (or (not ns) (equal ns "")) + (user-error "No namespace selected")) + (cider-map-connections + (lambda (connection) + (cider-nrepl-request:eval (format "(in-ns '%s)" ns) + (cider-repl-switch-ns-handler connection))) + :both)) + + +;;;;; 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-repl-history "cider-repl-history") +(declare-function cider-run "cider-interaction") +(declare-function cider-refresh "cider-interaction") +(cider-repl-add-shortcut "clear-output" #'cider-repl-clear-output) +(cider-repl-add-shortcut "clear" #'cider-repl-clear-buffer) +(cider-repl-add-shortcut "clear-banners" #'cider-repl-clear-banners) +(cider-repl-add-shortcut "clear-help-banner" #'cider-repl-clear-help-banner) +(cider-repl-add-shortcut "ns" #'cider-repl-set-ns) +(cider-repl-add-shortcut "toggle-pretty" #'cider-repl-toggle-pretty-printing) +(cider-repl-add-shortcut "browse-ns" (lambda () (cider-browse-ns (cider-current-ns)))) +(cider-repl-add-shortcut "classpath" #'cider-classpath) +(cider-repl-add-shortcut "history" #'cider-repl-history) +(cider-repl-add-shortcut "trace-ns" #'cider-toggle-trace-ns) +(cider-repl-add-shortcut "undef" #'cider-undef) +(cider-repl-add-shortcut "refresh" #'cider-refresh) +(cider-repl-add-shortcut "help" #'cider-repl-shortcuts-help) +(cider-repl-add-shortcut "test-ns" #'cider-test-run-ns-tests) +(cider-repl-add-shortcut "test-all" #'cider-test-run-loaded-tests) +(cider-repl-add-shortcut "test-project" #'cider-test-run-project-tests) +(cider-repl-add-shortcut "test-report" #'cider-test-show-report) +(cider-repl-add-shortcut "run" #'cider-run) +(cider-repl-add-shortcut "conn-info" #'cider-display-connection-info) +(cider-repl-add-shortcut "conn-rotate" #'cider-rotate-default-connection) +(cider-repl-add-shortcut "hasta la vista" #'cider-quit) +(cider-repl-add-shortcut "adios" #'cider-quit) +(cider-repl-add-shortcut "sayonara" #'cider-quit) +(cider-repl-add-shortcut "quit" #'cider-quit) +(cider-repl-add-shortcut "restart" #'cider-restart) +(cider-repl-add-shortcut "version" #'cider-version) + +(defconst cider-repl-shortcuts-help-buffer "*CIDER REPL Shortcuts Help*") + +(defun cider-repl-shortcuts-help () + "Display a help buffer." + (interactive) + (ignore-errors (kill-buffer cider-repl-shortcuts-help-buffer)) + (with-current-buffer (get-buffer-create cider-repl-shortcuts-help-buffer) + (insert "CIDER REPL shortcuts:\n\n") + (maphash (lambda (k v) (insert (format "%s:\n\t%s\n" k v))) cider-repl-shortcuts) + (goto-char (point-min)) + (help-mode) + (display-buffer (current-buffer) t)) + (cider-repl-handle-shortcut) + (current-buffer)) + +(defun cider-repl--available-shortcuts () + "Return the available REPL shortcuts." + (cider-util--hash-keys cider-repl-shortcuts)) + +(defun cider-repl-handle-shortcut () + "Execute a REPL shortcut." + (interactive) + (if (> (point) cider-repl-input-start-mark) + (insert (string cider-repl-shortcut-dispatch-char)) + (let ((command (completing-read "Command: " + (cider-repl--available-shortcuts)))) + (if (not (equal command "")) + (let ((command-func (gethash command cider-repl-shortcuts))) + (if command-func + (call-interactively (gethash command cider-repl-shortcuts)) + (error "Unknown command %S. Available commands: %s" + command-func + (mapconcat 'identity (cider-repl--available-shortcuts) ", ")))) + (error "No command selected"))))) + + +;;;;; 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-p") #'cider-repl-history) + (define-key map (kbd "C-c M-t v") #'cider-toggle-trace-var) + (define-key map (kbd "C-c M-t n") #'cider-toggle-trace-ns) + (define-key map (kbd "C-c C-x") #'cider-refresh) + (define-key map (kbd "C-x C-e") #'cider-eval-last-sexp) + (define-key map (kbd "C-c C-r") #'cider-eval-region) + (define-key map (string cider-repl-shortcut-dispatch-char) #'cider-repl-handle-shortcut) + (easy-menu-define cider-repl-mode-menu map + "Menu for CIDER's REPL mode" + `("REPL" + ["Complete symbol" complete-symbol] + "--" + ,cider-doc-menu + "--" + ("Find" + ["Find definition" cider-find-var] + ["Find resource" cider-find-resource] + ["Go back" cider-pop-back]) + "--" + ["Switch to Clojure buffer" cider-switch-to-last-clojure-buffer] + ["Switch to other REPL" cider-repl-switch-to-other] + "--" + ("Macroexpand" + ["Macroexpand-1" cider-macroexpand-1] + ["Macroexpand-all" cider-macroexpand-all]) + "--" + ,cider-test-menu + "--" + ["Run project (-main function)" cider-run] + ["Inspect" cider-inspect] + ["Toggle var tracing" cider-toggle-trace-var] + ["Toggle ns tracing" cider-toggle-trace-ns] + ["Refresh loaded code" cider-refresh] + "--" + ["Set REPL ns" cider-repl-set-ns] + ["Toggle pretty printing" cider-repl-toggle-pretty-printing] + "--" + ["Browse classpath" cider-classpath] + ["Browse classpath entry" cider-open-classpath-entry] + ["Browse namespace" cider-browse-ns] + ["Browse all namespaces" cider-browse-ns-all] + "--" + ["Next prompt" cider-repl-next-prompt] + ["Previous prompt" cider-repl-previous-prompt] + ["Clear output" cider-repl-clear-output] + ["Clear buffer" cider-repl-clear-buffer] + ["Clear banners" cider-repl-clear-banners] + ["Clear help banner" cider-repl-clear-help-banner] + ["Kill input" cider-repl-kill-input] + "--" + ["Interrupt evaluation" cider-interrupt] + "--" + ["Connection info" cider-display-connection-info] + "--" + ["Close ancillary buffers" cider-close-ancillary-buffers] + ["Quit" cider-quit] + ["Restart" cider-restart] + "--" + ["A sip of CIDER" cider-drink-a-sip] + ["View manual online" cider-view-manual] + ["View refcard online" cider-view-refcard] + ["Report a bug" cider-report-bug] + ["Version info" cider-version])) + map)) + +(defun cider-repl-wrap-fontify-function (func) + "Return a function that will call FUNC narrowed to input region." + (lambda (beg end &rest rest) + (when (and cider-repl-input-start-mark + (> end cider-repl-input-start-mark)) + (save-restriction + (narrow-to-region cider-repl-input-start-mark (point-max)) + (let ((font-lock-dont-widen t)) + (apply func (max beg cider-repl-input-start-mark) end rest)))))) + +(declare-function cider-complete-at-point "cider-interaction") +(defvar cider--static-font-lock-keywords) + +(define-derived-mode cider-repl-mode fundamental-mode "REPL" + "Major mode for Clojure REPL interactions. + +\\{cider-repl-mode-map}" + (clojure-mode-variables) + (setq-local lisp-indent-function #'clojure-indent-function) + (setq-local indent-line-function #'lisp-indent-line) + (clojure-font-lock-setup) + (font-lock-add-keywords nil cider--static-font-lock-keywords) + (setq-local font-lock-fontify-region-function + (cider-repl-wrap-fontify-function font-lock-fontify-region-function)) + (setq-local font-lock-unfontify-region-function + (cider-repl-wrap-fontify-function font-lock-unfontify-region-function)) + (make-local-variable 'completion-at-point-functions) + (add-to-list 'completion-at-point-functions + #'cider-complete-at-point) + (set-syntax-table cider-repl-mode-syntax-table) + (cider-eldoc-setup) + ;; At the REPL, we define beginning-of-defun and end-of-defun to be + ;; the start of the previous prompt or next prompt respectively. + ;; Notice the interplay with `cider-repl-beginning-of-defun'. + (setq-local beginning-of-defun-function #'cider-repl-mode-beginning-of-defun) + (setq-local end-of-defun-function #'cider-repl-mode-end-of-defun) + (setq-local prettify-symbols-alist clojure--prettify-symbols-alist) + ;; apply dir-local variables to REPL buffers + (hack-dir-local-variables-non-file-buffer) + (when cider-repl-history-file + (cider-repl-history-load cider-repl-history-file) + (add-hook 'kill-buffer-hook #'cider-repl-history-just-save t t) + (add-hook 'kill-emacs-hook #'cider-repl-history-just-save)) + (add-hook 'paredit-mode-hook (lambda () (clojure-paredit-setup cider-repl-mode-map)))) + +(provide 'cider-repl) + +;;; cider-repl.el ends here diff --git a/elpa/cider-20170129.1941/cider-resolve.el b/elpa/cider-20170129.1941/cider-resolve.el new file mode 100644 index 00000000..6f9f8ebf --- /dev/null +++ b/elpa/cider-20170129.1941/cider-resolve.el @@ -0,0 +1,129 @@ +;;; cider-resolve.el --- Resolve clojure symbols according to current nREPL connection + +;; Copyright © 2015-2017 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-20170129.1941/cider-scratch.el b/elpa/cider-20170129.1941/cider-scratch.el new file mode 100644 index 00000000..e4e3150d --- /dev/null +++ b/elpa/cider-20170129.1941/cider-scratch.el @@ -0,0 +1,96 @@ +;;; cider-scratch.el --- *scratch* buffer for Clojure -*- lexical-binding: t -*- + +;; Copyright © 2014-2017 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) +(require 'easymenu) + +(defvar cider-clojure-interaction-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map clojure-mode-map) + (define-key map (kbd "C-j") #'cider-eval-print-last-sexp) + (define-key map [remap paredit-newline] #'cider-eval-print-last-sexp) + (easy-menu-define cider-clojure-interaction-mode-menu map + "Menu for Clojure Interaction mode" + '("Clojure Interaction" + (["Eval and print last sexp" #'cider-eval-print-last-sexp] + "--" + ["Reset" #'cider-scratch-reset] + "--" + ["Set buffer connection" #'cider-assoc-buffer-with-connection] + ["Toggle buffer connection" #'cider-toggle-buffer-connection] + ["Reset buffer connection" #'cider-clear-buffer-local-connection]))) + map)) + +(defconst cider-scratch-buffer-name "*cider-scratch*") + +(push cider-scratch-buffer-name cider-ancillary-buffers) + +;;;###autoload +(defun cider-scratch () + "Go to the scratch buffer named `cider-scratch-buffer-name'." + (interactive) + (pop-to-buffer (cider-find-or-create-scratch-buffer))) + +(defun cider-find-or-create-scratch-buffer () + "Find or create the scratch buffer." + (or (get-buffer cider-scratch-buffer-name) + (cider-create-scratch-buffer))) + +(define-derived-mode cider-clojure-interaction-mode clojure-mode "Clojure Interaction" + "Major mode for typing and evaluating Clojure forms. +Like clojure-mode except that \\[cider-eval-print-last-sexp] evals the Lisp expression +before point, and prints its value into the buffer, advancing point. + +\\{cider-clojure-interaction-mode-map}") + +(defun cider--scratch-insert-welcome-message () + "Insert the welcome message for the scratch buffer." + (insert ";; This buffer is for Clojure experiments and evaluation.\n" + ";; Press C-j to evaluate the last expression.\n\n")) + +(defun cider-create-scratch-buffer () + "Create a new scratch buffer." + (with-current-buffer (get-buffer-create cider-scratch-buffer-name) + (cider-clojure-interaction-mode) + (cider--scratch-insert-welcome-message) + (current-buffer))) + +(defun cider-scratch-reset () + "Reset the current scratch buffer." + (interactive) + (erase-buffer) + (cider--scratch-insert-welcome-message)) + +(provide 'cider-scratch) + +;;; cider-scratch.el ends here diff --git a/elpa/cider-20170129.1941/cider-selector.el b/elpa/cider-20170129.1941/cider-selector.el new file mode 100644 index 00000000..ba85f703 --- /dev/null +++ b/elpa/cider-20170129.1941/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-2017 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-20170129.1941/cider-stacktrace.el b/elpa/cider-20170129.1941/cider-stacktrace.el new file mode 100644 index 00000000..6a244daa --- /dev/null +++ b/elpa/cider-20170129.1941/cider-stacktrace.el @@ -0,0 +1,718 @@ +;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*- + +;; Copyright © 2014-2017 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 'subr-x) +(require 'cider-compat) +(require 'cider-client) +(require 'cider-util) + +(require 'seq) + +;; Variables + +(defgroup cider-stacktrace nil + "Stacktrace filtering and navigation." + :prefix "cider-stacktrace-" + :group 'cider) + +(defcustom cider-stacktrace-fill-column t + "Fill column for error messages in stacktrace display. +If nil, messages will not be wrapped. If truthy but non-numeric, +`fill-column' will be used." + :type 'list + :group 'cider-stacktrace + :package-version '(cider . "0.7.0")) + +(defcustom cider-stacktrace-default-filters '(tooling dup) + "Frame types to omit from initial stacktrace display." + :type 'list + :group 'cider-stacktrace + :package-version '(cider . "0.6.0")) + +(defcustom cider-stacktrace-print-length 50 + "Set the maximum length of sequences in displayed cause data. + +This sets the value of Clojure's `*print-length*` when pretty printing the +`ex-data` map for exception causes in the stacktrace that are instances of +`IExceptionInfo`. + +Be advised that setting this to `nil` will cause the attempted printing of +infinite data structures." + :type '(choice integer (const nil)) + :group 'cider-stacktrace + :package-version '(cider . "0.9.0")) + +(defcustom cider-stacktrace-print-level 50 + "Set the maximum level of nesting in displayed cause data. + +This sets the value of Clojure's `*print-level*` when pretty printing the +`ex-data` map for exception causes in the stacktrace that are instances of +`IExceptionInfo`. + +Be advised that setting this to `nil` will cause the attempted printing of +cyclical data structures." + :type '(choice integer (const nil)) + :group 'cider-stacktrace + :package-version '(cider . "0.8.0")) + +(defvar cider-stacktrace-detail-max 2 + "The maximum detail level for causes.") + +(defvar-local cider-stacktrace-hidden-frame-count 0) +(defvar-local cider-stacktrace-filters nil) +(defvar-local cider-stacktrace-prior-filters nil) +(defvar-local cider-stacktrace-cause-visibility nil) + +(defconst cider-error-buffer "*cider-error*") +(add-to-list 'cider-ancillary-buffers cider-error-buffer) + +(defcustom cider-stacktrace-suppressed-errors '() + "A set of errors that won't make the stacktrace buffer 'pop-over' your active window. +The error types are represented as strings." + :type 'list + :group 'cider-stacktrace + :package-version '(cider . "0.12.0")) + +;; Faces + +(defface cider-stacktrace-error-class-face + '((t (:inherit font-lock-warning-face))) + "Face for exception class names" + :group 'cider-stacktrace + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-error-message-face + '((t (:inherit font-lock-doc-face))) + "Face for exception messages" + :group 'cider-stacktrace + :package-version '(cider . "0.7.0")) + +(defface cider-stacktrace-filter-shown-face + '((t (:inherit button :underline t :weight normal))) + "Face for filter buttons representing frames currently visible" + :group 'cider-stacktrace + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-filter-hidden-face + '((t (:inherit button :underline nil :weight normal))) + "Face for filter buttons representing frames currently filtered out" + :group 'cider-stacktrace + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-face + '((t (:inherit default))) + "Face for stack frame text" + :group 'cider-stacktrace + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-ns-face + '((t (:inherit font-lock-comment-face))) + "Face for stack frame namespace name" + :group 'cider-stacktrace + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-fn-face + '((t (:inherit default :weight bold))) + "Face for stack frame function name" + :group 'cider-stacktrace + :package-version '(cider . "0.6.0")) + +(defface cider-stacktrace-promoted-button-face + '((((type graphic)) + :box (:line-width 3 :style released-button) + :inherit error) + (t :inverse-video t)) + "A button with this face represents a promoted (non-suppressed) error type." + :group 'cider-stacktrace + :package-version '(cider . "0.12.0")) + +(defface cider-stacktrace-suppressed-button-face + '((((type graphic)) + :box (:line-width 3 :style pressed-button) + :inherit widget-inactive-face) + (t :inverse-video t)) + "A button with this face represents a suppressed error type." + :group 'cider-stacktrace + :package-version '(cider . "0.12.0")) + +;; Colors & Theme Support + +(defvar cider-stacktrace-frames-background-color + (cider-scale-background-color) + "Background color for stacktrace frames.") + +(defadvice enable-theme (after cider-stacktrace-adapt-to-theme activate) + "When theme is changed, update `cider-stacktrace-frames-background-color'." + (setq cider-stacktrace-frames-background-color (cider-scale-background-color))) + + +;; Mode & key bindings + +(defvar cider-stacktrace-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "M-p") #'cider-stacktrace-previous-cause) + (define-key map (kbd "M-n") #'cider-stacktrace-next-cause) + (define-key map (kbd "M-.") #'cider-stacktrace-jump) + (define-key map "q" #'cider-popup-buffer-quit-function) + (define-key map "j" #'cider-stacktrace-toggle-java) + (define-key map "c" #'cider-stacktrace-toggle-clj) + (define-key map "r" #'cider-stacktrace-toggle-repl) + (define-key map "t" #'cider-stacktrace-toggle-tooling) + (define-key map "d" #'cider-stacktrace-toggle-duplicates) + (define-key map "a" #'cider-stacktrace-toggle-all) + (define-key map "1" #'cider-stacktrace-cycle-cause-1) + (define-key map "2" #'cider-stacktrace-cycle-cause-2) + (define-key map "3" #'cider-stacktrace-cycle-cause-3) + (define-key map "4" #'cider-stacktrace-cycle-cause-4) + (define-key map "5" #'cider-stacktrace-cycle-cause-5) + (define-key map "0" #'cider-stacktrace-cycle-all-causes) + (define-key map (kbd "TAB") #'cider-stacktrace-cycle-current-cause) + (define-key map [backtab] #'cider-stacktrace-cycle-all-causes) + (easy-menu-define cider-stacktrace-mode-menu map + "Menu for CIDER's stacktrace mode" + '("Stacktrace" + ["Previous cause" cider-stacktrace-previous-cause] + ["Next cause" cider-stacktrace-next-cause] + "--" + ["Jump to frame source" cider-stacktrace-jump] + "--" + ["Cycle current cause detail" cider-stacktrace-cycle-current-cause] + ["Cycle cause #1 detail" cider-stacktrace-cycle-cause-1] + ["Cycle cause #2 detail" cider-stacktrace-cycle-cause-2] + ["Cycle cause #3 detail" cider-stacktrace-cycle-cause-3] + ["Cycle cause #4 detail" cider-stacktrace-cycle-cause-4] + ["Cycle cause #5 detail" cider-stacktrace-cycle-cause-5] + ["Cycle all cause detail" cider-stacktrace-cycle-all-causes] + "--" + ["Show/hide Java frames" cider-stacktrace-toggle-java] + ["Show/hide Clojure frames" cider-stacktrace-toggle-clj] + ["Show/hide REPL frames" cider-stacktrace-toggle-repl] + ["Show/hide tooling frames" cider-stacktrace-toggle-tooling] + ["Show/hide duplicate frames" cider-stacktrace-toggle-duplicates] + ["Show/hide all frames" cider-stacktrace-toggle-all])) + map)) + +(define-derived-mode cider-stacktrace-mode special-mode "Stacktrace" + "Major mode for filtering and navigating CIDER stacktraces. + +\\{cider-stacktrace-mode-map}" + (setq buffer-read-only t) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t)) + (setq-local electric-indent-chars nil) + (setq-local cider-stacktrace-prior-filters nil) + (setq-local cider-stacktrace-hidden-frame-count 0) + (setq-local cider-stacktrace-filters cider-stacktrace-default-filters) + (setq-local cider-stacktrace-cause-visibility (make-vector 10 0))) + + +;; Stacktrace filtering + +(defun cider-stacktrace-indicate-filters (filters) + "Update enabled state of filter buttons. + +Find buttons with a 'filter property; if filter is a member of FILTERS, or +if filter is nil ('show all') and the argument list is non-nil, fontify the +button as disabled. Upon finding text with a 'hidden-count property, stop +searching and update the hidden count text." + (with-current-buffer cider-error-buffer + (save-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t) + (get-face (lambda (hide) + (if hide + 'cider-stacktrace-filter-hidden-face + 'cider-stacktrace-filter-shown-face)))) + ;; Toggle buttons + (while (not (or (get-text-property (point) 'hidden-count) (eobp))) + (let ((button (button-at (point)))) + (when button + (let* ((filter (button-get button 'filter)) + (face (funcall get-face (if filter + (member filter filters) + filters)))) + (button-put button 'face face))) + (goto-char (or (next-property-change (point)) + (point-max))))) + ;; Update hidden count + (when (and (get-text-property (point) 'hidden-count) + (re-search-forward "[0-9]+" (line-end-position) t)) + (replace-match + (number-to-string cider-stacktrace-hidden-frame-count))))))) + +(defun cider-stacktrace-apply-filters (filters) + "Set visibility on stack frames using FILTERS. +Update `cider-stacktrace-hidden-frame-count' and indicate filters applied. +Currently collapsed stacktraces are ignored, and do not contribute to the +hidden count." + (with-current-buffer cider-error-buffer + (save-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t) + (hidden 0)) + (while (not (eobp)) + (unless (get-text-property (point) 'collapsed) + (let* ((flags (get-text-property (point) 'flags)) + (hide (if (seq-intersection filters flags) t nil))) + (when hide (cl-incf hidden)) + (put-text-property (point) (line-beginning-position 2) 'invisible hide))) + (forward-line 1)) + (setq cider-stacktrace-hidden-frame-count hidden))) + (cider-stacktrace-indicate-filters filters))) + + +(defun cider-stacktrace-apply-cause-visibility () + "Apply `cider-stacktrace-cause-visibility' to causes and reapply filters." + (with-current-buffer cider-error-buffer + (save-excursion + (goto-char (point-min)) + (cl-flet ((next-detail (end) + (when-let ((pos (next-single-property-change (point) 'detail))) + (when (< pos end) + (goto-char pos))))) + (let ((inhibit-read-only t)) + ;; For each cause... + (while (cider-stacktrace-next-cause) + (let* ((num (get-text-property (point) 'cause)) + (level (elt cider-stacktrace-cause-visibility num)) + (cause-end (cadr (cider-property-bounds 'cause)))) + ;; For each detail level within the cause, set visibility. + (while (next-detail cause-end) + (let* ((detail (get-text-property (point) 'detail)) + (detail-end (cadr (cider-property-bounds 'detail))) + (hide (if (> detail level) t nil))) + (add-text-properties (point) detail-end + (list 'invisible hide + 'collapsed hide)))))))) + (cider-stacktrace-apply-filters + cider-stacktrace-filters)))) + +;;; Internal/Middleware error suppression + +(defun cider-stacktrace-some-suppressed-errors-p (error-types) + "Return intersection of ERROR-TYPES and CIDER-STACKTRACE-SUPPRESSED-ERRORS. +I.e, Return non-nil if the seq ERROR-TYPES shares any elements with +`cider-stacktrace-suppressed-errors'. This means that even a 'well-behaved' (ie, +promoted) error type will be 'guilty by association' if grouped with a +suppressed error type." + (seq-intersection error-types cider-stacktrace-suppressed-errors)) + +(defun cider-stacktrace-suppress-error (error-type) + "Destructively add element ERROR-TYPE to the `cider-stacktrace-suppressed-errors' set." + (setq cider-stacktrace-suppressed-errors + (cl-adjoin error-type cider-stacktrace-suppressed-errors :test 'equal))) + +(defun cider-stacktrace-promote-error (error-type) + "Destructively remove element ERROR-TYPE from the `cider-stacktrace-suppressed-errors' set." + (setq cider-stacktrace-suppressed-errors + (remove error-type cider-stacktrace-suppressed-errors))) + +(defun cider-stacktrace-suppressed-error-p (error-type) + "Return non-nil if element ERROR-TYPE is a member of the `cider-stacktrace-suppressed-errors' set." + (member error-type cider-stacktrace-suppressed-errors)) + +;; Interactive functions + +(defun cider-stacktrace-previous-cause () + "Move point to the previous exception cause, if one exists." + (interactive) + (with-current-buffer cider-error-buffer + (when-let ((pos (previous-single-property-change (point) 'cause))) + (goto-char pos)))) + +(defun cider-stacktrace-next-cause () + "Move point to the next exception cause, if one exists." + (interactive) + (with-current-buffer cider-error-buffer + (when-let ((pos (next-single-property-change (point) 'cause))) + (goto-char pos)))) + +(defun cider-stacktrace-cycle-cause (num &optional level) + "Update element NUM of `cider-stacktrace-cause-visibility', optionally to LEVEL. +If LEVEL is not specified, its current value is incremented. When it reaches 3, +it wraps to 0." + (let ((level (or level (1+ (elt cider-stacktrace-cause-visibility num))))) + (aset cider-stacktrace-cause-visibility num (mod level 3)) + (cider-stacktrace-apply-cause-visibility))) + +(defun cider-stacktrace-cycle-all-causes () + "Cycle the visibility of all exception causes." + (interactive) + (with-current-buffer cider-error-buffer + (save-excursion + ;; Find nearest cause. + (unless (get-text-property (point) 'cause) + (cider-stacktrace-next-cause) + (unless (get-text-property (point) 'cause) + (cider-stacktrace-previous-cause))) + ;; Cycle its level, and apply that to all causes. + (let* ((num (get-text-property (point) 'cause)) + (level (1+ (elt cider-stacktrace-cause-visibility num)))) + (setq-local cider-stacktrace-cause-visibility + (make-vector 10 (mod level 3))) + (cider-stacktrace-apply-cause-visibility))))) + +(defun cider-stacktrace-cycle-current-cause () + "Cycle the visibility of current exception at point, if any." + (interactive) + (with-current-buffer cider-error-buffer + (when-let ((num (get-text-property (point) 'cause))) + (cider-stacktrace-cycle-cause num)))) + +(defun cider-stacktrace-cycle-cause-1 () + "Cycle the visibility of exception cause #1." + (interactive) + (cider-stacktrace-cycle-cause 1)) + +(defun cider-stacktrace-cycle-cause-2 () + "Cycle the visibility of exception cause #2." + (interactive) + (cider-stacktrace-cycle-cause 2)) + +(defun cider-stacktrace-cycle-cause-3 () + "Cycle the visibility of exception cause #3." + (interactive) + (cider-stacktrace-cycle-cause 3)) + +(defun cider-stacktrace-cycle-cause-4 () + "Cycle the visibility of exception cause #4." + (interactive) + (cider-stacktrace-cycle-cause 4)) + +(defun cider-stacktrace-cycle-cause-5 () + "Cycle the visibility of exception cause #5." + (interactive) + (cider-stacktrace-cycle-cause 5)) + + +(defun cider-stacktrace-toggle-all () + "Reset `cider-stacktrace-filters' if present; otherwise restore prior filters." + (interactive) + (when cider-stacktrace-filters + (setq-local cider-stacktrace-prior-filters + cider-stacktrace-filters)) + (cider-stacktrace-apply-filters + (setq cider-stacktrace-filters + (unless cider-stacktrace-filters ; when current filters are nil, + cider-stacktrace-prior-filters)))) ; reenable prior filter set + +(defun cider-stacktrace-toggle (flag) + "Update `cider-stacktrace-filters' to add or remove FLAG, and apply filters." + (cider-stacktrace-apply-filters + (setq cider-stacktrace-filters + (if (memq flag cider-stacktrace-filters) + (remq flag cider-stacktrace-filters) + (cons flag cider-stacktrace-filters))))) + +(defun cider-stacktrace-toggle-java () + "Toggle display of Java stack frames." + (interactive) + (cider-stacktrace-toggle 'java)) + +(defun cider-stacktrace-toggle-clj () + "Toggle display of Clojure stack frames." + (interactive) + (cider-stacktrace-toggle 'clj)) + +(defun cider-stacktrace-toggle-repl () + "Toggle display of REPL stack frames." + (interactive) + (cider-stacktrace-toggle 'repl)) + +(defun cider-stacktrace-toggle-tooling () + "Toggle display of Tooling stack frames (compiler, nREPL middleware, etc)." + (interactive) + (cider-stacktrace-toggle 'tooling)) + +(defun cider-stacktrace-toggle-duplicates () + "Toggle display of stack frames that are duplicates of their descendents." + (interactive) + (cider-stacktrace-toggle 'dup)) + +;; Text button functions + +(defun cider-stacktrace-filter (button) + "Apply filter(s) indicated by the BUTTON." + (with-temp-message "Filters may also be toggled with the keyboard." + (let ((flag (button-get button 'filter))) + (if flag + (cider-stacktrace-toggle flag) + (cider-stacktrace-toggle-all))) + (sit-for 5))) + +(defun cider-stacktrace-toggle-suppression (button) + "Toggle stacktrace pop-over/pop-under behavior for the `error-type' in BUTTON. +Achieved by destructively manipulating the `cider-stacktrace-suppressed-errors' set." + (with-current-buffer cider-error-buffer + (let ((inhibit-read-only t) + (suppressed (button-get button 'suppressed)) + (error-type (button-get button 'error-type))) + (if suppressed + (progn + (cider-stacktrace-promote-error error-type) + (button-put button 'face 'cider-stacktrace-promoted-button-face) + (button-put button 'help-echo "Click to suppress these stacktraces.")) + (cider-stacktrace-suppress-error error-type) + (button-put button 'face 'cider-stacktrace-suppressed-button-face) + (button-put button 'help-echo "Click to promote these stacktraces.")) + (button-put button 'suppressed (not suppressed))))) + +(defun cider-stacktrace-navigate (button) + "Navigate to the stack frame source represented by the BUTTON." + (let* ((var (button-get button 'var)) + (class (button-get button 'class)) + (method (button-get button 'method)) + (info (or (and var (cider-var-info var)) + (and class method (cider-member-info class method)) + (nrepl-dict))) + ;; Stacktrace returns more accurate line numbers, but if the function's + ;; line was unreliable, then so is the stacktrace by the same amount. + ;; Set `line-shift' to the number of lines from the beginning of defn. + (line-shift (- (or (button-get button 'line) 0) + (or (nrepl-dict-get info "line") 1))) + ;; give priority to `info` files as `info` returns full paths. + (info (nrepl-dict-put info "file" (or (nrepl-dict-get info "file") + (button-get button 'file))))) + (cider--jump-to-loc-from-info info t) + (forward-line line-shift) + (back-to-indentation))) + +(defun cider-stacktrace-jump (&optional arg) + "Find definition for stack frame at point, if available. +The prefix ARG and `cider-prompt-for-symbol' decide whether to +prompt and whether to use a new window. Similar to `cider-find-var'." + (interactive "P") + (let ((button (button-at (point)))) + (if (and button (button-get button 'line)) + (cider-stacktrace-navigate button) + (cider-find-var arg)))) + + +;; Rendering + +(defun cider-stacktrace-emit-indented (text indent &optional fill) + "Insert TEXT, and INDENT and optionally FILL the entire block." + (let ((beg (point))) + (insert text) + (goto-char beg) + (while (not (eobp)) + (insert indent) + (forward-line)) + (when (and fill cider-stacktrace-fill-column) + (when (and (numberp cider-stacktrace-fill-column)) + (setq-local fill-column cider-stacktrace-fill-column)) + (setq-local fill-prefix indent) + (fill-region beg (point))))) + +(defun cider-stacktrace-render-filters (buffer filters) + "Emit into BUFFER toggle buttons for each of the FILTERS." + (with-current-buffer buffer + (insert " Show: ") + (dolist (filter filters) + (insert-text-button (car filter) + 'filter (cadr filter) + 'follow-link t + 'action 'cider-stacktrace-filter + 'help-echo (format "Toggle %s stack frames" + (car filter))) + (insert " ")) + (let ((hidden "(0 frames hidden)")) + (put-text-property 0 (length hidden) 'hidden-count t hidden) + (insert " " hidden "\n")))) + +(defun cider-stacktrace-render-suppression-toggle (buffer error-types) + "Emit into BUFFER toggle buttons for each of the ERROR-TYPES leading this stacktrace buffer." + (with-current-buffer buffer + (when error-types + (insert " This is an unexpected CIDER middleware error.\n Please submit a bug report via `") + (insert-text-button "M-x cider-report-bug" + 'follow-link t + 'action (lambda (_button) (cider-report-bug)) + 'help-echo "Report bug to the CIDER team.") + (insert "`.\n\n") + (insert "\ + If these stacktraces are occuring frequently, consider using the + button(s) below to suppress these types of errors for the duration of + your current CIDER session. The stacktrace buffer will still be + generated, but it will \"pop under\" your current buffer instead of + \"popping over\". The button toggles this behavior.\n\n ") + (dolist (error-type error-types) + (let ((suppressed (cider-stacktrace-suppressed-error-p error-type))) + (insert-text-button (format "%s %s" (if suppressed "Promote" "Suppress") error-type) + 'follow-link t + 'error-type error-type + 'action 'cider-stacktrace-toggle-suppression + 'suppressed suppressed + 'face (if suppressed + 'cider-stacktrace-suppressed-button-face + 'cider-stacktrace-promoted-button-face) + 'help-echo (format "Click to %s these stacktraces." + (if suppressed "promote" "suppress")))) + (insert " "))))) + +(defun cider-stacktrace-render-frame (buffer frame) + "Emit into BUFFER function call site info for the stack FRAME. +This associates text properties to enable filtering and source navigation." + (with-current-buffer buffer + (nrepl-dbind-response frame (file line flags class method name var ns fn) + (let ((flags (mapcar 'intern flags))) ; strings -> symbols + (insert-text-button (format "%26s:%5d %s/%s" + (if (member 'repl flags) "REPL" file) line + (if (member 'clj flags) ns class) + (if (member 'clj flags) fn method)) + 'var var 'class class 'method method + 'name name 'file file 'line line + 'flags flags 'follow-link t + 'action 'cider-stacktrace-navigate + 'help-echo "View source at this location" + 'font-lock-face 'cider-stacktrace-face + 'type 'cider-plain-button) + (save-excursion + (let ((p4 (point)) + (p1 (search-backward " ")) + (p2 (search-forward "/")) + (p3 (search-forward-regexp "[^/$]+"))) + (put-text-property p1 p4 'font-lock-face 'cider-stacktrace-ns-face) + (put-text-property p2 p3 'font-lock-face 'cider-stacktrace-fn-face))) + (insert "\n"))))) + +(declare-function cider-jump-to "cider-interaction") + +(defun cider-stacktrace-render-compile-error (buffer cause) + "Emit into BUFFER the compile error CAUSE, and enable jumping to it." + (with-current-buffer buffer + (nrepl-dbind-response cause (file path line column) + (let ((indent " ") + (message-face 'cider-stacktrace-error-message-face)) + (insert indent) + (insert (propertize "Error compiling " 'font-lock-face message-face)) + (insert-text-button path 'compile-error t + 'file file 'line line 'column column 'follow-link t + 'action (lambda (_button) + (cider-jump-to (cider-find-file file) + (cons line column)))) + (insert (propertize (format " at (%d:%d)" line column) + 'font-lock-face message-face)))))) + +(defun cider-stacktrace-render-cause (buffer cause num note) + "Emit into BUFFER the CAUSE NUM, exception class, message, data, and NOTE." + (with-current-buffer buffer + (nrepl-dbind-response cause (class message data stacktrace) + (let ((indent " ") + (class-face 'cider-stacktrace-error-class-face) + (message-face 'cider-stacktrace-error-message-face)) + (cider-propertize-region `(cause ,num) + ;; Detail level 0: exception class + (cider-propertize-region '(detail 0) + (insert (format "%d. " num) + (propertize note 'font-lock-face 'font-lock-comment-face) " " + (propertize class 'font-lock-face class-face) + "\n")) + ;; Detail level 1: message + ex-data + (cider-propertize-region '(detail 1) + (if (equal class "clojure.lang.Compiler$CompilerException") + (cider-stacktrace-render-compile-error buffer cause) + (cider-stacktrace-emit-indented + (propertize (or message "(No message)") + 'font-lock-face message-face) indent t)) + (insert "\n") + (when data + (cider-stacktrace-emit-indented + (cider-font-lock-as-clojure data) indent nil))) + ;; Detail level 2: stacktrace + (cider-propertize-region '(detail 2) + (insert "\n") + (let ((beg (point)) + (bg `(:background ,cider-stacktrace-frames-background-color))) + (dolist (frame stacktrace) + (cider-stacktrace-render-frame buffer frame)) + (overlay-put (make-overlay beg (point)) 'font-lock-face bg))) + ;; Add line break between causes, even when collapsed. + (cider-propertize-region '(detail 0) + (insert "\n"))))))) + +(defun cider-stacktrace-initialize (causes) + "Set and apply CAUSES initial visibility, filters, and cursor position." + (nrepl-dbind-response (car causes) (class) + (let ((compile-error-p (equal class "clojure.lang.Compiler$CompilerException"))) + ;; Partially display outermost cause if it's a compiler exception (the + ;; description reports reader location of the error). + (when compile-error-p + (cider-stacktrace-cycle-cause (length causes) 1)) + ;; Fully display innermost cause. This also applies visibility/filters. + (cider-stacktrace-cycle-cause 1 cider-stacktrace-detail-max) + ;; Move point (DWIM) to the compile error location if present, or to the + ;; first stacktrace frame in displayed cause otherwise. If the error + ;; buffer is visible in a window, ensure that window is selected while moving + ;; point, so as to move both the buffer's and the window's point. + (with-selected-window (or (get-buffer-window cider-error-buffer) + (selected-window)) + (with-current-buffer cider-error-buffer + (goto-char (point-min)) + (if compile-error-p + (goto-char (next-single-property-change (point) 'compile-error)) + (progn + (while (cider-stacktrace-next-cause)) + (goto-char (next-single-property-change (point) 'flags))))))))) + +(defun cider-stacktrace-render (buffer causes &optional error-types) + "Emit into BUFFER useful stacktrace information for the CAUSES. +Takes an optional ERROR-TYPES list which will render a 'suppression' toggle +that alters the pop-over/pop-under behavorior of the stacktrace buffers +created by these types of errors. The suppressed errors set can be customized +through the `cider-stacktrace-suppressed-errors' variable." + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (erase-buffer) + (insert "\n") + ;; Stacktrace filters + (cider-stacktrace-render-filters + buffer + `(("Clojure" clj) ("Java" java) ("REPL" repl) + ("Tooling" tooling) ("Duplicates" dup) ("All" ,nil))) + (insert "\n") + ;; Option to suppress internal/middleware errors + (when error-types + (cider-stacktrace-render-suppression-toggle buffer error-types) + (insert "\n\n")) + ;; Stacktrace exceptions & frames + (let ((num (length causes))) + (dolist (cause causes) + (let ((note (if (= num (length causes)) "Unhandled" "Caused by"))) + (cider-stacktrace-render-cause buffer cause num note) + (setq num (1- num)))))) + (cider-stacktrace-initialize causes) + (font-lock-refresh-defaults))) + +(provide 'cider-stacktrace) + +;;; cider-stacktrace.el ends here diff --git a/elpa/cider-20170129.1941/cider-test.el b/elpa/cider-20170129.1941/cider-test.el new file mode 100644 index 00000000..e5b8570e --- /dev/null +++ b/elpa/cider-20170129.1941/cider-test.el @@ -0,0 +1,729 @@ +;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*- + +;; Copyright © 2014-2017 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 'subr-x) +(require 'cider-compat) +(require 'cider-overlays) + +(require 'button) +(require 'easymenu) +(require 'seq) + +;;; Variables + +(defgroup cider-test nil + "Presentation and navigation for test results." + :prefix "cider-test-" + :group 'cider) + +(defcustom cider-test-show-report-on-success nil + "Whether to show the `*cider-test-report*` buffer on passing tests." + :type 'boolean + :group 'cider-test + :package-version '(cider . "0.8.0")) + +(defcustom cider-auto-select-test-report-buffer t + "Determines if the test-report buffer should be auto-selected." + :type 'boolean + :group 'cider-test + :package-version '(cider . "0.9.0")) + +(defcustom cider-test-defining-forms '("deftest" "defspec") + "Forms that define individual tests. +CIDER considers the top-level form around point to define a test if the +form starts with one of these forms. +Add to this list to have CIDER recognize additional test defining macros." + :type '(repeat string) + :group 'cider-test + :package-version '(cider . "0.15.0")) + +(defvar cider-test-last-summary nil + "The summary of the last run test.") + +(defvar cider-test-last-results nil + "The results of the last run test.") + +(defconst cider-test-report-buffer "*cider-test-report*" + "Buffer name in which to display test reports.") +(add-to-list 'cider-ancillary-buffers cider-test-report-buffer) + + +;;; Faces + +(defface cider-test-failure-face + '((((class color) (background light)) + :background "orange red") + (((class color) (background dark)) + :background "firebrick")) + "Face for failed tests." + :group 'cider-test + :package-version '(cider . "0.7.0")) + +(defface cider-test-error-face + '((((class color) (background light)) + :background "orange1") + (((class color) (background dark)) + :background "orange4")) + "Face for erring tests." + :group 'cider-test + :package-version '(cider . "0.7.0")) + +(defface cider-test-success-face + '((((class color) (background light)) + :foreground "black" + :background "green") + (((class color) (background dark)) + :foreground "black" + :background "green")) + "Face for passing tests." + :group 'cider-test + :package-version '(cider . "0.7.0")) + + +;; Colors & Theme Support + +(defvar cider-test-items-background-color + (cider-scale-background-color) + "Background color for test assertion items.") + +(defadvice enable-theme (after cider-test-adapt-to-theme activate) + "When theme is changed, update `cider-test-items-background-color'." + (setq cider-test-items-background-color (cider-scale-background-color))) + + +;;; Report mode & key bindings +;; The primary mode of interacting with test results is the report buffer, which +;; allows navigation among tests, jumping to test definitions, expected/actual +;; diff-ing, and cause/stacktrace inspection for test errors. + +(defvar cider-test-commands-map + (let ((map (define-prefix-command 'cider-test-commands-map))) + ;; Duplicates of keys below with C- for convenience + (define-key map (kbd "C-r") #'cider-test-rerun-failed-tests) + (define-key map (kbd "C-t") #'cider-test-run-test) + (define-key map (kbd "C-g") #'cider-test-rerun-test) + (define-key map (kbd "C-n") #'cider-test-run-ns-tests) + (define-key map (kbd "C-l") #'cider-test-run-loaded-tests) + (define-key map (kbd "C-p") #'cider-test-run-project-tests) + (define-key map (kbd "C-b") #'cider-test-show-report) + ;; Single-key bindings defined last for display in menu + (define-key map (kbd "r") #'cider-test-rerun-failed-tests) + (define-key map (kbd "t") #'cider-test-run-test) + (define-key map (kbd "g") #'cider-test-rerun-test) + (define-key map (kbd "n") #'cider-test-run-ns-tests) + (define-key map (kbd "l") #'cider-test-run-loaded-tests) + (define-key map (kbd "p") #'cider-test-run-project-tests) + (define-key map (kbd "b") #'cider-test-show-report) + map)) + +(defconst cider-test-menu + '("Test" + ["Run test" cider-test-run-test] + ["Run namespace tests" cider-test-run-ns-tests] + ["Run all loaded tests" cider-test-run-loaded-tests] + ["Run all project tests" cider-test-run-project-tests] + ["Run tests after load-file" cider-auto-test-mode + :style toggle :selected cider-auto-test-mode] + "--" + ["Interrupt running tests" cider-interrupt] + ["Rerun failed/erring tests" cider-test-rerun-failed-tests] + ["Show test report" cider-test-show-report] + "--" + ["Configure testing" (customize-group 'cider-test)]) + "CIDER test submenu.") + +(defvar cider-test-report-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c ,") 'cider-test-commands-map) + (define-key map (kbd "C-c C-t") 'cider-test-commands-map) + (define-key map (kbd "M-p") #'cider-test-previous-result) + (define-key map (kbd "M-n") #'cider-test-next-result) + (define-key map (kbd "M-.") #'cider-test-jump) + (define-key map (kbd "") #'cider-test-previous-result) + (define-key map (kbd "TAB") #'cider-test-next-result) + (define-key map (kbd "RET") #'cider-test-jump) + (define-key map (kbd "t") #'cider-test-jump) + (define-key map (kbd "d") #'cider-test-ediff) + (define-key map (kbd "e") #'cider-test-stacktrace) + ;; `f' for "run failed". + (define-key map "f" #'cider-test-rerun-failed-tests) + (define-key map "n" #'cider-test-run-ns-tests) + (define-key map "l" #'cider-test-run-loaded-tests) + (define-key map "p" #'cider-test-run-project-tests) + ;; `g' generally reloads the buffer. The closest thing we have to that is + ;; "run the test at point". But it's not as nice as rerunning all tests in + ;; this buffer. + (define-key map "g" #'cider-test-run-test) + (define-key map "q" #'cider-popup-buffer-quit-function) + (easy-menu-define cider-test-report-mode-menu map + "Menu for CIDER's test result mode" + '("Test-Report" + ["Previous result" cider-test-previous-result] + ["Next result" cider-test-next-result] + "--" + ["Rerun current test" cider-test-run-test] + ["Rerun failed/erring tests" cider-test-rerun-failed-tests] + ["Run all ns tests" cider-test-run-ns-tests] + ["Run all loaded tests" cider-test-run-loaded-tests] + ["Run all project tests" cider-test-run-project-tests] + "--" + ["Jump to test definition" cider-test-jump] + ["Display test error" cider-test-stacktrace] + ["Display expected/actual diff" cider-test-ediff])) + map)) + +(define-derived-mode cider-test-report-mode fundamental-mode "Test Report" + "Major mode for presenting Clojure test results. + +\\{cider-test-report-mode-map}" + (setq buffer-read-only t) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t)) + (setq-local electric-indent-chars nil)) + +;; Report navigation + +(defun cider-test-show-report () + "Show the test report buffer, if one exists." + (interactive) + (if-let ((report-buffer (get-buffer cider-test-report-buffer))) + (switch-to-buffer report-buffer) + (message "No test report buffer"))) + +(defun cider-test-previous-result () + "Move point to the previous test result, if one exists." + (interactive) + (with-current-buffer (get-buffer cider-test-report-buffer) + (when-let ((pos (previous-single-property-change (point) 'type))) + (if (get-text-property pos 'type) + (goto-char pos) + (when-let ((pos (previous-single-property-change pos 'type))) + (goto-char pos)))))) + +(defun cider-test-next-result () + "Move point to the next test result, if one exists." + (interactive) + (with-current-buffer (get-buffer cider-test-report-buffer) + (when-let ((pos (next-single-property-change (point) 'type))) + (if (get-text-property pos 'type) + (goto-char pos) + (when-let ((pos (next-single-property-change pos 'type))) + (goto-char pos)))))) + +(defun cider-test-jump (&optional arg) + "Find definition for test at point, if available. +The prefix ARG and `cider-prompt-for-symbol' decide whether to +prompt and whether to use a new window. Similar to `cider-find-var'." + (interactive "P") + (let ((ns (get-text-property (point) 'ns)) + (var (get-text-property (point) 'var)) + (line (get-text-property (point) 'line))) + (if (and ns var) + (cider-find-var arg (concat ns "/" var) line) + (cider-find-var arg)))) + +;;; Error stacktraces + +(defvar cider-auto-select-error-buffer) + +(defun cider-test-stacktrace-for (ns var index) + "Display stacktrace for the erring NS VAR test with the assertion INDEX." + (let (causes) + (cider-nrepl-send-request + (append + (list "op" "test-stacktrace" + "ns" ns "var" var "index" index) + (when (cider--pprint-fn) + (list "pprint-fn" (cider--pprint-fn))) + (when cider-stacktrace-print-length + (list "print-length" cider-stacktrace-print-length)) + (when cider-stacktrace-print-level + (list "print-level" cider-stacktrace-print-level))) + (lambda (response) + (nrepl-dbind-response response (class status) + (cond (class (setq causes (cons response causes))) + (status (when causes + (cider-stacktrace-render + (cider-popup-buffer cider-error-buffer + cider-auto-select-error-buffer + #'cider-stacktrace-mode) + (reverse causes)))))))))) + +(defun cider-test-stacktrace () + "Display stacktrace for the erring test at point." + (interactive) + (let ((ns (get-text-property (point) 'ns)) + (var (get-text-property (point) 'var)) + (index (get-text-property (point) 'index)) + (err (get-text-property (point) 'error))) + (if (and err ns var index) + (cider-test-stacktrace-for ns var index) + (message "No test error at point")))) + + +;;; Expected vs actual diffing + +(defvar cider-test-ediff-buffers nil + "The expected/actual buffers used to display diff.") + +(defun cider-test-ediff () + "Show diff of the expected vs actual value for the test at point. +With the actual value, the outermost '(not ...)' s-expression is removed." + (interactive) + (let ((expected (get-text-property (point) 'expected)) + (actual (get-text-property (point) 'actual))) + (if (and expected actual) + (let ((expected-buffer (generate-new-buffer " *expected*")) + (actual-buffer (generate-new-buffer " *actual*"))) + (with-current-buffer expected-buffer + (insert expected) + (clojure-mode)) + (with-current-buffer actual-buffer + (insert actual) + (goto-char (point-min)) + (forward-char) + (forward-sexp) + (forward-whitespace 1) + (let ((beg (point))) + (forward-sexp) + (let ((actual* (buffer-substring beg (point)))) + (erase-buffer) + (insert actual*))) + (clojure-mode)) + (apply 'ediff-buffers + (setq cider-test-ediff-buffers + (list (buffer-name expected-buffer) + (buffer-name actual-buffer))))) + (message "No test failure at point")))) + +(defun cider-test-ediff-cleanup () + "Cleanup expected/actual buffers used for diff." + (interactive) + (mapc (lambda (b) (when (get-buffer b) (kill-buffer b))) + cider-test-ediff-buffers)) + +(add-hook 'ediff-cleanup-hook #'cider-test-ediff-cleanup) + + +;;; Report rendering + +(defun cider-test-type-face (type) + "Return the font lock face for the test result TYPE." + (pcase type + ("pass" 'cider-test-success-face) + ("fail" 'cider-test-failure-face) + ("error" 'cider-test-error-face) + (_ 'default))) + +(defun cider-test-type-simple-face (type) + "Return a face for the test result TYPE using the highlight color as foreground." + (let ((face (cider-test-type-face type))) + `(:foreground ,(face-attribute face :background)))) + +(defun cider-test-render-summary (buffer summary) + "Emit into BUFFER the report SUMMARY statistics." + (with-current-buffer buffer + (nrepl-dbind-response summary (ns var test pass fail error) + (insert (format "Tested %d namespaces\n" ns)) + (insert (format "Ran %d assertions, in %d test functions\n" test var)) + (unless (zerop fail) + (cider-insert (format "%d failures" fail) 'cider-test-failure-face t)) + (unless (zerop error) + (cider-insert (format "%d errors" error) 'cider-test-error-face t)) + (when (zerop (+ fail error)) + (cider-insert (format "%d passed" pass) 'cider-test-success-face t)) + (insert "\n\n")))) + +(defun cider-test-render-assertion (buffer test) + "Emit into BUFFER report detail for the TEST assertion." + (with-current-buffer buffer + (nrepl-dbind-response test (var context type message expected actual error gen-input) + (cider-propertize-region (cider-intern-keys (cdr test)) + (let ((beg (point)) + (type-face (cider-test-type-simple-face type)) + (bg `(:background ,cider-test-items-background-color))) + (cider-insert (capitalize type) type-face nil " in ") + (cider-insert var 'font-lock-function-name-face t) + (when context (cider-insert context 'font-lock-doc-face t)) + (when message (cider-insert message 'font-lock-doc-string-face t)) + (when expected + (cider-insert "expected: " 'font-lock-comment-face nil + (cider-font-lock-as-clojure expected))) + (when actual + (cider-insert " actual: " 'font-lock-comment-face nil + (cider-font-lock-as-clojure actual))) + (when error + (cider-insert " error: " 'font-lock-comment-face nil) + (insert-text-button error + 'follow-link t + 'action '(lambda (_button) (cider-test-stacktrace)) + 'help-echo "View causes and stacktrace") + (insert "\n")) + (when gen-input + (cider-insert " input: " 'font-lock-comment-face nil + (cider-font-lock-as-clojure gen-input))) + (overlay-put (make-overlay beg (point)) 'font-lock-face bg)) + (insert "\n"))))) + +(defun cider-test-non-passing (tests) + "For a list of TESTS, each an nrepl-dict, return only those that did not pass." + (seq-filter (lambda (test) + (unless (equal (nrepl-dict-get test "type") "pass") + test)) + tests)) + +(defun cider-test-render-report (buffer summary results) + "Emit into BUFFER the report for the SUMMARY, and test RESULTS." + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (cider-test-report-mode) + (cider-insert "Test Summary" 'bold t) + (dolist (ns (nrepl-dict-keys results)) + (insert (cider-propertize ns 'ns) "\n")) + (cider-insert "\n") + (cider-test-render-summary buffer summary) + (nrepl-dbind-response summary (fail error) + (unless (zerop (+ fail error)) + (cider-insert "Results" 'bold t "\n") + ;; Results are a nested dict, keyed first by ns, then var. Within each + ;; var is a sequence of test assertion results. + (nrepl-dict-map + (lambda (ns vars) + (nrepl-dict-map + (lambda (_var tests) + (let* ((problems (cider-test-non-passing tests)) + (count (length problems))) + (when (< 0 count) + (insert (format "%s\n%d non-passing tests:\n\n" + (cider-propertize ns 'ns) count)) + (dolist (test problems) + (cider-test-render-assertion buffer test))))) + vars)) + results))) + (goto-char (point-min)) + (current-buffer)))) + + +;;; Message echo + +(defun cider-test-echo-running (ns &optional test) + "Echo a running message for the test NS, which may be a keyword. +The optional arg TEST denotes an individual test name." + (if test + (message "Running test %s in %s..." + (cider-propertize test 'bold) + (cider-propertize ns 'ns)) + (message "Running tests in %s..." + (concat (cider-propertize + (cond ((stringp ns) ns) + ((eq :non-passing ns) "failing") + ((eq :loaded ns) "all loaded") + ((eq :project ns) "all project")) + 'ns) + (unless (stringp ns) " namespaces"))))) + +(defun cider-test-echo-summary (summary results) + "Echo SUMMARY statistics for a test run returning RESULTS." + (nrepl-dbind-response summary (ns test var fail error) + (if (nrepl-dict-empty-p results) + (message (concat (propertize "No assertions (or no tests) were run." 'face 'cider-test-error-face) + "Did you forget to use `is' in your tests?")) + (message (propertize + "%sRan %d assertions, in %d test functions. %d failures, %d errors." + 'face (cond ((not (zerop error)) 'cider-test-error-face) + ((not (zerop fail)) 'cider-test-failure-face) + (t 'cider-test-success-face))) + (concat (if (= 1 ns) ; ns count from summary + (cider-propertize (car (nrepl-dict-keys results)) 'ns) + (propertize (format "%d namespaces" ns) 'face 'default)) + (propertize ": " 'face 'default)) + test var fail error)))) + +;;; Test definition highlighting +;; On receipt of test results, failing/erring test definitions are highlighted. +;; Highlights are cleared on the next report run, and may be cleared manually +;; by the user. + +;; NOTE If keybindings specific to test sources are desired, it would be +;; straightforward to turn this into a `cider-test-mode' minor mode, which we +;; enable on test sources, much like the legacy `clojure-test-mode'. At present, +;; though, there doesn't seem to be much value in this, since the report buffer +;; provides the primary means of interacting with test results. + +(defun cider-test-highlight-problem (buffer test) + "Highlight the BUFFER test definition for the non-passing TEST." + (with-current-buffer buffer + (nrepl-dbind-response test (type file line message expected actual) + ;; we have to watch out for vars without proper location metadata + ;; right now everything evaluated interactively lacks this data + ;; TODO: Figure out what to do when the metadata is missing + (when (and file line (not (cider--tooling-file-p file))) + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (search-forward "(" nil t) + (let ((beg (point))) + (forward-sexp) + (cider--make-overlay beg (point) 'cider-test + 'font-lock-face (cider-test-type-face type) + 'type type + 'help-echo message + 'message message + 'expected expected + 'actual actual))))))) + +(defun cider-find-var-file (ns var) + "Return the buffer visiting the file in which the NS VAR is defined. +Or nil if not found." + (cider-ensure-op-supported "info") + (when-let ((info (cider-var-info (concat ns "/" var))) + (file (nrepl-dict-get info "file"))) + (cider-find-file file))) + +(defun cider-test-highlight-problems (results) + "Highlight all non-passing tests in the test RESULTS." + (nrepl-dict-map + (lambda (ns vars) + (nrepl-dict-map + (lambda (var tests) + (when-let ((buffer (cider-find-var-file ns var))) + (dolist (test tests) + (nrepl-dbind-response test (type) + (unless (equal "pass" type) + (cider-test-highlight-problem buffer test)))))) + vars)) + results)) + +(defun cider-test-clear-highlights () + "Clear highlighting of non-passing tests from the last test run." + (interactive) + (when cider-test-last-results + (nrepl-dict-map + (lambda (ns vars) + (dolist (var (nrepl-dict-keys vars)) + (when-let ((buffer (cider-find-var-file ns var))) + (with-current-buffer buffer + (remove-overlays nil nil 'category 'cider-test))))) + cider-test-last-results))) + + +;;; Test namespaces +;; Test namespace inference exists to enable DWIM test running functions: the +;; same "run-tests" function should be able to be used in a source file, and in +;; its corresponding test namespace. To provide this, we need to map the +;; relationship between those namespaces. + +(defcustom cider-test-infer-test-ns 'cider-test-default-test-ns-fn + "Function to infer the test namespace for NS. +The default implementation uses the simple Leiningen convention of appending +'-test' to the namespace name." + :type 'symbol + :group 'cider-test + :package-version '(cider . "0.7.0")) + +(defun cider-test-default-test-ns-fn (ns) + "For a NS, return the test namespace, which may be the argument itself. +This uses the Leiningen convention of appending '-test' to the namespace name." + (when ns + (let ((suffix "-test")) + ;; string-suffix-p is only available in Emacs 24.4+ + (if (string-match-p (rx-to-string `(: ,suffix eos) t) ns) + ns + (concat ns suffix))))) + + +;;; Test execution + +(declare-function cider-emit-interactive-eval-output "cider-interaction") +(declare-function cider-emit-interactive-eval-err-output "cider-interaction") + +(defun cider-test-execute (ns &optional tests silent) + "Run tests for NS, which may be a keyword, optionally specifying TESTS. + +This tests a single NS, or multiple namespaces when using keywords `:project', +`:loaded' or `:non-passing'. Optional TESTS are only honored when a single +namespace is specified. Upon test completion, results are echoed and a test +report is optionally displayed. When test failures/errors occur, their sources +are highlighted. +If SILENT is non-nil, suppress all messages other then test results." + (cider-test-clear-highlights) + (cider-map-connections + (lambda (conn) + (unless silent + (if (and tests (= (length tests) 1)) + ;; we generate a different message when running individual tests + (cider-test-echo-running ns (car tests)) + (cider-test-echo-running ns))) + (cider-nrepl-send-request + (list "op" (cond ((stringp ns) "test") + ((eq :project ns) "test-all") + ((eq :loaded ns) "test-all") + ((eq :non-passing ns) "retest")) + "ns" (when (stringp ns) ns) + "tests" (when (stringp ns) tests) + "load?" (when (or (stringp ns) + (eq :project ns)) + "true")) + (lambda (response) + (nrepl-dbind-response response (summary results status out err) + (cond ((member "namespace-not-found" status) + (unless silent + (message "No test namespace: %s" (cider-propertize ns 'ns)))) + (out (cider-emit-interactive-eval-output out)) + (err (cider-emit-interactive-eval-err-output err)) + (results + (nrepl-dbind-response summary (error fail) + (setq cider-test-last-summary summary) + (setq cider-test-last-results results) + (cider-test-highlight-problems results) + (cider-test-echo-summary summary results) + (if (or (not (zerop (+ error fail))) + cider-test-show-report-on-success) + (cider-test-render-report + (cider-popup-buffer cider-test-report-buffer + cider-auto-select-test-report-buffer) + summary results) + (when (get-buffer cider-test-report-buffer) + (with-current-buffer cider-test-report-buffer + (let ((inhibit-read-only t)) + (erase-buffer))) + (cider-test-render-report + cider-test-report-buffer + summary results)))))))) + conn)) + :clj)) + +(defun cider-test-rerun-failed-tests () + "Rerun failed and erring tests from the last test run." + (interactive) + (if cider-test-last-summary + (nrepl-dbind-response cider-test-last-summary (fail error) + (if (not (zerop (+ error fail))) + (cider-test-execute :non-passing) + (message "No prior failures to retest"))) + (message "No prior results to retest"))) + +(defun cider-test-run-loaded-tests () + "Run all tests defined in currently loaded namespaces." + (interactive) + (cider-test-execute :loaded)) + +(defun cider-test-run-project-tests () + "Run all tests defined in all project namespaces, loading these as needed." + (interactive) + (cider-test-execute :project)) + +(defun cider-test-run-ns-tests (suppress-inference &optional silent) + "Run all tests for the current Clojure namespace context. + +If SILENT is non-nil, suppress all messages other then test results. +With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the +current ns." + (interactive "P") + (if-let ((ns (if suppress-inference + (cider-current-ns t) + (funcall cider-test-infer-test-ns (cider-current-ns t))))) + (cider-test-execute ns nil silent) + (if (eq major-mode 'cider-test-report-mode) + (when (y-or-n-p (concat "Test report does not define a namespace. " + "Rerun failed/erring tests?")) + (cider-test-rerun-failed-tests)) + (unless silent + (message "No namespace to test in current context"))))) + +(defvar cider-test-last-test-ns nil + "The ns of the last test ran with `cider-test-run-test'.") +(defvar cider-test-last-test-var nil + "The var of the last test ran with `cider-test-run-test'.") + +(defun cider-test-update-last-test (ns var) + "Update the last test by setting NS and VAR. + +See `cider-test-rerun-test'." + (setq cider-test-last-test-ns ns + cider-test-last-test-var var)) + +(defun cider-test-run-test () + "Run the test at point. +The test ns/var exist as text properties on report items and on highlighted +failed/erred test definitions. When not found, a test definition at point +is searched." + (interactive) + (let ((ns (get-text-property (point) 'ns)) + (var (get-text-property (point) 'var))) + (if (and ns var) + (progn + (cider-test-update-last-test ns var) + (cider-test-execute ns (list var))) + (let ((ns (clojure-find-ns)) + (def (clojure-find-def))) + (if (and ns (member (car def) cider-test-defining-forms)) + (progn + (cider-test-update-last-test ns (cdr def)) + (cider-test-execute ns (cdr def))) + (message "No test at point")))))) + +(defun cider-test-rerun-test () + "Re-run the test that was previously ran." + (interactive) + (if (and cider-test-last-test-ns cider-test-last-test-var) + (cider-test-execute cider-test-last-test-ns cider-test-last-test-var) + (user-error "No test to re-run"))) + +;;; Auto-test mode +(defun cider--test-silently () + "Like `cider-test-run-tests', but with less feedback. +Only notify the user if there actually were any tests to run and only after +the results are received." + (when (cider-connected-p) + (let ((cider-auto-select-test-report-buffer nil) + (cider-test-show-report-on-success nil)) + (cider-test-run-ns-tests nil 'soft)))) + +;;;###autoload +(define-minor-mode cider-auto-test-mode + "Toggle automatic testing of Clojure files. + +When enabled this reruns tests every time a Clojure file is loaded. +Only runs tests corresponding to the loaded file's namespace and does +nothing if no tests are defined or if the file failed to load." + nil (cider-mode " Test") nil + :global t + (if cider-auto-test-mode + (add-hook 'cider-file-loaded-hook #'cider--test-silently) + (remove-hook 'cider-file-loaded-hook #'cider--test-silently))) + +(provide 'cider-test) + +;;; cider-test.el ends here diff --git a/elpa/cider-20170129.1941/cider-util.el b/elpa/cider-20170129.1941/cider-util.el new file mode 100644 index 00000000..2c3eafb0 --- /dev/null +++ b/elpa/cider-20170129.1941/cider-util.el @@ -0,0 +1,677 @@ +;;; cider-util.el --- Common utility functions that don't belong anywhere else -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; 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 'subr-x) +(require 'cider-compat) +(require 'nrepl-dict) + +(defalias 'cider-pop-back 'pop-tag-mark) + +(defcustom cider-font-lock-max-length 10000 + "The max length of strings to fontify in `cider-font-lock-as'. + +Setting this to nil removes the fontification restriction." + :group 'cider + :type 'boolean + :package-version '(cider . "0.10.0")) + +(defun cider-util--hash-keys (hashtable) + "Return a list of keys in HASHTABLE." + (let ((keys '())) + (maphash (lambda (k _v) (setq keys (cons k keys))) hashtable) + keys)) + +(defun cider-util--clojure-buffers () + "Return a list of all existing `clojure-mode' buffers." + (seq-filter + (lambda (buffer) (with-current-buffer buffer (derived-mode-p 'clojure-mode))) + (buffer-list))) + +(defun cider-current-dir () + "Return the directory of the current buffer." + (if buffer-file-name + (file-name-directory buffer-file-name) + default-directory)) + +(defun cider-in-string-p () + "Return true if point is in a string." + (let ((beg (save-excursion (beginning-of-defun) (point)))) + (nth 3 (parse-partial-sexp beg (point))))) + +(defun cider-in-comment-p () + "Return true if point is in a comment." + (let ((beg (save-excursion (beginning-of-defun) (point)))) + (nth 4 (parse-partial-sexp beg (point))))) + +(defun cider--tooling-file-p (file-name) + "Return t if FILE-NAME is not a 'real' source file. +Currently, only check if the relative file name starts with 'form-init' +which nREPL uses for temporary evaluation file names." + (let ((fname (file-name-nondirectory file-name))) + (string-match-p "^form-init" fname))) + +(defun cider--cljc-or-cljx-buffer-p (&optional buffer) + "Return true if the current buffer is visiting a cljc or cljx file. + +If BUFFER is provided act on that buffer instead." + (with-current-buffer (or buffer (current-buffer)) + (or (derived-mode-p 'clojurec-mode) (derived-mode-p 'clojurex-mode)))) + + +;;; 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-join-into-alist (candidates &optional separator) + "Make an alist from CANDIDATES. +The keys are the elements joined with SEPARATOR and values are the original +elements. Useful for `completing-read' when candidates are complex +objects." + (mapcar (lambda (el) + (if (listp el) + (cons (string-join el (or separator ":")) el) + (cons el el))) + candidates)) + +(defun cider-add-to-alist (symbol car cadr) + "Add '(CAR CADR) to the alist stored in SYMBOL. +If CAR already corresponds to an entry in the alist, destructively replace +the entry's second element with CADR. + +This can be used, for instance, to update the version of an injected +plugin or dependency with: + (cider-add-to-alist 'cider-jack-in-lein-plugins + \"plugin/artifact-name\" \"THE-NEW-VERSION\")" + (let ((alist (symbol-value symbol))) + (if-let ((cons (assoc car alist))) + (setcdr cons (list cadr)) + (set symbol (cons (list car cadr) alist))))) + +(defun cider-namespace-qualified-p (sym) + "Return t if SYM is namespace-qualified." + (string-match-p "[^/]+/" sym)) + +(defvar cider-version) + +(defconst cider-manual-url "http://cider.readthedocs.org/en/%s/" + "The URL to CIDER's manual.") + +(defun cider--manual-version () + "Convert the version to a ReadTheDocs-friendly version." + (if (string-match-p "-snapshot" cider-version) + "latest" + "stable")) + +(defun cider-manual-url () + "The CIDER manual's url." + (format cider-manual-url (cider--manual-version))) + +;;;###autoload +(defun cider-view-manual () + "View the manual in your default browser." + (interactive) + (browse-url (cider-manual-url))) + +(defun cider--manual-button (label section-id) + "Return a button string that links to the online manual. +LABEL is the displayed string, and SECTION-ID is where it points +to." + (with-temp-buffer + (insert-text-button + label + 'follow-link t + 'action (lambda (&rest _) (interactive) + (browse-url (concat (cider-manual-url) + section-id)))) + (buffer-string))) + +(defconst cider-refcard-url "https://github.com/clojure-emacs/cider/raw/%s/doc/cider-refcard.pdf" + "The URL to CIDER's refcard.") + +(defun cider--github-version () + "Convert the version to a GitHub-friendly version." + (if (string-match-p "-snapshot" cider-version) + "master" + (concat "v" cider-version))) + +(defun cider-refcard-url () + "The CIDER manual's url." + (format cider-refcard-url (cider--github-version))) + +(defun cider-view-refcard () + "View the refcard in your default browser." + (interactive) + (browse-url (cider-refcard-url))) + +(defconst cider-report-bug-url "https://github.com/clojure-emacs/cider/issues/new" + "The URL to report a CIDER issue.") + +(defun cider-report-bug () + "Report a bug in your default browser." + (interactive) + (browse-url cider-report-bug-url)) + +(defun cider--project-name (dir) + "Extracts a project name from DIR, possibly nil. +The project name is the final component of DIR if not nil." + (when dir + (file-name-nondirectory (directory-file-name dir)))) + +;;; Vectors +(defun cider--deep-vector-to-list (x) + "Convert vectors in X to lists. +If X is a sequence, return a list of `cider--deep-vector-to-list' applied to +each of its elements. +Any other value is just returned." + (if (sequencep x) + (mapcar #'cider--deep-vector-to-list x) + x)) + + +;;; Help mode + +;; Same as https://github.com/emacs-mirror/emacs/blob/86d083438dba60dc00e9e96414bf7e832720c05a/lisp/help-mode.el#L355 +;; the original function uses some buffer local variables, but the buffer used +;; is not configurable. It defaults to (help-buffer) + +(defun cider--help-setup-xref (item interactive-p buffer) + "Invoked from commands using the \"*Help*\" buffer to install some xref info. + +ITEM is a (FUNCTION . ARGS) pair appropriate for recreating the help +buffer after following a reference. INTERACTIVE-P is non-nil if the +calling command was invoked interactively. In this case the stack of +items for help buffer \"back\" buttons is cleared. Use BUFFER for the +buffer local variables. + +This should be called very early, before the output buffer is cleared, +because we want to record the \"previous\" position of point so we can +restore it properly when going back." + (with-current-buffer buffer + (when help-xref-stack-item + (push (cons (point) help-xref-stack-item) help-xref-stack) + (setq help-xref-forward-stack nil)) + (when interactive-p + (let ((tail (nthcdr 10 help-xref-stack))) + ;; Truncate the stack. + (if tail (setcdr tail nil)))) + (setq help-xref-stack-item item))) + +(defcustom cider-doc-xref-regexp "`\\(.*?\\)`" + "The regexp used to search Clojure vars in doc buffers." + :type 'regexp + :safe #'stringp + :group 'cider + :package-version '(cider . "0.13.0")) + +(defun cider--find-symbol-xref () + "Parse and return the first clojure symbol in current-buffer. +Use `cider-doc-xref-regexp' for the search. Set match data and return a +string of the Clojure symbol. Return nil if there are no more matches in +the buffer." + (when (re-search-forward cider-doc-xref-regexp nil t) + (match-string 1))) + +(declare-function cider-doc-lookup "cider-doc") +(declare-function cider--eldoc-remove-dot "cider-eldoc") + +;; Similar to https://github.com/emacs-mirror/emacs/blob/65c8c7cb96c14f9c6accd03cc8851b5a3459049e/lisp/help-mode.el#L404 +(defun cider--doc-make-xrefs () + "Parse and hyperlink documentation cross-references in current-buffer. +Find cross-reference information in a buffer and activate such cross +references for selection with `help-xref'. Cross-references are parsed +using `cider--find-symbol-xref'. + +Special references `back' and `forward' are made to go back and forth +through a stack of help buffers. Variables `help-back-label' and +`help-forward-label' specify the text for that." + (interactive "b") + + ;; parse the docstring and create xrefs for symbols + (save-excursion + (goto-char (point-min)) + (let ((symbol)) + (while (setq symbol (cider--find-symbol-xref)) + (replace-match "") + (insert-text-button symbol + 'type 'help-xref + 'help-function (apply-partially #'cider-doc-lookup + (cider--eldoc-remove-dot symbol)))))) + + ;; create back and forward buttons if appropiate + (insert "\n") + (when (or help-xref-stack help-xref-forward-stack) + (insert "\n")) + ;; Make a back-reference in this buffer if appropriate. + (when help-xref-stack + (help-insert-xref-button help-back-label 'help-back + (current-buffer))) + ;; Make a forward-reference in this buffer if appropriate. + (when help-xref-forward-stack + (when help-xref-stack + (insert "\t")) + (help-insert-xref-button help-forward-label 'help-forward + (current-buffer))) + (when (or help-xref-stack help-xref-forward-stack) + (insert "\n"))) + + +;;; Words of inspiration +(defun cider-user-first-name () + "Find the current user's first name." + (let ((name (if (string= (user-full-name) "") + (user-login-name) + (user-full-name)))) + (string-match "^[^ ]*" name) + (capitalize (match-string 0 name)))) + +(defvar cider-words-of-inspiration + `("The best way to predict the future is to invent it. -Alan Kay" + "A point of view is worth 80 IQ points. -Alan Kay" + "Lisp isn't a language, it's a building material. -Alan Kay" + "Simple things should be simple, complex things should be possible. -Alan Kay" + "Everything should be as simple as possible, but not simpler. -Albert Einstein" + "Measuring programming progress by lines of code is like measuring aircraft building progress by weight. -Bill Gates" + "Controlling complexity is the essence of computer programming. -Brian Kernighan" + "The unavoidable price of reliability is simplicity. -C.A.R. Hoare" + "You're bound to be unhappy if you optimize everything. -Donald Knuth" + "Simplicity is prerequisite for reliability. -Edsger W. Dijkstra" + "Elegance is not a dispensable luxury but a quality that decides between success and failure. -Edsger W. Dijkstra" + "Deleted code is debugged code. -Jeff Sickel" + "The key to performance is elegance, not battalions of special cases. -Jon Bentley and Doug McIlroy" + "First, solve the problem. Then, write the code. -John Johnson" + "Simplicity is the ultimate sophistication. -Leonardo da Vinci" + "Programming is not about typing... it's about thinking. -Rich Hickey" + "Design is about pulling things apart. -Rich Hickey" + "Programmers know the benefits of everything and the tradeoffs of nothing. -Rich Hickey" + "Code never lies, comments sometimes do. -Ron Jeffries" + "The true delight is in the finding out rather than in the knowing. -Isaac Asimov" + "If paredit is not for you, then you need to become the sort of person that paredit is for. -Phil Hagelberg" + "Express Yourself. -Madonna" + "Put on your red shoes and dance the blues. -David Bowie" + "Do. Or do not. There is no try. -Yoda" + "The enjoyment of one's tools is an essential ingredient of successful work. -Donald E. Knuth" + "Not all those who wander are lost. -J.R.R. Tolkien" + "The best way to learn is to do. -P.R. Halmos" + "If you wish to make an apple pie from scratch, you must first invent the universe. -Carl Sagan" + "Learn the rules like a pro, so you can break them like an artist. -Pablo Picasso" + "The only way of discovering the limits of the possible is to venture a little way past them into the impossible. -Arthur C. Clarke" + "Don't wish it were easier. Wish you were better. -Jim Rohn" + "One chord is fine. Two chords is pushing it. Three chords and you're into jazz. -Lou Reed" + "We are all apprentices in a craft where no one ever becomes a master. -Ernest Hemingway" + "Clojure isn't a language, it's a building material." + "Think big!" + "Think bold!" + "Think fun!" + "Code big!" + "Code bold!" + "Code fun!" + "Take this REPL, fellow hacker, and may it serve you well." + "Let the hacking commence!" + "Hacks and glory await!" + "Hack and be merry!" + "Your hacking starts... NOW!" + "May the Source be with you!" + "May the Source shine upon thy REPL!" + "Code long and prosper!" + "Happy hacking!" + "nREPL server is up, CIDER REPL is online!" + "CIDER REPL operational!" + "Your imagination is the only limit to what you can do with this REPL!" + "This REPL is yours to command!" + "Fame is but a hack away!" + "The REPL is not enough, but it is such a perfect place to start..." + "Keep on codin' in the free world!" + "What we do in the REPL echoes in eternity!" + "Evaluating is believing." + "To infinity... and beyond." + "Showtime!" + "Unfortunately, no one can be told what CIDER is. You have to figure this out yourself." + "Procure a bottle of cider to achieve optimum programming results." + "In parentheses we trust!" + "Write you some Clojure for Great Good!" + "Oh, what a day... what a lovely day!" + "What a day! What cannot be accomplished on such a splendid day!" + "Home is where your REPL is." + ,(format "%s, I've a feeling we're not in Kansas anymore." + (cider-user-first-name)) + ,(format "%s, this could be the start of a beautiful program." + (cider-user-first-name))) + "Scientifically-proven optimal words of hackerish encouragement.") + +(defun cider-random-words-of-inspiration () + "Select a random entry from `cider-words-of-inspiration'." + (eval (nth (random (length cider-words-of-inspiration)) + cider-words-of-inspiration))) + +(defvar cider-tips + '("Press <\\[cider-connect]> to connect to a running nREPL server." + "Press <\\[cider-quit]> to quit the current connection." + "Press <\\[cider-view-manual]> to view CIDER's manual." + "Press <\\[cider-view-refcard]> to view CIDER's refcard." + "Press <\\[describe-mode]> to see a list of the keybindings available (this will work in every Emacs buffer)." + "Press <\\[cider-repl-handle-shortcut]> to quickly invoke some REPL command." + "Press <\\[cider-switch-to-last-clojure-buffer]> to switch between the REPL and a Clojure source buffer." + "Press <\\[cider-find-var]> to jump to the source of something (e.g. a var, a Java method)." + "Press <\\[cider-doc]> to view the documentation for something (e.g. a var, a Java method)." + "Press <\\[cider-find-resource]> to find a resource on the classpath." + "Press <\\[cider-selector]> to quickly select a CIDER buffer." + "Press <\\[cider-test-run-ns-tests]> to run the tests for the current namespace." + "Press <\\[cider-test-run-loaded-tests]> to run all loaded tests." + "Press <\\[cider-test-run-project-tests]> to run all tests for the current project." + "Press <\\[cider-apropos]> to look for a symbol by some search string." + "Press <\\[cider-apropos-documentation]> to look for a symbol that has some string in its docstring." + "Press <\\[cider-eval-defun-at-point]> to eval the top-level form at point." + "Press <\\[cider-eval-buffer]> to eval the entire source buffer." + "Press <\\[cider-scratch]> to create a Clojure scratchpad. Pretty handy for prototyping." + "Press <\\[cider-read-and-eval]> to evaluate some Clojure expression directly in the minibuffer." + "Press <\\[cider-drink-a-sip]> to get more CIDER tips." + "Press <\\[cider-browse-ns-all]> to start CIDER's namespace browser." + "Press <\\[cider-classpath]> to start CIDER's classpath browser." + "Press <\\[cider-repl-history]> to start CIDER's REPL input history browser." + "Press <\\[cider-macroexpand-1]> to expand the preceding macro." + "Press <\\[cider-inspect]> to inspect the preceding expression's result." + "Press 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) + ;; we have to adjust the column number by 1 to account for the fact + ;; that Emacs starts counting columns from 0 and Clojure from 1 + (1+ (current-column)))) + +(defun cider-propertize (text kind) + "Propertize TEXT as KIND. +KIND can be the symbols `ns', `var', `emph', `fn', or a face name." + (propertize text 'face (pcase kind + (`fn 'font-lock-function-name-face) + (`var 'font-lock-variable-name-face) + (`ns 'font-lock-type-face) + (`emph 'font-lock-keyword-face) + (face face)))) + +(defun cider--menu-add-help-strings (menu-list) + "Add a :help entries to items in MENU-LIST." + (mapcar (lambda (x) + (cond + ((listp x) (cider--menu-add-help-strings x)) + ((and (vectorp x) + (not (plist-get (append x nil) :help)) + (functionp (elt x 1))) + (vconcat x `[:help ,(documentation (elt x 1))])) + (t x))) + menu-list)) + +(provide 'cider-util) + +;;; cider-util.el ends here diff --git a/elpa/cider-20170129.1941/cider.el b/elpa/cider-20170129.1941/cider.el new file mode 100644 index 00000000..c46e02a1 --- /dev/null +++ b/elpa/cider-20170129.1941/cider.el @@ -0,0 +1,885 @@ +;;; cider.el --- Clojure Interactive Development Environment that Rocks -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; Phil Hagelberg +;; Bozhidar Batsov +;; Artur Malabarba +;; Hugo Duncan +;; Steve Purcell +;; Maintainer: Bozhidar Batsov +;; URL: http://www.github.com/clojure-emacs/cider +;; Version: 0.15.0-snapshot +;; Package-Requires: ((emacs "24.4") (clojure-mode "5.6.0") (pkg-info "0.4") (queue "0.1.1") (spinner "1.7") (seq "2.16")) +;; Keywords: languages, clojure, cider + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Provides a Clojure interactive development environment for Emacs, built on +;; top of nREPL. + +;;; Installation: + +;; Available as a package in melpa.org and stable.melpa.org + +;; (add-to-list 'package-archives +;; '("melpa" . "https://melpa.org/packages/")) +;; +;; or +;; +;; (add-to-list 'package-archives +;; '("melpa-stable" . "https://stable.melpa.org/packages/") t) +;; +;; M-x package-install cider + +;;; Usage: + +;; M-x cider-jack-in + +;;; Code: + +(defgroup cider nil + "Clojure Interactive Development Environment that Rocks." + :prefix "cider-" + :group 'applications + :link '(url-link :tag "GitHub" "https://github.com/clojure-emacs/cider") + :link '(url-link :tag "Online Manual" "https://cider.readthedocs.org") + :link '(emacs-commentary-link :tag "Commentary" "cider")) + +(defcustom cider-prompt-for-project-on-connect 'when-needed + "Controls whether to prompt for associated project on `cider-connect'. + +When set to when-needed, the project will be derived from the buffer you're +visiting, when invoking `cider-connect'. +When set to t, you'll always to prompted to select the matching project. +When set to nil, you'll never be prompted to select a project and no +project inference will take place." + :type '(choice (const :tag "always" t) + (const when-needed) + (const :tag "never" nil)) + :group 'cider + :package-version '(cider . "0.10.0")) + +(require 'cider-client) +(require 'cider-eldoc) +(require 'cider-repl) +(require 'cider-mode) +(require 'cider-common) +(require 'subr-x) +(require 'cider-compat) +(require 'cider-debug) +(require 'tramp-sh) +(require 'cider-repl-history) + +(require 'seq) + +(defconst cider-version "0.15.0-snapshot" + "Fallback version used when it cannot be extracted automatically. +Normally it won't be used, unless `pkg-info' fails to extract the +version from the CIDER package or library.") + +(defconst cider-codename "London" + "Codename used to denote stable releases.") + +(defcustom cider-lein-command + "lein" + "The command used to execute Leiningen." + :type 'string + :group 'cider) + +(defcustom cider-lein-global-options + nil + "Command global options used to execute Leiningen (e.g.: -o for offline)." + :type 'string + :group 'cider) + +(defcustom cider-lein-parameters + "repl :headless" + "Params passed to Leiningen to start an nREPL server via `cider-jack-in'." + :type 'string + :group 'cider) + +(defcustom cider-boot-command + "boot" + "The command used to execute Boot." + :type 'string + :group 'cider + :package-version '(cider . "0.9.0")) + +(defcustom cider-boot-global-options + nil + "Command global options used to execute Boot (e.g.: -c for checkouts)." + :type 'string + :group 'cider + :package-version '(cider . "0.14.0")) + +(defcustom cider-boot-parameters + "repl -s wait" + "Params passed to boot to start an nREPL server via `cider-jack-in'." + :type 'string + :group 'cider + :package-version '(cider . "0.9.0")) + +(defcustom cider-gradle-command + "gradle" + "The command used to execute Gradle." + :type 'string + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-gradle-global-options + "--no-daemon" + "Command line options used to execute Gradle (e.g.: -m for dry run)." + :type 'string + :group 'cider + :package-version '(cider . "0.14.0")) + +(defcustom cider-gradle-parameters + "clojureRepl" + "Params passed to gradle to start an nREPL server via `cider-jack-in'." + :type 'string + :group 'cider + :package-version '(cider . "0.10.0")) + +(defcustom cider-default-repl-command + "lein" + "The default command and parameters to use when connecting to nREPL. +This value will only be consulted when no identifying file types, i.e. +project.clj for leiningen or build.boot for boot, could be found." + :type 'string + :group 'cider + :package-version '(cider . "0.9.0")) + +(defcustom cider-preferred-build-tool + nil + "Allow choosing a build system when there are many. +When there are artifacts from multiple build systems (\"lein\", \"boot\", +\"gradle\") the user is prompted to select one of them. When non-nil, this +variable will suppress this behavior and will select whatever build system +is indicated by the variable if present. Note, this is only when CIDER +cannot decide which of many build systems to use and will never override a +command when there is no ambiguity." + :type '(choice (const "lein") + (const "boot") + (const "gradle") + (const :tag "Always ask" nil)) + :group 'cider + :package-version '(cider . "0.13.0")) + +(defcustom cider-allow-jack-in-without-project 'warn + "Controls what happens when doing `cider-jack-in' outside a project. +When set to 'warn you'd prompted to confirm the command. +When set to t `cider-jack-in' will quietly continue. +When set to nil `cider-jack-in' will fail." + :type '(choice (const :tag "always" t) + (const 'warn) + (const :tag "never" nil)) + :group 'cider + :package-version '(cider . "0.15.0")) + +(defcustom cider-known-endpoints nil + "A list of connection endpoints where each endpoint is a list. +For example: \\='((\"label\" \"host\" \"port\")). +The label is optional so that \\='(\"host\" \"port\") will suffice. +This variable is used by `cider-connect'." + :type '(repeat (list (string :tag "label") + (string :tag "host") + (string :tag "port"))) + :group 'cider) + +(defcustom cider-connected-hook nil + "List of functions to call when connected to Clojure nREPL server." + :type 'hook + :group 'cider + :package-version '(cider . "0.9.0")) + +(defcustom cider-disconnected-hook nil + "List of functions to call when disconnected from the Clojure nREPL server." + :type 'hook + :group 'cider + :package-version '(cider . "0.9.0")) + +(defcustom cider-auto-mode t + "When non-nil, automatically enable `cider-mode' for all Clojure buffers." + :type 'boolean + :package-version '(cider . "0.9.0")) + +(defcustom cider-inject-dependencies-at-jack-in t + "When nil, do not inject repl dependencies (most likely nREPL middlewares) at `cider-jack-in' time." + :type 'boolean + :version '(cider . "0.11.0")) + +(defvar cider-ps-running-nrepls-command "ps u | grep leiningen" + "Process snapshot command used in `cider-locate-running-nrepl-ports'.") + +(defvar cider-ps-running-nrepl-path-regexp-list + '("\\(?:leiningen.original.pwd=\\)\\(.+?\\) -D" + "\\(?:-classpath +:?\\(.+?\\)/self-installs\\)") + "Regexp list to get project paths. +Extract project paths from output of `cider-ps-running-nrepls-command'. +Sub-match 1 must be the project path.") + +(defvar cider-host-history nil + "Completion history for connection hosts.") + +;;;###autoload +(defun cider-version () + "Display CIDER's version." + (interactive) + (message "CIDER %s" (cider--version))) + +(defun cider-jack-in-command (project-type) + "Determine the command `cider-jack-in' needs to invoke for the PROJECT-TYPE." + (pcase project-type + ("lein" cider-lein-command) + ("boot" cider-boot-command) + ("gradle" cider-gradle-command) + (_ (user-error "Unsupported project type `%s'" project-type)))) + +(defun cider-jack-in-resolve-command (project-type) + "Determine the resolved file path to `cider-jack-in-command' if it can be +found for the PROJECT-TYPE" + (pcase project-type + ("lein" (cider--lein-resolve-command)) + ("boot" (cider--boot-resolve-command)) + ("gradle" (cider--gradle-resolve-command)) + (_ (user-error "Unsupported project type `%s'" project-type)))) + +(defun cider-jack-in-global-options (project-type) + "Determine the command line options for `cider-jack-in' for the PROJECT-TYPE." + (pcase project-type + ("lein" cider-lein-global-options) + ("boot" cider-boot-global-options) + ("gradle" cider-gradle-global-options) + (_ (user-error "Unsupported project type `%s'" project-type)))) + +(defun cider-jack-in-params (project-type) + "Determine the commands params for `cider-jack-in' for the PROJECT-TYPE." + (pcase project-type + ("lein" cider-lein-parameters) + ("boot" cider-boot-parameters) + ("gradle" cider-gradle-parameters) + (_ (user-error "Unsupported project type `%s'" project-type)))) + + +;;; Jack-in dependencies injection +(defvar cider-jack-in-dependencies nil + "List of dependencies where elements are lists of artifact name and version.") +(put 'cider-jack-in-dependencies 'risky-local-variable t) +(cider-add-to-alist 'cider-jack-in-dependencies + "org.clojure/tools.nrepl" "0.2.12") + +(defvar cider-jack-in-dependencies-exclusions nil + "List of exclusions for jack in dependencies. + +Elements of the list are artifact name and list of exclusions to apply for the artifact.") +(put 'cider-jack-in-dependencies-exclusions 'risky-local-variable t) +(cider-add-to-alist 'cider-jack-in-dependencies-exclusions + "org.clojure/tools.nrepl" '("org.clojure/clojure")) + +(defcustom cider-jack-in-auto-inject-clojure nil + "Version of clojure to auto-inject into REPL. + +If nil, do not inject Clojure into the REPL. If `latest', inject +`cider-latest-clojure-version', which should approximate to the most recent +version of Clojure. If `minimal', inject `cider-minimum-clojure-version', +which will be the lowest version CIDER supports. If a string, use this as +the version number. If it is a list, the first element should be a string, +specifying the artifact ID, and the second element the version number." + :type '(choice (const :tag "None" nil) + (const :tag "Latest" 'latest) + (const :tag "Minimal" 'minimal) + (string :tag "Specific Version") + (list :tag "Artifact ID and Version" + (string :tag "Artifact ID") + (string :tag "Version")))) + +(defvar cider-jack-in-lein-plugins nil + "List of Leiningen plugins where elements are lists of artifact name and version.") +(put 'cider-jack-in-lein-plugins 'risky-local-variable t) +(cider-add-to-alist 'cider-jack-in-lein-plugins + "cider/cider-nrepl" (upcase cider-version)) + +(defvar cider-jack-in-nrepl-middlewares nil + "List of Clojure variable names. +Each of these Clojure variables should hold a vector of nREPL middlewares.") +(put 'cider-jack-in-nrepl-middlewares 'risky-local-variable t) +(add-to-list 'cider-jack-in-nrepl-middlewares "cider.nrepl/cider-middleware") + +(defun cider--list-as-boot-artifact (list) + "Return a boot artifact string described by the elements of LIST. +LIST should have the form (ARTIFACT-NAME ARTIFACT-VERSION). The returned +string is quoted for passing as argument to an inferior shell." + (concat "-d " (shell-quote-argument (format "%s:%s" (car list) (cadr list))))) + +(defun cider-boot-dependencies (dependencies) + "Return a list of boot artifact strings created from DEPENDENCIES." + (concat (mapconcat #'cider--list-as-boot-artifact dependencies " ") + (when (not (seq-empty-p dependencies)) " "))) + +(defun cider-boot-middleware-task (params middlewares) + (concat "cider.tasks/add-middleware " + (mapconcat (lambda (middleware) + (format "-m %s" (shell-quote-argument middleware))) + middlewares + " ") + " " params)) + +(defun cider-boot-jack-in-dependencies (global-opts params dependencies plugins middlewares) + (concat global-opts + (when (not (seq-empty-p global-opts)) " ") + "-i \"(require 'cider.tasks)\" " ;; Note the white space at the end here + (cider-boot-dependencies (append dependencies plugins)) + (cider-boot-middleware-task params middlewares))) + +(defun cider--lein-artifact-exclusions (exclusions) + "Return an exclusions vector described by the elements of EXCLUSIONS." + (if exclusions + (format " :exclusions [%s]" (mapconcat #'identity exclusions " ")) + "")) + +(defun cider--list-as-lein-artifact (list &optional exclusions) + "Return an artifact string described by the elements of LIST. +LIST should have the form (ARTIFACT-NAME ARTIFACT-VERSION). Optionally a list +of EXCLUSIONS can be provided as well. The returned +string is quoted for passing as argument to an inferior shell." + (shell-quote-argument (format "[%s %S%s]" (car list) (cadr list) (cider--lein-artifact-exclusions exclusions)))) + +(defun cider-lein-jack-in-dependencies (global-opts params dependencies dependencies-exclusions lein-plugins) + (concat + global-opts + (when (not (seq-empty-p global-opts)) " ") + (mapconcat #'identity + (append (seq-map (lambda (dep) + (let ((exclusions (cadr (assoc (car dep) dependencies-exclusions)))) + (concat "update-in :dependencies conj " + (cider--list-as-lein-artifact dep exclusions)))) + dependencies) + (seq-map (lambda (plugin) + (concat "update-in :plugins conj " + (cider--list-as-lein-artifact plugin))) + lein-plugins)) + " -- ") + " -- " + params)) + +(defun cider-add-clojure-dependencies-maybe (dependencies) + "Return DEPENDENCIES with an added Clojure dependency if requested. + +See also `cider-jack-in-auto-inject-clojure'." + (if cider-jack-in-auto-inject-clojure + (if (consp cider-jack-in-auto-inject-clojure) + (cons cider-jack-in-auto-inject-clojure dependencies) + (cons (list cider-clojure-artifact-id + (cond + ((stringp cider-jack-in-auto-inject-clojure) + cider-jack-in-auto-inject-clojure) + ((eq cider-jack-in-auto-inject-clojure 'minimal) + cider-minimum-clojure-version) + ((eq cider-jack-in-auto-inject-clojure 'latest) + cider-latest-clojure-version))) + dependencies)) + dependencies)) + +(defun cider-inject-jack-in-dependencies (global-opts params project-type) + "Return PARAMS with injected REPL dependencies. +These are set in `cider-jack-in-dependencies', `cider-jack-in-lein-plugins' and +`cider-jack-in-nrepl-middlewares' are injected from the CLI according to +the used PROJECT-TYPE. Eliminates the need for hacking profiles.clj or the +boot script for supporting cider with its nREPL middleware and +dependencies." + (pcase project-type + ("lein" (cider-lein-jack-in-dependencies + global-opts + params + (cider-add-clojure-dependencies-maybe + cider-jack-in-dependencies) + cider-jack-in-dependencies-exclusions + cider-jack-in-lein-plugins)) + ("boot" (cider-boot-jack-in-dependencies + global-opts + params + (cider-add-clojure-dependencies-maybe + cider-jack-in-dependencies) + cider-jack-in-lein-plugins + cider-jack-in-nrepl-middlewares)) + ("gradle" (concat + global-opts + (when (not (seq-empty-p global-opts)) " ") + params)) + (_ (error "Unsupported project type `%s'" project-type)))) + + +;;; ClojureScript REPL creation +(defconst cider--cljs-repl-types + '(("(cemerick.piggieback/cljs-repl (cljs.repl.rhino/repl-env))" + "Rhino" "") + ("(do (require 'figwheel-sidecar.repl-api) (figwheel-sidecar.repl-api/start-figwheel!) (figwheel-sidecar.repl-api/cljs-repl))" + "Figwheel-sidecar" " (add figwheel-sidecar to your plugins)") + ("(do (require 'cljs.repl.node) (cemerick.piggieback/cljs-repl (cljs.repl.node/repl-env)))" + "Node" " (requires NodeJS to be installed)") + ("(do (require 'weasel.repl.websocket) (cemerick.piggieback/cljs-repl (weasel.repl.websocket/repl-env :ip \"127.0.0.1\" :port 9001)))" + "Weasel" " (see http://cider.readthedocs.io/en/latest/up_and_running/#browser-connected-clojurescript-repl)") + ("(do (require 'adzerk.boot-cljs-repl) (adzerk.boot-cljs-repl/start-repl))" + "Boot-cljs-repl" " (see https://github.com/adzerk-oss/boot-cljs-repl/blob/master/README.md"))) + +(defcustom cider-cljs-lein-repl "(cemerick.piggieback/cljs-repl (cljs.repl.rhino/repl-env))" + "Clojure form that returns a ClojureScript REPL environment. +This is only used in lein projects. It is evaluated in a Clojure REPL and +it should start a ClojureScript REPL." + :type `(choice ,@(seq-map (lambda (x) `(const :tag ,(apply #'concat (cdr x)) ,(car x))) + cider--cljs-repl-types) + (string :tag "Custom")) + :safe (lambda (x) (assoc x cider--cljs-repl-types)) + :package-version '(cider . "0.11.0") + :group 'cider) + +(defcustom cider-cljs-boot-repl "(do (require 'adzerk.boot-cljs-repl) (adzerk.boot-cljs-repl/start-repl))" + "Clojure form that returns a ClojureScript REPL environment. +This is only used in boot projects. It is evaluated in a Clojure REPL and +it should start a ClojureScript REPL." + :type `(choice ,@(seq-map (lambda (x) `(const :tag ,(apply #'concat (cdr x)) ,(car x))) + cider--cljs-repl-types) + (string :tag "Custom")) + :safe (lambda (x) (assoc x cider--cljs-repl-types)) + :package-version '(cider . "0.15.0") + :group 'cider) + +(defcustom cider-cljs-gradle-repl "(cemerick.piggieback/cljs-repl (cljs.repl.rhino/repl-env))" + "Clojure form that returns a ClojureScript REPL environment. +This is only used in gradle projects. It is evaluated in a Clojure REPL and +it should start a ClojureScript REPL." + :type `(choice ,@(seq-map (lambda (x) `(const :tag ,(apply #'concat (cdr x)) ,(car x))) + cider--cljs-repl-types) + (string :tag "Custom")) + :safe (lambda (x) (assoc x cider--cljs-repl-types)) + :package-version '(cider . "0.15.0") + :group 'cider) + +(defun cider-cljs-repl-form (project-type) + "Return a Clojure form that returns a ClojureScript REPL environment +based on PROJECT-TYPE." + (pcase project-type + ("lein" cider-cljs-lein-repl) + ("boot" cider-cljs-boot-repl) + ("gradle" cider-cljs-gradle-repl) + (_ (error "Unsupported project type `%s'" project-type)))) + +(defun cider--offer-to-open-app-in-browser (server-buffer) + "Look for a server address in SERVER-BUFFER and offer to open it." + (when (buffer-live-p server-buffer) + (with-current-buffer server-buffer + (save-excursion + (goto-char (point-min)) + (when-let ((url (and (search-forward-regexp "http://localhost:[0-9]+" nil 'noerror) + (match-string 0)))) + (when (y-or-n-p (format "Visit ‘%s’ in a browser? " url)) + (browse-url url))))))) + +(defun cider-create-sibling-cljs-repl (client-buffer) + "Create a ClojureScript REPL with the same server as CLIENT-BUFFER. +The new buffer will correspond to the same project as CLIENT-BUFFER, which +should be the regular Clojure REPL started by the server process filter." + (interactive (list (cider-current-connection))) + (let* ((nrepl-repl-buffer-name-template "*cider-repl CLJS%s*") + (nrepl-create-client-buffer-function #'cider-repl-create) + (nrepl-use-this-as-repl-buffer 'new) + (client-process-args (with-current-buffer client-buffer + (unless (or nrepl-server-buffer nrepl-endpoint) + (error "This is not a REPL buffer, is there a REPL active?")) + (list (car nrepl-endpoint) + (elt nrepl-endpoint 1) + (when (buffer-live-p nrepl-server-buffer) + (get-buffer-process nrepl-server-buffer))))) + (cljs-proc (apply #'nrepl-start-client-process client-process-args)) + (cljs-buffer (process-buffer cljs-proc)) + (cljs-repl-form (cider-cljs-repl-form (cider-project-type)))) + (with-current-buffer cljs-buffer + ;; The new connection has now been bumped to the top, but it's still a + ;; Clojure REPL! Additionally, some ClojureScript REPLs can actually take + ;; a while to start (some even depend on the user opening a browser). + ;; Meanwhile, this REPL will gladly receive requests in place of the + ;; original Clojure REPL. Our solution is to bump the original REPL back + ;; up the list, so it takes priority on Clojure requests. + (cider-make-connection-default client-buffer) + (pcase (assoc cljs-repl-form cider--cljs-repl-types) + (`(,_ ,name ,info) + (message "Starting a %s REPL%s" name (or info ""))) + (_ (message "Starting a custom ClojureScript REPL"))) + (cider-nrepl-send-request + (list "op" "eval" + "ns" (cider-current-ns) + "code" cljs-repl-form) + (cider-repl-handler (current-buffer))) + (cider--offer-to-open-app-in-browser nrepl-server-buffer)))) + +(defun cider--select-zombie-buffer (repl-buffers) + "Return a zombie buffer from REPL-BUFFERS, or nil if none exists." + (when-let ((zombie-buffs (seq-remove #'get-buffer-process repl-buffers))) + (when (y-or-n-p + (format "Zombie REPL buffers exist (%s). Reuse? " + (mapconcat #'buffer-name zombie-buffs ", "))) + (if (= (length zombie-buffs) 1) + (car zombie-buffs) + (completing-read "Choose REPL buffer: " + (mapcar #'buffer-name zombie-buffs) + nil t))))) + +(defun cider-find-reusable-repl-buffer (endpoint project-directory) + "Check whether a reusable connection buffer already exists. +Looks for buffers where `nrepl-endpoint' matches ENDPOINT, or +`nrepl-project-dir' matches PROJECT-DIRECTORY. If such a buffer was found, +and has no process, return it. If the process is alive, ask the user for +confirmation and return 'new/nil for y/n answer respectively. If other +REPL buffers with dead process exist, ask the user if any of those should +be reused." + (if-let ((repl-buffers (cider-repl-buffers)) + (exact-buff (seq-find + (lambda (buff) + (with-current-buffer buff + (or (and endpoint + (equal endpoint nrepl-endpoint)) + (and project-directory + (equal project-directory nrepl-project-dir))))) + repl-buffers))) + (if (get-buffer-process exact-buff) + (when (y-or-n-p (format "REPL buffer already exists (%s). \ +Do you really want to create a new one? " + exact-buff)) + 'new) + exact-buff) + (or (cider--select-zombie-buffer repl-buffers) 'new))) + +;;;###autoload +(defun cider-jack-in (&optional prompt-project cljs-too) + "Start an nREPL server for the current project and connect to it. +If PROMPT-PROJECT is t, then prompt for the project for which to +start the server. +If CLJS-TOO is non-nil, also start a ClojureScript REPL session with its +own buffer." + (interactive "P") + (setq cider-current-clojure-buffer (current-buffer)) + (let* ((project-type (cider-project-type)) + (command (cider-jack-in-command project-type)) + (command-resolved (cider-jack-in-resolve-command project-type)) + (command-global-opts (cider-jack-in-global-options project-type)) + (command-params (cider-jack-in-params project-type))) + (if command-resolved + (let* ((project (when prompt-project + (read-directory-name "Project: "))) + (project-dir (clojure-project-dir + (or project (cider-current-dir)))) + (params (if prompt-project + (read-string (format "nREPL server command: %s " + command-params) + command-params) + command-params)) + (params (if cider-inject-dependencies-at-jack-in + (cider-inject-jack-in-dependencies command-global-opts params project-type) + params)) + + (cmd (format "%s %s" command-resolved params))) + (if (or project-dir cider-allow-jack-in-without-project) + (progn + (when (or project-dir + (eq cider-allow-jack-in-without-project t) + (and (null project-dir) + (eq cider-allow-jack-in-without-project 'warn) + (y-or-n-p "Are you sure you want to run `cider-jack-in' without a Clojure project? "))) + (when-let ((repl-buff (cider-find-reusable-repl-buffer nil project-dir))) + (let ((nrepl-create-client-buffer-function #'cider-repl-create) + (nrepl-use-this-as-repl-buffer repl-buff)) + (nrepl-start-server-process + project-dir cmd + (when cljs-too #'cider-create-sibling-cljs-repl)))))) + (user-error "`cider-jack-in' is not allowed without a Clojure project"))) + (user-error "The %s executable isn't on your `exec-path'" command)))) + +;;;###autoload +(defun cider-jack-in-clojurescript (&optional prompt-project) + "Start an nREPL server and connect to it both Clojure and ClojureScript REPLs. +If PROMPT-PROJECT is t, then prompt for the project for which to +start the server." + (interactive "P") + (cider-jack-in prompt-project 'cljs-too)) + +;;;###autoload +(defun cider-connect (host port &optional project-dir) + "Connect to an nREPL server identified by HOST and PORT. +Create REPL buffer and start an nREPL client connection. + +When the optional param PROJECT-DIR is present, the connection +gets associated with it." + (interactive (cider-select-endpoint)) + (setq cider-current-clojure-buffer (current-buffer)) + (when-let ((repl-buff (cider-find-reusable-repl-buffer `(,host ,port) nil))) + (let* ((nrepl-create-client-buffer-function #'cider-repl-create) + (nrepl-use-this-as-repl-buffer repl-buff) + (conn (process-buffer (nrepl-start-client-process host port)))) + (with-current-buffer conn + (setq cider-connection-created-with 'connect)) + (if project-dir + (cider-assoc-project-with-connection project-dir conn) + (let ((project-dir (clojure-project-dir))) + (cond + ;; associate only if we're in a project + ((and project-dir (null cider-prompt-for-project-on-connect)) (cider-assoc-project-with-connection project-dir conn)) + ;; associate if we're in a project, prompt otherwise + ((eq cider-prompt-for-project-on-connect 'when-needed) (cider-assoc-project-with-connection project-dir conn)) + ;; always prompt + (t (cider-assoc-project-with-connection nil conn)))))))) + +(defun cider-current-host () + "Retrieve the current host." + (if (and (stringp buffer-file-name) + (file-remote-p buffer-file-name)) + tramp-current-host + "localhost")) + +(defun cider-select-endpoint () + "Interactively select the host and port to connect to." + (dolist (endpoint cider-known-endpoints) + (unless (stringp (or (nth 2 endpoint) + (nth 1 endpoint))) + (user-error "The port for %s in `cider-known-endpoints' should be a string" + (nth 0 endpoint)))) + (let* ((ssh-hosts (cider--ssh-hosts)) + (hosts (seq-uniq (append (when cider-host-history + ;; history elements are strings of the form "host:port" + (list (split-string (car cider-host-history) ":"))) + (list (list (cider-current-host))) + cider-known-endpoints + ssh-hosts + (when (file-remote-p default-directory) + ;; add localhost even in remote buffers + '(("localhost")))))) + (sel-host (cider--completing-read-host hosts)) + (host (car sel-host)) + (port (or (cadr sel-host) + (cider--completing-read-port host (cider--infer-ports host ssh-hosts))))) + (list host port))) + +(defun cider--ssh-hosts () + "Retrieve all ssh host from local configuration files." + (seq-map (lambda (s) (list (replace-regexp-in-string ":$" "" s))) + (let ((tramp-completion-mode t)) + (tramp-completion-handle-file-name-all-completions "" "/ssh:")))) + +(defun cider--completing-read-host (hosts) + "Interactively select host from HOSTS. +Each element in HOSTS is one of: (host), (host port) or (label host port). +Return a list of the form (HOST PORT), where PORT can be nil." + (let* ((hosts (cider-join-into-alist hosts)) + (sel-host (completing-read "Host: " hosts nil nil nil + 'cider-host-history (caar hosts))) + (host (or (cdr (assoc sel-host hosts)) (list sel-host)))) + ;; remove the label + (if (= 3 (length host)) (cdr host) host))) + +(defun cider--infer-ports (host ssh-hosts) + "Infer nREPL ports on HOST. +Return a list of elements of the form (directory port). SSH-HOSTS is a list +of remote SSH hosts." + (let ((localp (or (nrepl-local-host-p host) + (not (assoc-string host ssh-hosts))))) + (if localp + ;; change dir: current file might be remote + (let* ((change-dir-p (file-remote-p default-directory)) + (default-directory (if change-dir-p "~/" default-directory))) + (cider-locate-running-nrepl-ports (unless change-dir-p default-directory))) + (let ((vec (vector "sshx" nil host "" nil)) + ;; change dir: user might want to connect to a different remote + (dir (when (file-remote-p default-directory) + (with-parsed-tramp-file-name default-directory cur + (when (string= cur-host host) default-directory))))) + (tramp-maybe-open-connection vec) + (with-current-buffer (tramp-get-connection-buffer vec) + (cider-locate-running-nrepl-ports dir)))))) + +(defun cider--completing-read-port (host ports) + "Interactively select port for HOST from PORTS." + (let* ((ports (cider-join-into-alist ports)) + (sel-port (completing-read (format "Port for %s: " host) ports + nil nil nil nil (caar ports))) + (port (or (cdr (assoc sel-port ports)) sel-port)) + (port (if (listp port) (cadr port) port))) + (if (stringp port) (string-to-number port) port))) + +(defun cider-locate-running-nrepl-ports (&optional dir) + "Locate ports of running nREPL servers. +When DIR is non-nil also look for nREPL port files in DIR. Return a list +of list of the form (project-dir port)." + (let* ((paths (cider--running-nrepl-paths)) + (proj-ports (mapcar (lambda (d) + (when-let ((port (and d (nrepl-extract-port (cider--file-path d))))) + (list (file-name-nondirectory (directory-file-name d)) port))) + (cons (clojure-project-dir dir) paths)))) + (seq-uniq (delq nil proj-ports)))) + +(defun cider--running-nrepl-paths () + "Retrieve project paths of running nREPL servers. +Use `cider-ps-running-nrepls-command' and `cider-ps-running-nrepl-path-regexp-list'." + (let (paths) + (with-temp-buffer + (insert (shell-command-to-string cider-ps-running-nrepls-command)) + (dolist (regexp cider-ps-running-nrepl-path-regexp-list) + (goto-char 1) + (while (re-search-forward regexp nil t) + (setq paths (cons (match-string 1) paths))))) + (seq-uniq paths))) + +(defun cider--identify-buildtools-present () + "Identify build systems present by their build files." + (let* ((default-directory (clojure-project-dir (cider-current-dir))) + (build-files '(("lein" . "project.clj") + ("boot" . "build.boot") + ("gradle" . "build.gradle")))) + (delq nil + (mapcar (lambda (candidate) + (when (file-exists-p (cdr candidate)) + (car candidate))) + build-files)))) + +(defun cider-project-type () + "Determine the type, either leiningen, boot or gradle, of the current project. +If more than one project file types are present, check for a preferred +build tool in `cider-preferred-build-tool', otherwise prompt the user to +choose." + (let* ((choices (cider--identify-buildtools-present)) + (multiple-project-choices (> (length choices) 1)) + (default (car choices))) + (cond ((and multiple-project-choices + (member cider-preferred-build-tool choices)) + cider-preferred-build-tool) + (multiple-project-choices + (completing-read (format "Which command should be used (default %s): " default) + choices nil t nil nil default)) + (choices + (car choices)) + (t cider-default-repl-command)))) + + +;; TODO: Implement a check for `cider-lein-command' over tramp +(defun cider--lein-resolve-command () + "Find `cider-lein-command' on `exec-path' if possible, or return `nil'. + +In case `default-directory' is non-local we assume the command is available." + (when-let ((command (or (and (file-remote-p default-directory) cider-lein-command) + (executable-find cider-lein-command) + (executable-find (concat cider-lein-command ".bat"))))) + (shell-quote-argument command))) + +;; TODO: Implement a check for `cider-boot-command' over tramp +(defun cider--boot-resolve-command () + "Find `cider-boot-command' on `exec-path' if possible, or return `nil'. + +In case `default-directory' is non-local we assume the command is available." + (when-let ((command (or (and (file-remote-p default-directory) cider-boot-command) + (executable-find cider-boot-command) + (executable-find (concat cider-boot-command ".exe"))))) + (shell-quote-argument command))) + +;; TODO: Implement a check for `cider-gradle-command' over tramp +(defun cider--gradle-resolve-command () + "Find `cider-gradle-command' on `exec-path' if possible, or return `nil'. + +In case `default-directory' is non-local we assume the command is available." + (when-let ((command (or (and (file-remote-p default-directory) cider-gradle-command) + (executable-find cider-gradle-command) + (executable-find (concat cider-gradle-command ".exe"))))) + (shell-quote-argument command))) + + +;;; Check that the connection is working well +;; TODO: This is nrepl specific. It should eventually go into some cider-nrepl-client +;; file. +(defun cider--check-required-nrepl-version () + "Check whether we're using a compatible nREPL version." + (if-let ((nrepl-version (cider--nrepl-version))) + (when (version< nrepl-version cider-required-nrepl-version) + (cider-repl-manual-warning "troubleshooting/#warning-saying-you-have-to-use-nrepl-0212" + "CIDER requires nREPL %s (or newer) to work properly" + cider-required-nrepl-version)) + (cider-repl-manual-warning "troubleshooting/#warning-saying-you-have-to-use-nrepl-0212" + "Can't determine nREPL's version.\nPlease, update nREPL to %s." + cider-required-nrepl-version))) + +(defun cider--check-clojure-version-supported () + "Ensure that we are meeting the minimum supported version of Clojure." + (if-let ((clojure-version (cider--clojure-version))) + (when (version< clojure-version cider-minimum-clojure-version) + (cider-repl-manual-warning "installation/#prerequisites" + "Clojure version (%s) is not supported (minimum %s). CIDER will not work." + clojure-version cider-minimum-clojure-version)) + (cider-repl-manual-warning "installation/#prerequisites" + "Can't determine Clojure's version. CIDER requires Clojure %s (or newer)." + cider-minimum-clojure-version))) + +(defun cider--check-middleware-compatibility () + "CIDER frontend/backend compatibility check. +Retrieve the underlying connection's CIDER-nREPL version and checks if the +middleware used is compatible with CIDER. If not, will display a warning +message in the REPL area." + (let* ((version-dict (nrepl-aux-info "cider-version" (cider-current-connection))) + (middleware-version (nrepl-dict-get version-dict "version-string" "not installed"))) + (unless (equal cider-version middleware-version) + (cider-repl-manual-warning "troubleshooting/#cider-complains-of-the-cider-nrepl-version" + "CIDER's version (%s) does not match cider-nrepl's version (%s). Things will break!" + cider-version middleware-version)))) + +(defun cider--subscribe-repl-to-server-out () + "Subscribe to the server's *out*." + (cider-nrepl-send-request '("op" "out-subscribe") + (cider-interactive-eval-handler (current-buffer)))) + +(defun cider--connected-handler () + "Handle cider initialization after nREPL connection has been established. +This function is appended to `nrepl-connected-hook' in the client process +buffer." + ;; `nrepl-connected-hook' is run in the connection buffer + (cider-make-connection-default (current-buffer)) + (cider-repl-init (current-buffer)) + (cider--check-required-nrepl-version) + (cider--check-clojure-version-supported) + (cider--check-middleware-compatibility) + (cider--debug-init-connection) + (cider--subscribe-repl-to-server-out) + (when cider-auto-mode + (cider-enable-on-existing-clojure-buffers)) + (run-hooks 'cider-connected-hook)) + +(defun cider--disconnected-handler () + "Cleanup after nREPL connection has been lost or closed. +This function is appended to `nrepl-disconnected-hook' in the client +process buffer." + ;; `nrepl-connected-hook' is run in the connection buffer + (cider-possibly-disable-on-existing-clojure-buffers) + (run-hooks 'cider-disconnected-hook)) + +;;;###autoload +(eval-after-load 'clojure-mode + '(progn + (define-key clojure-mode-map (kbd "C-c M-j") #'cider-jack-in) + (define-key clojure-mode-map (kbd "C-c M-J") #'cider-jack-in-clojurescript) + (define-key clojure-mode-map (kbd "C-c M-c") #'cider-connect))) + +(provide 'cider) + +;;; cider.el ends here diff --git a/elpa/cider-20170129.1941/nrepl-client.el b/elpa/cider-20170129.1941/nrepl-client.el new file mode 100644 index 00000000..177f8ff4 --- /dev/null +++ b/elpa/cider-20170129.1941/nrepl-client.el @@ -0,0 +1,1306 @@ +;;; nrepl-client.el --- Client for Clojure nREPL -*- lexical-binding: t -*- + +;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov +;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors +;; +;; Author: Tim King +;; 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 'subr-x) +(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-use-ssh-fallback-for-remote-hosts nil + "If non-nil, attempt to connect via ssh to remote hosts when unable to connect directly." + :type 'boolean + :group 'nrepl) + +(defcustom nrepl-sync-request-timeout 10 + "The number of seconds to wait for a sync response. +Setting this to nil disables the timeout functionality." + :type 'integer + :group 'nrepl) + +(defcustom nrepl-hide-special-buffers nil + "Control the display of some special buffers in buffer switching commands. +When true some special buffers like the server buffer will be hidden." + :type 'boolean + :group 'nrepl) + +(defcustom nrepl-prompt-to-kill-server-buffer-on-quit t + "If non-nil, prompt the user for confirmation before killing the nrepl server buffer and associated process." + :type 'boolean + :group 'nrepl) + +(defvar nrepl-create-client-buffer-function 'nrepl-create-client-buffer-default + "Name of a function that returns a client process buffer. +It is called with one argument, a plist containing :host, :port and :proc +as returned by `nrepl-connect'.") + +(defvar nrepl-use-this-as-repl-buffer 'new + "Name of the buffer to use as REPL buffer. +In case of a special value 'new, a new buffer is created.") + + +;;; 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 (and `nrepl-use-ssh-fallback-for-remote-hosts' is +non-nil), try to start a SSH tunneled connection. Return a plist of the +form (:proc PROC :host \"HOST\" :port PORT) that might contain additional +key-values depending on the connection type." + (let ((localp (if host + (nrepl-local-host-p host) + (not (file-remote-p default-directory))))) + (if localp + (nrepl--direct-connect (or host "localhost") port) + ;; we're dealing with a remote host + (if (and host (not nrepl-force-ssh-for-remote-hosts)) + (nrepl--direct-connect host port 'no-error) + ;; direct connection failed or `nrepl-force-ssh-for-remote-hosts' is non-nil + (when (or nrepl-use-ssh-fallback-for-remote-hosts + nrepl-force-ssh-for-remote-hosts) + (nrepl--ssh-tunnel-connect host port)))))) + +(defun nrepl--direct-connect (host port &optional no-error) + "If HOST and PORT are given, try to `open-network-stream'. +If NO-ERROR is non-nil, show messages instead of throwing an error." + (if (not (and host port)) + (unless no-error + (error "Host (%s) and port (%s) must be provided" host port)) + (message "[nREPL] Establishing direct connection to %s:%s ..." host port) + (condition-case nil + (prog1 (list :proc (open-network-stream "nrepl-connection" nil host port) + :host host :port port) + (message "[nREPL] Direct connection established")) + (error (let ((mes "[nREPL] Direct connection failed")) + (if no-error (message mes) (error mes)) + nil))))) + +(defun nrepl--ssh-tunnel-connect (host port) + "Connect to a remote machine identified by HOST and PORT through SSH tunnel." + (message "[nREPL] Establishing SSH tunneled connection ...") + (let* ((remote-dir (if host (format "/ssh:%s:" host) default-directory)) + (ssh (or (executable-find "ssh") + (error "[nREPL] Cannot locate 'ssh' executable"))) + (cmd (nrepl--ssh-tunnel-command ssh remote-dir port)) + (tunnel-buf (nrepl-tunnel-buffer-name)) + (tunnel (start-process-shell-command "nrepl-tunnel" tunnel-buf cmd))) + (process-put tunnel :waiting-for-port t) + (set-process-filter tunnel (nrepl--ssh-tunnel-filter port)) + (while (and (process-live-p tunnel) + (process-get tunnel :waiting-for-port)) + (accept-process-output nil 0.005)) + (if (not (process-live-p tunnel)) + (error "[nREPL] SSH port forwarding failed. Check the '%s' buffer" tunnel-buf) + (message "[nREPL] SSH port forwarding established to localhost:%s" port) + (let ((endpoint (nrepl--direct-connect "localhost" port))) + (thread-first endpoint + (plist-put :tunnel tunnel) + (plist-put :remote-host host)))))) + +(defun nrepl--ssh-tunnel-command (ssh dir port) + "Command string to open SSH tunnel to the host associated with DIR's PORT." + (with-parsed-tramp-file-name dir nil + ;; this abuses the -v option for ssh to get output when the port + ;; forwarding is set up, which is used to synchronise on, so that + ;; the port forwarding is up when we try to connect. + (format-spec + "%s -v -N -L %p:localhost:%p %u'%h'" + `((?s . ,ssh) + (?p . ,port) + (?h . ,host) + (?u . ,(if user (format "-l '%s' " user) "")))))) + +(autoload 'comint-watch-for-password-prompt "comint" "(autoload).") + +(defun nrepl--ssh-tunnel-filter (port) + "Return a process filter that waits for PORT to appear in process output." + (let ((port-string (format "LOCALHOST:%s" port))) + (lambda (proc string) + (when (string-match-p port-string string) + (process-put proc :waiting-for-port nil)) + (when (and (process-live-p proc) + (buffer-live-p (process-buffer proc))) + (with-current-buffer (process-buffer proc) + (let ((moving (= (point) (process-mark proc)))) + (save-excursion + (goto-char (process-mark proc)) + (insert string) + (set-marker (process-mark proc) (point)) + (comint-watch-for-password-prompt string)) + (if moving (goto-char (process-mark proc))))))))) + + +;;; Client: Process Handling + +(defun nrepl--maybe-kill-server-buffer (server-buf) + "Kill SERVER-BUF and its process, subject to user confirmation. +Do nothing if there is a REPL connected to that server." + (with-current-buffer server-buf + ;; Don't kill the server if there is a REPL connected to it. + (when (and (not nrepl-client-buffers) + (or (not nrepl-prompt-to-kill-server-buffer-on-quit) + (y-or-n-p "Also kill server process and buffer? "))) + (let ((proc (get-buffer-process server-buf))) + (when (process-live-p proc) + (set-process-query-on-exit-flag proc nil) + (kill-process proc)) + (kill-buffer server-buf))))) + +;; `nrepl-start-client-process' is called from `nrepl-server-filter'. It +;; starts the client process described by `nrepl-client-filter' and +;; `nrepl-client-sentinel'. +(defun nrepl-start-client-process (&optional host port server-proc) + "Create new client process identified by HOST and PORT. +In remote buffers, HOST and PORT are taken from the current tramp +connection. SERVER-PROC must be a running nREPL server process within +Emacs. This function creates connection buffer by a call to +`nrepl-create-client-buffer-function'. Return newly created client +process." + (let* ((endpoint (nrepl-connect host port)) + (client-proc (plist-get endpoint :proc)) + (host (plist-get endpoint :host)) + (port (plist-get endpoint :port)) + (client-buf (funcall nrepl-create-client-buffer-function endpoint))) + + (set-process-buffer client-proc client-buf) + + (set-process-filter client-proc 'nrepl-client-filter) + (set-process-sentinel client-proc 'nrepl-client-sentinel) + (set-process-coding-system client-proc 'utf-8-unix 'utf-8-unix) + + (process-put client-proc :string-q (queue-create)) + (process-put client-proc :response-q (nrepl-response-queue)) + + (with-current-buffer client-buf + (when-let ((server-buf (and server-proc (process-buffer server-proc)))) + (setq nrepl-project-dir (buffer-local-value 'nrepl-project-dir server-buf) + nrepl-server-buffer server-buf)) + (setq nrepl-endpoint `(,host ,port) + nrepl-tunnel-buffer (when-let ((tunnel (plist-get endpoint :tunnel))) + (process-buffer tunnel)) + nrepl-pending-requests (make-hash-table :test 'equal) + nrepl-completed-requests (make-hash-table :test 'equal))) + + (with-current-buffer client-buf + (nrepl--init-client-sessions client-proc) + (nrepl--init-capabilities client-buf) + (run-hooks 'nrepl-connected-hook)) + + client-proc)) + +(defun nrepl--init-client-sessions (client) + "Initialize CLIENT connection nREPL sessions. + +We create two client nREPL sessions per connection - a main session and a +tooling session. The main session is general purpose and is used for pretty +much every request that needs a session. The tooling session is used only +for functionality that's implemented in terms of the \"eval\" op, so that +eval requests for functionality like pretty-printing won't clobber the +values of *1, *2, etc." + (let* ((client-conn (process-buffer client)) + (response-main (nrepl-sync-request:clone client-conn)) + (response-tooling (nrepl-sync-request:clone client-conn t))) ; t for tooling + (nrepl-dbind-response response-main (new-session err) + (if new-session + (with-current-buffer client-conn + (setq nrepl-session new-session)) + (error "Could not create new session (%s)" err))) + (nrepl-dbind-response response-tooling (new-session err) + (if new-session + (with-current-buffer client-conn + (setq nrepl-tooling-session new-session)) + (error "Could not create new tooling session (%s)" err))))) + +(defun nrepl--init-capabilities (conn-buffer) + "Store locally in CONN-BUFFER the capabilities of nREPL server." + (let ((description (nrepl-sync-request:describe conn-buffer))) + (nrepl-dbind-response description (ops versions aux) + (with-current-buffer conn-buffer + (setq nrepl-ops ops) + (setq nrepl-versions versions) + (setq nrepl-aux aux))))) + +(defun nrepl--clear-client-sessions (conn-buffer) + "Clear information about nREPL sessions in CONN-BUFFER. +CONN-BUFFER refers to a (presumably) dead connection, which we can eventually reuse." + (with-current-buffer conn-buffer + (setq nrepl-session nil) + (setq nrepl-tooling-session nil))) + + +;;; Client: Response Handling +;; After being decoded, responses (aka, messages from the server) are dispatched +;; to handlers. Handlers are constructed with `nrepl-make-response-handler'. + +(defvar nrepl-err-handler nil + "Evaluation error handler.") + +(defun nrepl--mark-id-completed (id) + "Move ID from `nrepl-pending-requests' to `nrepl-completed-requests'. +It is safe to call this function multiple times on the same ID." + ;; FIXME: This should go away eventually when we get rid of + ;; pending-request hash table + (when-let ((handler (gethash id nrepl-pending-requests))) + (puthash id handler nrepl-completed-requests) + (remhash id nrepl-pending-requests))) + +(defvar cider-buffer-ns) +(defvar cider-special-mode-truncate-lines) +(declare-function cider-need-input "cider-interaction") +(declare-function cider-set-buffer-ns "cider-mode") + +(defun nrepl-make-response-handler (buffer value-handler stdout-handler + stderr-handler done-handler + &optional eval-error-handler + pprint-out-handler) + "Make a response handler for connection BUFFER. +A handler is a function that takes one argument - response received from +the server process. The response is an alist that contains at least 'id' +and 'session' keys. Other standard response keys are 'value', 'out', 'err', +'pprint-out' and 'status'. + +The presence of a particular key determines the type of the response. For +example, if 'value' key is present, the response is of type 'value', if +'out' key is present the response is 'stdout' etc. Depending on the type, +the handler dispatches the appropriate value to one of the supplied +handlers: VALUE-HANDLER, STDOUT-HANDLER, STDERR-HANDLER, DONE-HANDLER, +EVAL-ERROR-HANDLER, and PPRINT-OUT-HANDLER. If the optional +EVAL-ERROR-HANDLER is nil, the default `nrepl-err-handler' is used. If any +of the other supplied handlers are nil nothing happens for the +corresponding type of response." + (lambda (response) + (nrepl-dbind-response response (value ns out err status id pprint-out) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when (and ns (not (derived-mode-p 'clojure-mode))) + (cider-set-buffer-ns ns)))) + (cond (value + (when value-handler + (funcall value-handler buffer value))) + (out + (when stdout-handler + (funcall stdout-handler buffer out))) + (pprint-out + (cond (pprint-out-handler (funcall pprint-out-handler buffer pprint-out)) + (stdout-handler (funcall stdout-handler buffer pprint-out)))) + (err + (when stderr-handler + (funcall stderr-handler buffer err))) + (status + (when (member "interrupted" status) + (message "Evaluation interrupted.")) + (when (member "eval-error" status) + (funcall (or eval-error-handler nrepl-err-handler))) + (when (member "namespace-not-found" status) + (message "Namespace not found.")) + (when (member "need-input" status) + (cider-need-input buffer)) + (when (member "done" status) + (nrepl--mark-id-completed id) + (when done-handler + (funcall done-handler buffer)))))))) + + +;;; Client: Request Core API + +;; Requests are messages from an nREPL client (like CIDER) to an nREPL server. +;; Requests can be asynchronous (sent with `nrepl-send-request') or +;; synchronous (send with `nrepl-send-sync-request'). The request is a pair list +;; of operation name and operation parameters. The core operations are described +;; at https://github.com/clojure/tools.nrepl/blob/master/doc/ops.md. CIDER adds +;; many more operations through nREPL middleware. See +;; https://github.com/clojure-emacs/cider-nrepl#supplied-nrepl-middleware for +;; the up-to-date list. + +(defun nrepl-next-request-id (connection) + "Return the next request id for CONNECTION." + (with-current-buffer connection + (number-to-string (cl-incf nrepl-request-counter)))) + +(defun nrepl-send-request (request callback connection &optional tooling) + "Send REQUEST and register response handler CALLBACK using CONNECTION. +REQUEST is a pair list of the form (\"op\" \"operation\" \"par1-name\" +\"par1\" ... ). See the code of `nrepl-request:clone', +`nrepl-request:stdin', etc. This expects that the REQUEST does not have a +session already in it. This code will add it as appropriate to prevent +connection/session drift. +Return the ID of the sent message. +Optional argument TOOLING Set to t if desiring the tooling session rather than the standard session." + (with-current-buffer connection + (when-let ((session (if tooling nrepl-tooling-session nrepl-session))) + (setq request (append request + (list "session" session)))) + (let* ((id (nrepl-next-request-id connection)) + (request (cons 'dict (lax-plist-put request "id" id))) + (message (nrepl-bencode request))) + (nrepl-log-message request 'request) + (puthash id callback nrepl-pending-requests) + (process-send-string nil message) + id))) + +(defvar nrepl-ongoing-sync-request nil + "Dynamically bound to t while a sync request is ongoing.") + +(declare-function cider-repl-emit-interactive-stderr "cider-repl") +(declare-function cider--render-stacktrace-causes "cider-interaction") + +(defun nrepl-send-sync-request (request connection &optional abort-on-input tooling) + "Send REQUEST to the nREPL server synchronously using CONNECTION. +Hold till final \"done\" message has arrived and join all response messages +of the same \"op\" that came along. +If ABORT-ON-INPUT is non-nil, the function will return nil at the first +sign of user input, so as not to hang the interface. +If TOOLING, use the tooling session rather than the standard session." + (let* ((time0 (current-time)) + (response (cons 'dict nil)) + (nrepl-ongoing-sync-request t) + status) + (nrepl-send-request request + (lambda (resp) (nrepl--merge response resp)) + connection + tooling) + (while (and (not (member "done" status)) + (not (and abort-on-input + (input-pending-p)))) + (setq status (nrepl-dict-get response "status")) + ;; If we get a need-input message then the repl probably isn't going + ;; anywhere, and we'll just timeout. So we forward it to the user. + (if (member "need-input" status) + (progn (cider-need-input (current-buffer)) + ;; If the used took a few seconds to respond, we might + ;; unnecessarily timeout, so let's reset the timer. + (setq time0 (current-time))) + ;; break out in case we don't receive a response for a while + (when (and nrepl-sync-request-timeout + (> (cadr (time-subtract (current-time) time0)) + nrepl-sync-request-timeout)) + (error "Sync nREPL request timed out %s" request))) + ;; Clean up the response, otherwise we might repeatedly ask for input. + (nrepl-dict-put response "status" (remove "need-input" status)) + (accept-process-output nil 0.01)) + ;; If we couldn't finish, return nil. + (when (member "done" status) + (nrepl-dbind-response response (ex err eval-error pp-stacktrace id) + (when (and ex err) + (cond (eval-error (funcall nrepl-err-handler)) + (pp-stacktrace (cider--render-stacktrace-causes + pp-stacktrace (remove "done" status))))) ;; send the error type + (when id + (with-current-buffer connection + (nrepl--mark-id-completed id))) + response)))) + +(defun nrepl-request:stdin (input callback connection) + "Send a :stdin request with INPUT using CONNECTION. +Register CALLBACK as the response handler." + (nrepl-send-request (list "op" "stdin" + "stdin" input) + callback + connection)) + +(defun nrepl-request:interrupt (pending-request-id callback connection) + "Send an :interrupt request for PENDING-REQUEST-ID. +The request is dispatched using CONNECTION. +Register CALLBACK as the response handler." + (nrepl-send-request (list "op" "interrupt" + "interrupt-id" pending-request-id) + callback + connection)) + +(define-minor-mode cider-enlighten-mode nil nil (cider-mode " light") + :global t) + +(defun nrepl--eval-request (input &optional ns line column) + "Prepare :eval request message for INPUT. +NS provides context for the request. +If LINE and COLUMN are non-nil and current buffer is a file buffer, \"line\", +\"column\" and \"file\" are added to the message." + (append (and ns (list "ns" ns)) + (list "op" "eval" + "code" input) + (when cider-enlighten-mode + (list "enlighten" "true")) + (let ((file (or (buffer-file-name) (buffer-name)))) + (when (and line column file) + (list "file" file + "line" line + "column" column))))) + +(defun nrepl-request:eval (input callback connection &optional ns line column additional-params tooling) + "Send the request INPUT and register the CALLBACK as the response handler. +The request is dispatched via CONNECTION. If NS is non-nil, +include it in the request. LINE and COLUMN, if non-nil, define the position +of INPUT in its buffer. A CONNECTION uniquely determines two connections +available: the standard interaction one and the tooling session. If the +tooling is desired, set TOOLING to true. +ADDITIONAL-PARAMS is a plist to be appended to the request message." + (nrepl-send-request (append (nrepl--eval-request input ns line column) additional-params) + callback + connection + tooling)) + +(defun nrepl-sync-request:clone (connection &optional tooling) + "Sent a :clone request to create a new client session. +The request is dispatched via CONNECTION. +Optional argument TOOLING Tooling is set to t if wanting the tooling session from CONNECTION." + (nrepl-send-sync-request '("op" "clone") + connection + nil tooling)) + +(defun nrepl-sync-request:close (connection) + "Sent a :close request to close CONNECTION's SESSION." + (nrepl-send-sync-request (list "op" "close") + connection) + (nrepl-send-sync-request (list "op" "close") + connection nil t)) ;; close tooling session + +(defun nrepl-sync-request:describe (connection) + "Perform :describe request for CONNECTION and SESSION." + (nrepl-send-sync-request '("op" "describe") + connection)) + +(defun nrepl-sync-request:ls-sessions (connection) + "Perform :ls-sessions request for CONNECTION." + (nrepl-send-sync-request '("op" "ls-sessions") connection)) + +(defun nrepl-sync-request:eval (input connection &optional ns) + "Send the INPUT to the nREPL server synchronously. +The request is dispatched via CONNECTION. +If NS is non-nil, include it in the request." + (nrepl-send-sync-request + (nrepl--eval-request input ns) + connection)) + +(defun nrepl-sessions (connection) + "Get a list of active sessions on the nREPL server using CONNECTION." + (nrepl-dict-get (nrepl-sync-request:ls-sessions connection) "sessions")) + + +;;; Server + +;; The server side process is started by `nrepl-start-server-process' and has a +;; very simple filter that pipes its output directly into its process buffer +;; (*nrepl-server*). The main purpose of this process is to start the actual +;; nrepl communication client (`nrepl-client-filter') when the message "nREPL +;; server started on port ..." is detected. + +(defvar-local nrepl-post-client-callback nil + "Function called after the client process is started. +Used by `nrepl-start-server-process'.") + +(defun nrepl-start-server-process (directory cmd &optional callback) + "Start nREPL server process in DIRECTORY using shell command CMD. +Return a newly created process. +Set `nrepl-server-filter' as the process filter, which starts REPL process +with its own buffer once the server has started. +If CALLBACK is non-nil, it should be function of 1 argument. Once the +client process is started, the function is called with the client buffer." + (let* ((default-directory (or directory default-directory)) + (serv-buf (get-buffer-create (generate-new-buffer-name + (nrepl-server-buffer-name directory)))) + (serv-proc (start-file-process-shell-command + "nrepl-server" serv-buf cmd))) + (set-process-filter serv-proc 'nrepl-server-filter) + (set-process-sentinel serv-proc 'nrepl-server-sentinel) + (set-process-coding-system serv-proc 'utf-8-unix 'utf-8-unix) + (with-current-buffer serv-buf + (setq nrepl-project-dir directory) + (setq nrepl-post-client-callback callback) + ;; Ensure that `nrepl-start-client-process' sees right things. This + ;; causes warnings about making a local within a let-bind. This is safe + ;; as long as `serv-buf' is not the buffer where the let-binding was + ;; started. http://www.gnu.org/software/emacs/manual/html_node/elisp/Creating-Buffer_002dLocal.html + (setq-local nrepl-create-client-buffer-function + nrepl-create-client-buffer-function) + (setq-local nrepl-use-this-as-repl-buffer + nrepl-use-this-as-repl-buffer)) + (message "Starting nREPL server via %s..." + (propertize cmd 'face 'font-lock-keyword-face)) + serv-proc)) + +(defun nrepl-server-filter (process output) + "Process nREPL server output from PROCESS contained in OUTPUT." + ;; In Windows this can be false: + (let ((server-buffer (process-buffer process))) + (when (buffer-live-p server-buffer) + (with-current-buffer server-buffer + ;; auto-scroll on new output + (let ((moving (= (point) (process-mark process)))) + (save-excursion + (goto-char (process-mark process)) + (insert output) + (ansi-color-apply-on-region (process-mark process) (point)) + (set-marker (process-mark process) (point))) + (when moving + (goto-char (process-mark process)) + (when-let ((win (get-buffer-window))) + (set-window-point win (point)))))) + ;; detect the port the server is listening on from its output + (when (string-match "nREPL server started on port \\([0-9]+\\)" output) + (let ((port (string-to-number (match-string 1 output)))) + (message "nREPL server started on %s" port) + (with-current-buffer server-buffer + (let* ((client-proc (nrepl-start-client-process nil port process)) + (client-buffer (process-buffer client-proc))) + (setq nrepl-client-buffers + (cons client-buffer + (delete client-buffer nrepl-client-buffers))) + + (when (functionp nrepl-post-client-callback) + (funcall nrepl-post-client-callback client-buffer))))))))) + +(declare-function cider--close-connection-buffer "cider-client") + +(defun nrepl-server-sentinel (process event) + "Handle nREPL server PROCESS EVENT." + (let* ((server-buffer (process-buffer process)) + (clients (buffer-local-value 'nrepl-client-buffers server-buffer)) + (problem (if (and server-buffer (buffer-live-p server-buffer)) + (with-current-buffer server-buffer + (buffer-substring (point-min) (point-max))) + ""))) + (when server-buffer + (kill-buffer server-buffer)) + (cond + ((string-match-p "^killed\\|^interrupt" event) + nil) + ((string-match-p "^hangup" event) + (mapc #'cider--close-connection-buffer clients)) + ;; On Windows, a failed start sends the "finished" event. On Linux it sends + ;; "exited abnormally with code 1". + (t (error "Could not start nREPL server: %s" problem))))) + + +;;; Messages + +(defcustom nrepl-log-messages nil + "If non-nil, log protocol messages to an nREPL messages buffer. + +This is extremely useful for debug purposes, as it allows you to +inspect the communication between Emacs and an nREPL server. + +Enabling the logging might have a negative impact on performance, +so it's not recommended to keep it enabled unless you need to +debug something." + :type 'boolean + :group 'nrepl) + +(defconst nrepl-message-buffer-max-size 1000000 + "Maximum size for the nREPL message buffer. +Defaults to 1000000 characters, which should be an insignificant +memory burden, while providing reasonable history.") + +(defconst nrepl-message-buffer-reduce-denominator 4 + "Divisor by which to reduce message buffer size. +When the maximum size for the nREPL message buffer is exceeded, the size of +the buffer is reduced by one over this value. Defaults to 4, so that 1/4 +of the buffer is removed, which should ensure the buffer's maximum is +reasonably utilized, while limiting the number of buffer shrinking +operations.") + +(defvar nrepl-messages-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "n") #'next-line) + (define-key map (kbd "p") #'previous-line) + (define-key map (kbd "TAB") #'forward-button) + (define-key map (kbd "RET") #'nrepl-log-expand-button) + (define-key map (kbd "e") #'nrepl-log-expand-button) + (define-key map (kbd "E") #'nrepl-log-expand-all-buttons) + (define-key map (kbd "") #'backward-button) + map)) + +(define-derived-mode nrepl-messages-mode special-mode "nREPL Messages" + "Major mode for displaying nREPL messages. + +\\{nrepl-messages-mode-map}" + (setq buffer-read-only t) + (when cider-special-mode-truncate-lines + (setq-local truncate-lines t)) + (setq-local electric-indent-chars nil) + (setq-local comment-start ";") + (setq-local comment-end "") + (setq-local paragraph-start "(-->\\|(<--") + (setq-local paragraph-separate "(<--")) + +(defun nrepl-decorate-msg (msg type) + "Decorate nREPL MSG according to its TYPE." + (pcase type + (`request (cons '--> (cdr msg))) + (`response (cons '<-- (cdr msg))))) + +(defun nrepl-log-message (msg type) + "Log the nREPL MSG. +TYPE is either request or response. The message is logged to a buffer +described by `nrepl-message-buffer-name-template'." + (when nrepl-log-messages + (with-current-buffer (nrepl-messages-buffer (current-buffer)) + (setq buffer-read-only nil) + (when (> (buffer-size) nrepl-message-buffer-max-size) + (goto-char (/ (buffer-size) nrepl-message-buffer-reduce-denominator)) + (re-search-forward "^(" nil t) + (delete-region (point-min) (- (point) 1))) + (goto-char (point-max)) + (nrepl-log-pp-object (nrepl-decorate-msg msg type) + (nrepl-log--message-color (lax-plist-get (cdr msg) "id")) + t) + (when-let ((win (get-buffer-window))) + (set-window-point win (point-max))) + (setq buffer-read-only t)))) + +(defun nrepl-toggle-message-logging () + "Toggle the value of `nrepl-log-messages' between nil and t. + +This in effect enables or disables the logging of nREPL messages." + (interactive) + (setq nrepl-log-messages (not nrepl-log-messages)) + (if nrepl-log-messages + (message "nREPL message logging enabled") + (message "nREPL message logging disabled"))) + +(defcustom nrepl-message-colors + '("red" "brown" "coral" "orange" "green" "deep sky blue" "blue" "dark violet") + "Colors used in `nrepl-messages-buffer'." + :type '(repeat color) + :group 'nrepl) + +(defun nrepl-log-expand-button (&optional button) + "Expand the objects hidden in BUTTON's :nrepl-object property. +BUTTON defaults the button at point." + (interactive) + (if-let ((button (or button (button-at (point))))) + (let* ((start (overlay-start button)) + (end (overlay-end button)) + (obj (overlay-get button :nrepl-object)) + (inhibit-read-only t)) + (save-excursion + (goto-char start) + (delete-overlay button) + (delete-region start end) + (nrepl-log-pp-object obj) + (delete-char -1))) + (error "No button at point"))) + +(defun nrepl-log-expand-all-buttons () + "Expand all buttons in nREPL log buffer." + (interactive) + (if (not (eq major-mode 'nrepl-messages-mode)) + (user-error "Not in a `nrepl-messages-mode'") + (save-excursion + (let* ((pos (point-min)) + (button (next-button pos))) + (while button + (setq pos (overlay-start button)) + (nrepl-log-expand-button button) + (setq button (next-button pos))))))) + +(defun nrepl-log--expand-button-mouse (event) + "Expand the text hidden under overlay button. +EVENT gives the button position on window." + (interactive "e") + (pcase (elt event 1) + (`(,window ,_ ,_ ,_ ,_ ,point . ,_) + (with-selected-window window + (nrepl-log-expand-button (button-at point)))))) + +(defun nrepl-log-insert-button (label object) + "Insert button with LABEL and :nrepl-object property as OBJECT." + (insert-button label + :nrepl-object object + 'action #'nrepl-log-expand-button + 'face 'link + 'help-echo "RET: Expand object." + ;; Workaround for bug#1568 (don't use local-map here; it + ;; overwrites major mode map.) + 'keymap `(keymap (mouse-1 . nrepl-log--expand-button-mouse))) + (insert "\n")) + +(defun nrepl-log--message-color (id) + "Return the color to use when pretty-printing the nREPL message with ID. +If ID is nil, return nil." + (when id + (thread-first (string-to-number id) + (mod (length nrepl-message-colors)) + (nth nrepl-message-colors)))) + +(defun nrepl-log--pp-listlike (object &optional foreground button) + "Pretty print nREPL list like OBJECT. +FOREGROUND and BUTTON are as in `nrepl-log-pp-object'." + (cl-flet ((color (str) + (propertize str 'face + (append '(:weight ultra-bold) + (when foreground `(:foreground ,foreground)))))) + (let ((head (format "(%s" (car object)))) + (insert (color head)) + (let ((indent (+ 2 (- (current-column) (length head)))) + (l (point))) + (if (null (cdr object)) + (insert ")\n") + (insert " \n") + (cl-loop for l on (cdr object) by #'cddr + do (let ((str (format "%s%s " (make-string indent ?\s) + (propertize (car l) 'face + ;; Only highlight top-level keys. + (unless (eq (car object) 'dict) + 'font-lock-keyword-face))))) + (insert str) + (nrepl-log-pp-object (cadr l) nil button))) + (when (eq (car object) 'dict) + (delete-char -1)) + (insert (color ")\n"))))))) + +(defun nrepl-log-pp-object (object &optional foreground button) + "Pretty print nREPL OBJECT, delimited using FOREGROUND. +If BUTTON is non-nil, try making a button from OBJECT instead of inserting +it into the buffer." + (let ((min-dict-fold-size 1) + (min-list-fold-size 10) + (min-string-fold-size 60)) + (if-let ((head (car-safe object))) + ;; list-like objects + (cond + ;; top level dicts (always expanded) + ((memq head '(<-- -->)) + (nrepl-log--pp-listlike object foreground button)) + ;; inner dicts + ((eq head 'dict) + (if (and button (> (length object) min-dict-fold-size)) + (nrepl-log-insert-button "(dict ...)" object) + (nrepl-log--pp-listlike object foreground button))) + ;; lists + (t + (if (and button (> (length object) min-list-fold-size)) + (nrepl-log-insert-button (format "(%s ...)" (prin1-to-string head)) object) + (pp object (current-buffer))))) + ;; non-list objects + (if (stringp object) + (if (and button (> (length object) min-string-fold-size)) + (nrepl-log-insert-button (format "\"%s...\"" (substring object 0 min-string-fold-size)) object) + (insert (prin1-to-string object) "\n")) + (pp object (current-buffer)) + (insert "\n"))))) + +(defun nrepl-messages-buffer-name (conn) + "Return the name for the message buffer matching CONN." + (format nrepl-message-buffer-name-template (nrepl-connection-identifier conn))) + +(defun nrepl-messages-buffer (conn) + "Return or create the buffer for CONN. +The default buffer name is *nrepl-messages connection*." + (let ((msg-buffer-name (nrepl-messages-buffer-name conn))) + (or (get-buffer msg-buffer-name) + (let ((buffer (get-buffer-create msg-buffer-name))) + (with-current-buffer buffer + (buffer-disable-undo) + (nrepl-messages-mode) + buffer))))) + +(defun nrepl-error-buffer () + "Return or create the buffer. +The default buffer name is *nrepl-error*." + (or (get-buffer nrepl-error-buffer-name) + (let ((buffer (get-buffer-create nrepl-error-buffer-name))) + (with-current-buffer buffer + (buffer-disable-undo) + (fundamental-mode) + buffer)))) + +(defun nrepl-log-error (msg) + "Log the given MSG to the buffer given by `nrepl-error-buffer'." + (with-current-buffer (nrepl-error-buffer) + (setq buffer-read-only nil) + (goto-char (point-max)) + (insert msg) + (when-let ((win (get-buffer-window))) + (set-window-point win (point-max))) + (setq buffer-read-only t))) + +(defun nrepl-create-client-buffer-default (endpoint) + "Create an nREPL client process buffer. +ENDPOINT is a plist returned by `nrepl-connect'." + (let ((buffer (generate-new-buffer + (nrepl-connection-buffer-name default-directory + (plist-get endpoint :host) + (plist-get endpoint :port))))) + (with-current-buffer buffer + (buffer-disable-undo) + (setq-local kill-buffer-query-functions nil)) + buffer)) + +(provide 'nrepl-client) + +;;; nrepl-client.el ends here diff --git a/elpa/cider-20170129.1941/nrepl-dict.el b/elpa/cider-20170129.1941/nrepl-dict.el new file mode 100644 index 00000000..afdaece5 --- /dev/null +++ b/elpa/cider-20170129.1941/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-2017 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/circe-20161102.1405/circe-autoloads.el b/elpa/circe-20161102.1405/circe-autoloads.el new file mode 100644 index 00000000..ed85f661 --- /dev/null +++ b/elpa/circe-20161102.1405/circe-autoloads.el @@ -0,0 +1,223 @@ +;;; circe-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path)))) + +;;;### (autoloads nil "circe" "circe.el" (22555 30982 0 0)) +;;; Generated autoloads from circe.el + +(autoload 'circe-version "circe" "\ +Display Circe's version. + +\(fn)" t nil) + +(autoload 'circe "circe" "\ +Connect to IRC. + +Connect to the given network specified by NETWORK-OR-SERVER. + +When this function is called, it collects options from the +SERVER-OPTIONS argument, the user variable +`circe-network-options', and the defaults found in +`circe-network-defaults', in this order. + +If NETWORK-OR-SERVER is not found in any of these variables, the +argument is assumed to be the host name for the server, and all +relevant settings must be passed via SERVER-OPTIONS. + +All SERVER-OPTIONS are treated as variables by getting the string +\"circe-\" prepended to their name. This variable is then set +locally in the server buffer. + +See `circe-network-options' for a list of common options. + +\(fn NETWORK-OR-SERVER &rest SERVER-OPTIONS)" t nil) + +;;;*** + +;;;### (autoloads nil "circe-color-nicks" "circe-color-nicks.el" +;;;;;; (22555 30982 0 0)) +;;; Generated autoloads from circe-color-nicks.el + +(autoload 'enable-circe-color-nicks "circe-color-nicks" "\ +Enable the Color Nicks module for Circe. +This module colors all encountered nicks in a cross-server fashion. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "circe-highlight-all-nicks" "circe-highlight-all-nicks.el" +;;;;;; (22555 30982 0 0)) +;;; Generated autoloads from circe-highlight-all-nicks.el + +(autoload 'enable-circe-highlight-all-nicks "circe-highlight-all-nicks" "\ +Enable the Highlight Nicks module for Circe. +This module highlights all occurances of nicks in the current +channel in messages of other people. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "circe-lagmon" "circe-lagmon.el" (22555 30982 +;;;;;; 0 0)) +;;; Generated autoloads from circe-lagmon.el + +(defvar circe-lagmon-mode nil "\ +Non-nil if Circe-Lagmon mode is enabled. +See the `circe-lagmon-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `circe-lagmon-mode'.") + +(custom-autoload 'circe-lagmon-mode "circe-lagmon" nil) + +(autoload 'circe-lagmon-mode "circe-lagmon" "\ +Circe-lagmon-mode monitors the amount of lag on your +connection to each server, and displays the lag time in seconds +in the mode-line. + +\(fn &optional ARG)" t nil) + +;;;*** + +;;;### (autoloads nil "circe-new-day-notifier" "circe-new-day-notifier.el" +;;;;;; (22555 30982 0 0)) +;;; Generated autoloads from circe-new-day-notifier.el + +(autoload 'enable-circe-new-day-notifier "circe-new-day-notifier" "\ + + +\(fn)" t nil) + +(autoload 'disable-circe-new-day-notifier "circe-new-day-notifier" "\ + + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "lui-autopaste" "lui-autopaste.el" (22555 30982 +;;;;;; 0 0)) +;;; Generated autoloads from lui-autopaste.el + +(autoload 'enable-lui-autopaste "lui-autopaste" "\ +Enable the lui autopaste feature. + +If you enter more than `lui-autopaste-lines' at once, Lui will +ask if you would prefer to use a paste service instead. If you +agree, Lui will paste your input to `lui-autopaste-function' and +replace it with the resulting URL. + +\(fn)" t nil) + +(autoload 'disable-lui-autopaste "lui-autopaste" "\ +Disable the lui autopaste feature. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "lui-irc-colors" "lui-irc-colors.el" (22555 +;;;;;; 30982 0 0)) +;;; Generated autoloads from lui-irc-colors.el + +(autoload 'enable-lui-irc-colors "lui-irc-colors" "\ +Enable IRC color interpretation for Lui. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "lui-track-bar" "lui-track-bar.el" (22555 30982 +;;;;;; 0 0)) +;;; Generated autoloads from lui-track-bar.el + +(autoload 'enable-lui-track-bar "lui-track-bar" "\ +Enable a bar in Lui buffers that shows where you stopped reading. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil "shorten" "shorten.el" (22555 30982 0 0)) +;;; Generated autoloads from shorten.el + +(autoload 'shorten-strings "shorten" "\ +Takes a list of strings and returns an alist ((STRING +. SHORTENED-STRING) ...). Uses `shorten-split-function' to split +the strings, and `shorten-join-function' to join shortened +components back together into SHORTENED-STRING. See also +`shorten-validate-component-function'. + +\(fn STRINGS)" nil nil) + +;;;*** + +;;;### (autoloads nil "tracking" "tracking.el" (22555 30982 0 0)) +;;; Generated autoloads from tracking.el + +(defvar tracking-mode nil "\ +Non-nil if Tracking mode is enabled. +See the `tracking-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `tracking-mode'.") + +(custom-autoload 'tracking-mode "tracking" nil) + +(autoload 'tracking-mode "tracking" "\ +Allow cycling through modified buffers. +This mode in itself does not track buffer modification, but +provides an API for programs to add buffers as modified (using +`tracking-add-buffer'). + +Once this mode is active, modified buffers are shown in the mode +line. The user can cycle through them using +\\[tracking-next-buffer]. + +\(fn &optional ARG)" t nil) + +(autoload 'tracking-add-buffer "tracking" "\ +Add BUFFER as being modified with FACES. +This does check whether BUFFER is currently visible. + +If FACES is given, it lists the faces that might be appropriate +for BUFFER in the mode line. The highest-priority face of these +and the current face of the buffer, if any, is used. Priority is +decided according to `tracking-faces-priorities'. + +\(fn BUFFER &optional FACES)" nil nil) + +(autoload 'tracking-remove-buffer "tracking" "\ +Remove BUFFER from being tracked. + +\(fn BUFFER)" nil nil) + +(autoload 'tracking-next-buffer "tracking" "\ +Switch to the next active buffer. + +\(fn)" t nil) + +(autoload 'tracking-previous-buffer "tracking" "\ +Switch to the last active buffer. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil nil ("circe-chanop.el" "circe-compat.el" "circe-pkg.el" +;;;;;; "irc.el" "lcs.el" "lui-format.el" "lui-logging.el" "lui.el" +;;;;;; "make-tls-process.el") (22555 30982 0 0)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; circe-autoloads.el ends here diff --git a/elpa/circe-20161102.1405/circe-chanop.el b/elpa/circe-20161102.1405/circe-chanop.el new file mode 100644 index 00000000..a5880e5f --- /dev/null +++ b/elpa/circe-20161102.1405/circe-chanop.el @@ -0,0 +1,97 @@ +;;; circe-chanop.el --- Provide common channel operator commands + +;; Copyright (C) 2006, 2015 Jorgen Schaefer + +;; Author: Jorgen Schaefer + +;; This file is part of Circe. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; This Circe module provides some often-used chanop commands. I was +;; very reluctant to add this. None of these commands will make it in +;; the core, or even be provided by default. You should have to go to +;; great lengths to use them. + +;; Always remember the Tao of IRC: +;; +;; IGNORE is the weapon of an IRC knight. Not as clumsy or as +;; random as a kickban. + +;;; Code: + +(require 'circe) + +(defun circe-command-MODE (mode) + "Set MODE in the current channel." + (interactive "sMode change: ") + (cond + ((not (string-match "^[+-]" mode)) + (irc-send-raw (circe-server-process) + (format "MODE %s" mode))) + ((eq major-mode 'circe-channel-mode) + (irc-send-raw (circe-server-process) + (format "MODE %s %s" circe-chat-target mode))) + (t + (circe-display-server-message "Not in a channel buffer.")))) + +(defun circe-command-BANS (&optional ignored) + "Show channel bans" + (if (not circe-chat-target) + (circe-display-server-message "No target for current buffer") + (irc-send-raw (circe-server-process) + (format "MODE %s +b" circe-chat-target)))) + +(defun circe-command-KICK (nick &optional reason) + "Kick WHO from the current channel with optional REASON." + (interactive "sKick who: \nsWhy: ") + (if (not (eq major-mode 'circe-channel-mode)) + (circe-display-server-message "Not in a channel buffer.") + (when (not reason) + (if (string-match "^\\([^ ]*\\) +\\(.+\\)" nick) + (setq reason (match-string 2 nick) + nick (match-string 1 nick)) + (setq reason "-"))) + (irc-send-raw (circe-server-process) + (format "KICK %s %s :%s" + circe-chat-target nick reason)))) + +(defun circe-command-GETOP (&optional ignored) + "Ask chanserv for op on the current channel." + (interactive) + (if (not (eq major-mode 'circe-channel-mode)) + (circe-display-server-message "Not in a channel buffer.") + (irc-send-PRIVMSG (circe-server-process) + "chanserv" + (format "op %s" circe-chat-target)))) + +(defun circe-command-DROPOP (&optional ignored) + "Lose op mode on the current channel." + (interactive) + (if (not (eq major-mode 'circe-channel-mode)) + (circe-display-server-message "Not in a channel buffer.") + (irc-send-raw (circe-server-process) + (format "MODE %s -o %s" + circe-chat-target + (circe-nick))))) + +;; For KICKBAN (requested by Riastradh), we'd need a callback on a +;; USERHOST command. + +(provide 'circe-chanop) +;;; circe-chanop.el ends here diff --git a/elpa/circe-20161102.1405/circe-color-nicks.el b/elpa/circe-20161102.1405/circe-color-nicks.el new file mode 100644 index 00000000..409af627 --- /dev/null +++ b/elpa/circe-20161102.1405/circe-color-nicks.el @@ -0,0 +1,345 @@ +;;; circe-color-nicks.el --- Color nicks in the channel + +;; Copyright (C) 2012 Taylan Ulrich Bayırlı/Kammer + +;; Author: Taylan Ulrich Bayırlı/Kammer + +;; This file is part of Circe. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; This Circe module adds the ability to assign a color to each +;; nick in a channel. + +;; Some ideas/code copied from rcirc-colors.el. + +;; To use it, put the following into your .emacs: + +;; (require 'circe-color-nicks) +;; (enable-circe-color-nicks) + +;;; Code: + +(require 'circe) +(require 'color) +(require 'cl-lib) + +;;;###autoload +(defun enable-circe-color-nicks () + "Enable the Color Nicks module for Circe. +This module colors all encountered nicks in a cross-server fashion." + (interactive) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (eq major-mode 'circe-channel-mode) + (add-circe-color-nicks)))) + (add-hook 'circe-channel-mode-hook + 'add-circe-color-nicks)) + +(defun disable-circe-color-nicks () + "Disable the Color Nicks module for Circe. +See `enable-circe-color-nicks'." + (interactive) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (eq major-mode 'circe-channel-mode) + (remove-circe-color-nicks)))) + (remove-hook 'circe-channel-mode-hook + 'add-circe-color-nicks)) + +(defun add-circe-color-nicks () + "Add `circe-color-nicks' to `lui-pre-output-hook'." + (add-hook 'lui-pre-output-hook 'circe-color-nicks)) + +(defun remove-circe-color-nicks () + "Remove `circe-color-nicks' from `lui-pre-output-hook'." + (remove-hook 'lui-pre-output-hook 'circe-color-nicks)) + + +(defgroup circe-color-nicks nil + "Nicks colorization for Circe" + :prefix "circe-color-nicks-" + :group 'circe) + +(defcustom circe-color-nicks-min-contrast-ratio 7 + "Minimum contrast ratio from background for generated colors; +recommended is 7:1, or at least 4.5:1 (7 stands for 7:1 here). +Lower value allows higher color spread, but could lead to less +readability." + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-min-difference 17 + "Minimum difference from each other for generated colors." + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-min-fg-difference 17 + "Minimum difference from foreground for generated colors." + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-min-my-message-difference 0 + "Minimum difference from own nick color for generated colors." + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-everywhere nil + "Whether nicks should be colored in message bodies too." + :type 'boolean + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-message-blacklist nil + "Blacklist for nicks that shall never be highlighted inside + images." + :type '(repeat string) + :group 'circe-color-nicks) + +(defcustom circe-color-nicks-pool-type 'adaptive + "Type of the color nick pool. +Must be one of the following: + +'adaptive: Generate colors based on the current theme. + +List of strings: Pick colors from the specified list of hex codes +or color names (see `color-name-rgb-alist')." + :type '(choice (const :tag "Adaptive" adaptive) + (repeat string)) + :group 'circe-color-nicks) + + +;;; See http://www.w3.org/TR/2013/NOTE-WCAG20-TECHS-20130905/G18 + +(defsubst circe-w3-contrast-c-to-l (c) + (if (<= c 0.03928) + (/ c 12.92) + (expt (/ (+ c 0.055) 1.055) 2.4))) + +(defsubst circe-w3-contrast-relative-luminance (rgb) + (apply #'+ + (cl-mapcar (lambda (color coefficient) + (* coefficient + (circe-w3-contrast-c-to-l color))) + rgb + '(0.2126 0.7152 0.0722)))) + +(defsubst circe-w3-contrast-contrast-ratio (color1 color2) + (let ((l1 (+ 0.05 (circe-w3-contrast-relative-luminance color1))) + (l2 (+ 0.05 (circe-w3-contrast-relative-luminance color2)))) + (if (> l1 l2) + (/ l1 l2) + (/ l2 l1)))) + + +(defun circe-color-alist () + "Return list of colors (name rgb lab) where rgb is 0 to 1." + (let ((alist (if (display-graphic-p) + color-name-rgb-alist + (mapcar (lambda (c) + (cons (car c) (cddr c))) + (tty-color-alist)))) + (valmax (float (car (color-values "#ffffff"))))) + (mapcar (lambda (c) + (let* ((name (car c)) + (rgb (mapcar (lambda (v) + (/ v valmax)) + (cdr c))) + (lab (apply #'color-srgb-to-lab rgb))) + (list name rgb lab))) + alist))) + +(defun circe-color-canonicalize-format (color) + "Turns COLOR into (name rgb lab) format. Avoid calling this in +a loop, it's very slow on a tty!" + (let* ((name color) + (rgb (circe-color-name-to-rgb color)) + (lab (apply #'color-srgb-to-lab rgb))) + (list name rgb lab))) + +(defun circe-color-contrast-ratio (color1 color2) + "Gives the contrast ratio between two colors." + (circe-w3-contrast-contrast-ratio (nth 1 color1) (nth 1 color2))) + +(defun circe-color-diff (color1 color2) + "Gives the difference between two colors per CIEDE2000." + (color-cie-de2000 (nth 2 color1) (nth 2 color2))) + +(defun circe-color-name-to-rgb (color) + "Like `color-name-to-rgb' but also handles \"unspecified-bg\" +and \"unspecified-fg\"." + (cond ((equal color "unspecified-bg") '(0 0 0)) + ((equal color "unspecified-fg") '(1 1 1)) + (t (color-name-to-rgb color)))) + + +(defun circe-nick-color-appropriate-p (color bg fg my-msg) + "Tells whether COLOR is appropriate for being a nick color. +BG, FG, and MY-MSG are the background, foreground, and my-message +colors; these are expected as parameters instead of computed here +because computing them repeatedly is a heavy operation." + (and (>= (circe-color-contrast-ratio color bg) + circe-color-nicks-min-contrast-ratio) + (>= (circe-color-diff color fg) + circe-color-nicks-min-fg-difference) + (>= (circe-color-diff color my-msg) + circe-color-nicks-min-my-message-difference))) + +(defun circe-nick-colors-delete-similar (colors) + "Return list COLORS with pairs of colors filtered out that are +too similar per `circe-color-nicks-min-difference'. COLORS may +be mutated." + (cl-mapl (lambda (rest) + (let ((color (car rest))) + (setcdr rest (cl-delete-if + (lambda (c) + (< (circe-color-diff color c) + circe-color-nicks-min-difference)) + (cdr rest))))) + colors) + colors) + +(defun circe-nick-color-generate-pool () + "Return a list of appropriate nick colors." + (if (consp circe-color-nicks-pool-type) + circe-color-nicks-pool-type + (let ((bg (circe-color-canonicalize-format (face-background 'default))) + (fg (circe-color-canonicalize-format (face-foreground 'default))) + (my-msg (circe-color-canonicalize-format + (face-attribute + 'circe-my-message-face :foreground nil 'default)))) + (mapcar #'car (circe-nick-colors-delete-similar + (cl-remove-if-not + (lambda (c) + (circe-nick-color-appropriate-p c bg fg my-msg)) + (circe-color-alist))))))) + +(defun circe-nick-color-pool-test () + "Display all appropriate nick colors in a temp buffer." + (interactive) + (switch-to-buffer (get-buffer-create "*Circe color test*")) + (erase-buffer) + (let ((pool (circe-nick-color-generate-pool))) + (while pool + (let ((pt (point))) + (insert "The quick brown fox jumped over the lazy dog.\n") + (put-text-property pt (point) 'face `(:foreground ,(pop pool))))))) + +(defvar circe-nick-color-pool nil + "Pool of yet unused nick colors.") + +(defvar circe-nick-color-mapping (make-hash-table :test 'equal) + "Hash-table from nicks to colors.") + +(defun circe-nick-color-nick-list () + "Return list of all nicks that have a color assigned to them. +Own and blacklisted nicks are excluded." + (let ((our-nick (circe-nick)) + (channel-nicks (circe-channel-nicks)) + nicks) + (maphash + (lambda (nick color) + (when (and (member nick channel-nicks) + (not (string= our-nick nick)) + (not (member nick circe-color-nicks-message-blacklist))) + (push nick nicks))) + circe-nick-color-mapping) + nicks)) + +(defvar circe-nick-color-timestamps (make-hash-table :test 'equal) + "Hash-table from colors to the timestamp of their last use.") + +(defun circe-nick-color-for-nick (nick) + "Return the color for NICK. Assigns a color to NICK if one +wasn't assigned already." + (let ((color (gethash nick circe-nick-color-mapping))) + (when (not color) + ;; NOTE use this as entry point for taking NICK into account for + ;; picking the new color + (setq color (circe-nick-color-pick)) + (puthash nick color circe-nick-color-mapping)) + (puthash color (float-time) circe-nick-color-timestamps) + color)) + +(defun circe-nick-color-pick () + "Picks either a color from the pool of unused colors, or the +color that was used least recently (i.e. nicks that have it +assigned have been least recently active)." + (if (zerop (hash-table-count circe-nick-color-mapping)) + (setq circe-nick-color-pool (circe-nick-color-generate-pool))) + (or (pop circe-nick-color-pool) + (circe-nick-color-pick-least-recent))) + +(defun circe-nick-color-pick-least-recent () + "Pick the color that was used least recently. +See `circe-nick-color-pick', which is where this is used." + (let ((least-recent-color nil) + (oldest-time (float-time))) + (maphash + (lambda (color time) + (if (< time oldest-time) + (progn + (setq least-recent-color color) + (setq oldest-time time)))) + circe-nick-color-timestamps) + (if least-recent-color + least-recent-color + ;; Someone must have messed with `circe-nick-color-mapping', recover by + ;; re-filling the pool. + (setq circe-nick-color-pool (circe-nick-color-generate-pool)) + (pop circe-nick-color-pool)))) + +(defun circe-color-nicks () + "Color nicks on this lui output line." + (when (eq major-mode 'circe-channel-mode) + (let ((nickstart (text-property-any (point-min) (point-max) + 'lui-format-argument 'nick))) + (when nickstart + (goto-char nickstart) + (let ((nickend (next-single-property-change nickstart + 'lui-format-argument)) + (nick (plist-get (plist-get (text-properties-at nickstart) + 'lui-keywords) + :nick))) + (when (not (circe-server-my-nick-p nick)) + (let ((color (circe-nick-color-for-nick nick))) + (add-face-text-property nickstart nickend + `(:foreground ,color))))))) + (when circe-color-nicks-everywhere + (let ((body (text-property-any (point-min) (point-max) + 'lui-format-argument 'body))) + (when body + (with-syntax-table circe-nick-syntax-table + (goto-char body) + (let* ((nicks (circe-nick-color-nick-list)) + (regex (regexp-opt nicks 'words))) + (let (case-fold-search) + (while (re-search-forward regex nil t) + (let* ((nick (match-string-no-properties 0)) + (color (circe-nick-color-for-nick nick))) + (add-face-text-property (match-beginning 0) (match-end 0) + `(:foreground ,color)))))))))))) + +(defun circe-nick-color-reset () + "Reset the nick color mapping (and some internal data). + +This is useful if you switched between frames supporting +different color ranges and would like nicks to get new colors +appropriate to the new color range." + (interactive) + (setq circe-nick-color-pool (circe-nick-color-generate-pool)) + (setq circe-nick-color-mapping (make-hash-table :test 'equal)) + (setq circe-nick-color-timestamps (make-hash-table :test 'equal))) + +(provide 'circe-color-nicks) +;;; circe-color-nicks.el ends here diff --git a/elpa/circe-20161102.1405/circe-compat.el b/elpa/circe-20161102.1405/circe-compat.el new file mode 100644 index 00000000..f509c66d --- /dev/null +++ b/elpa/circe-20161102.1405/circe-compat.el @@ -0,0 +1,53 @@ +;;; circe-compat.el --- Compatibility definitions + +;; Copyright (C) 2015 Jorgen Schaefer + +;; Author: Jorgen Schaefer + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General 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: + +;; Define functions and variables as needed by Circe to remain +;; compatible with older Emacsen. + +;;; Code: + +(when (not (fboundp 'string-trim)) + (defun string-trim (string) + "Remove leading and trailing whitespace from STRING." + (if (string-match "\\` *\\(.*[^[:space:]]\\) *\\'" string) + (match-string 1 string) + string))) + +(when (not (fboundp 'add-face-text-property)) + (defun add-face-text-property (start end face &optional append object) + (while (/= start end) + (let* ((next (next-single-property-change start 'face object end)) + (prev (get-text-property start 'face object)) + (value (if (listp prev) prev (list prev)))) + (put-text-property start next 'face + (if append + (append value (list face)) + (append (list face) value)) + object) + (setq start next))))) + +(when (not (boundp 'mode-line-misc-info)) + (defvar mode-line-misc-info nil + "Misc info in the mode line.") + (add-to-list 'mode-line-format 'mode-line-misc-info t)) + +(provide 'circe-compat) +;;; circe-compat.el ends here diff --git a/elpa/circe-20161102.1405/circe-highlight-all-nicks.el b/elpa/circe-20161102.1405/circe-highlight-all-nicks.el new file mode 100644 index 00000000..e06098c9 --- /dev/null +++ b/elpa/circe-20161102.1405/circe-highlight-all-nicks.el @@ -0,0 +1,100 @@ +;;; circe-highlight-all-nicks.el --- Highlight all nicks in the current channel + +;; Copyright (C) 2005 Jorgen Schaefer + +;; Author: Jorgen Schaefer + +;; This file is part of Circe. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; This Circe module adds the ability to highlight every occurance of +;; a nick in the current channel in a message by other people. + +;; To use it, put the following into your .emacs: + +;; (require 'circe-highlight-all-nicks) +;; (enable-circe-highlight-all-nicks) + +;;; Code: + +(require 'circe) + +(defface circe-highlight-all-nicks-face + '((t (:foreground "green"))) + "The face used for nicks from the current channel. +See `enable-circe-highlight-all-nicks'." + :group 'circe) + +;;;###autoload +(defun enable-circe-highlight-all-nicks () + "Enable the Highlight Nicks module for Circe. +This module highlights all occurances of nicks in the current +channel in messages of other people." + (interactive) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (eq major-mode 'circe-channel-mode) + (add-circe-highlight-all-nicks)))) + (add-hook 'circe-channel-mode-hook + 'add-circe-highlight-all-nicks)) + +(defun disable-circe-highlight-all-nicks () + "Disable the Highlight Nicks module for Circe. +See `enable-circe-highlight-all-nicks'." + (interactive) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (eq major-mode 'circe-channel-mode) + (remove-circe-highlight-all-nicks)))) + (remove-hook 'circe-channel-mode-hook + 'add-circe-highlight-all-nicks)) + +(defun add-circe-highlight-all-nicks () + "Add `circe-highlight-all-nicks' to `lui-pre-output-hook'." + (add-hook 'lui-pre-output-hook 'circe-highlight-all-nicks + nil t)) + +(defun remove-circe-highlight-all-nicks () + "Remove `circe-highlight-all-nicks' from `lui-pre-output-hook'." + (remove-hook 'lui-pre-output-hook 'circe-highlight-all-nicks + t)) + +(defun circe-highlight-all-nicks () + "Highlight all occurances of nicks of the current channel in the message." + (when (eq major-mode 'circe-channel-mode) + (let ((body (text-property-any (point-min) (point-max) + 'lui-format-argument 'body)) + (nicks '()) + (regex nil)) + (when body + (let ((channel-nicks (circe-channel-nicks))) + (when channel-nicks + (mapc (lambda (nick) + (when (not (circe-server-my-nick-p nick)) + (setq nicks (cons nick nicks)))) + channel-nicks))) + (setq regex (regexp-opt nicks 'words)) + (goto-char body) + (while (re-search-forward regex nil t) + (add-text-properties (match-beginning 0) + (match-end 0) + '(face circe-highlight-all-nicks-face))))))) + +(provide 'circe-highlight-all-nicks) +;;; circe-highlight-all-nicks.el ends here diff --git a/elpa/circe-20161102.1405/circe-lagmon.el b/elpa/circe-20161102.1405/circe-lagmon.el new file mode 100644 index 00000000..42a37329 --- /dev/null +++ b/elpa/circe-20161102.1405/circe-lagmon.el @@ -0,0 +1,243 @@ +;;; circe-lagmon.el --- Lag Monitor for Circe + +;; Copyright (C) 2011-2012 Jorgen Schaefer + +;; Author: John J Foerch , +;; Jorgen Schaefer + +;; This file is part of Circe. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301, USA. + +;;; Commentary: +;;; +;;; Circe-lagmon-mode monitors the amount of lag on your connection to +;;; each server, and displays the lag time in seconds in the mode-line. +;;; It works by managing two timers. Timer1 sends CTCP LAGMON to yourself +;;; on each server every 60 seconds. Each time around, timer1 starts +;;; timer2 to monitor for timeouts of these messages. Timer2 cancels +;;; itself when all of the pings in the round have been answered. +;;; + +;;; Code: + +(require 'circe) + +;;; User variables + +(defgroup circe-lagmon nil + "Lag Monitor for Circe" + :prefix "circe-lagmon-" + :group 'circe) + +(defcustom circe-lagmon-timer-tick 5 + "How often to check for lag. + +Increase this to improve performance at the cost of accuracy." + :type 'number + :group 'circe-lagmon) + +(defcustom circe-lagmon-check-interval 60 + "Interval in seconds at which to send the CTCP message." + :type 'number + :group 'circe-lagmon) + +(defcustom circe-lagmon-reconnect-interval 120 + "Seconds after which to automatically reconnect upon a timeout +of a lag monitor message. A value of nil disables the feature." + :type '(choice (const :tag "Disable auto-reconnect" nil) + number) + :group 'circe-lagmon) + +(defcustom circe-lagmon-mode-line-format-string "lag:%.1f " + "Format string for displaying the lag in the mode-line." + :type 'string + :group 'circe-lagmon) + +(defcustom circe-lagmon-mode-line-unknown-lag-string "lag:? " + "Indicator string for displaying unknown lag in the mode-line." + :type 'string + :group 'circe-lagmon) + +(defvar circe-lagmon-disabled nil + "A boolean value if lagmon should be disabled on this network. + +Don't set this by hand, use `circe-network-options'.") +(make-variable-buffer-local 'circe-lagmon-disabled) + + +;;; Internal variables +;;; +(defvar circe-lagmon-timer nil) + +(defvar circe-lagmon-server-lag nil) +(make-variable-buffer-local 'circe-lagmon-server-lag) + +(defvar circe-lagmon-last-send-time nil) +(make-variable-buffer-local 'circe-lagmon-last-send-time) + +(defvar circe-lagmon-last-receive-time nil) +(make-variable-buffer-local 'circe-lagmon-last-receive-time) + +(defun circe-lagmon-timer-tick () + "Function run periodically to check lag. + +This will call `circe-lagmon-server-check' in every active server +buffer. You can call it yourself if you like to force an update, +there is no harm in running it too often, but it really should be +run sufficiently often with the timer." + (dolist (buffer (circe-server-buffers)) + (with-current-buffer buffer + (when (and (eq major-mode 'circe-server-mode) + circe-server-process + (eq (irc-connection-state circe-server-process) + 'registered) + (not circe-lagmon-disabled)) + (circe-lagmon-server-check))))) + +(defun circe-lagmon-server-check () + "Check the current server for lag. + +This will reconnect if we haven't heard back for too long, or +send a request if it's time for that. See +`circe-lagmon-reconnect-interval' and +`circe-lagmon-check-interval' to configure the behavior.." + (let ((now (float-time))) + (cond + ;; No answer so far... + ((and circe-lagmon-last-send-time + (not circe-lagmon-last-receive-time)) + ;; Count up until the answer comes. + (let ((lag (/ (- now circe-lagmon-last-send-time) 2))) + (when (or (not circe-lagmon-server-lag) + (> lag circe-lagmon-server-lag)) + (setq circe-lagmon-server-lag lag) + (circe-lagmon-force-mode-line-update))) + ;; Check for timeout. + (when (and circe-lagmon-reconnect-interval + (> now + (+ circe-lagmon-last-send-time + circe-lagmon-reconnect-interval))) + (setq circe-lagmon-last-send-time nil + circe-lagmon-last-receive-time nil) + (circe-reconnect))) + ;; Nothing sent so far, or last send was too long ago. + ((or (not circe-lagmon-last-send-time) + (> now + (+ circe-lagmon-last-send-time + circe-lagmon-check-interval))) + (irc-send-raw (circe-server-process) + (format "PRIVMSG %s :\C-aLAGMON %s\C-a" + (circe-nick) now) + :nowait) + (setq circe-lagmon-last-send-time now + circe-lagmon-last-receive-time nil)) + ))) + +(defun circe-lagmon-force-mode-line-update () + "Call force-mode-line-update on a circe server buffer and all +of its chat buffers." + (force-mode-line-update) + (dolist (b (circe-server-chat-buffers)) + (with-current-buffer b + (force-mode-line-update)))) + +(defun circe-lagmon-format-mode-line-entry () + "Format the mode-line entry for displaying the lag." + (let ((buf (cond + ((eq major-mode 'circe-server-mode) + (current-buffer)) + (circe-server-buffer + circe-server-buffer) + (t + nil)))) + (when buf + (with-current-buffer buf + (cond + (circe-lagmon-disabled + nil) + (circe-lagmon-server-lag + (format circe-lagmon-mode-line-format-string + circe-lagmon-server-lag)) + (t + circe-lagmon-mode-line-unknown-lag-string)))))) + +(defun circe-lagmon-init () + "Initialize the values of the lag monitor for one server, and +start the lag monitor if it has not been started." + (setq circe-lagmon-server-lag nil + circe-lagmon-last-send-time nil + circe-lagmon-last-receive-time nil) + (circe-lagmon-force-mode-line-update) + (unless circe-lagmon-timer + (setq circe-lagmon-timer + (run-at-time nil circe-lagmon-timer-tick + 'circe-lagmon-timer-tick)))) + +(defun circe-lagmon--rpl-welcome-handler (conn &rest ignored) + (with-current-buffer (irc-connection-get conn :server-buffer) + (circe-lagmon-init))) + +(defun circe-lagmon--ctcp-lagmon-handler (conn event sender target argument) + (when (irc-current-nick-p conn (irc-userstring-nick sender)) + (with-current-buffer (irc-connection-get conn :server-buffer) + (let* ((now (float-time)) + (lag (/ (- now (string-to-number argument)) + 2))) + (setq circe-lagmon-server-lag lag + circe-lagmon-last-receive-time now) + (circe-lagmon-force-mode-line-update))))) + +(defun circe-lagmon--nick-handler (conn event sender new-nick) + (when (irc-current-nick-p conn (irc-userstring-nick sender)) + (with-current-buffer (irc-connection-get conn :server-buffer) + (setq circe-lagmon-last-send-time nil)))) + +;;;###autoload +(define-minor-mode circe-lagmon-mode + "Circe-lagmon-mode monitors the amount of lag on your +connection to each server, and displays the lag time in seconds +in the mode-line." + :global t + (let ((mode-line-entry '(:eval (circe-lagmon-format-mode-line-entry)))) + (remove-hook 'mode-line-modes mode-line-entry) + (let ((table (circe-irc-handler-table))) + (irc-handler-remove table "001" 'circe-lagmon--rpl-welcome-handler) + (irc-handler-remove table "irc.ctcp.LAGMON" + 'circe-lagmon--ctcp-lagmon-handler) + (irc-handler-remove table "NICK" 'circe-lagmon--nick-handler)) + (circe-set-display-handler "irc.ctcp.LAGMON" nil) + (when circe-lagmon-timer + (cancel-timer circe-lagmon-timer) + (setq circe-lagmon-timer nil)) + (when circe-lagmon-mode + (add-hook 'mode-line-modes mode-line-entry) + (let ((table (circe-irc-handler-table))) + (irc-handler-add table "001" 'circe-lagmon--rpl-welcome-handler) + (irc-handler-add table "irc.ctcp.LAGMON" + 'circe-lagmon--ctcp-lagmon-handler) + (irc-handler-add table "NICK" 'circe-lagmon--nick-handler)) + (circe-set-display-handler "irc.ctcp.LAGMON" 'circe-display-ignore) + (dolist (buffer (circe-server-buffers)) + (with-current-buffer buffer + (setq circe-lagmon-server-lag nil) + (when (and circe-server-process + (eq (irc-connection-state circe-server-process) + 'registered)) + (circe-lagmon-init))))))) + +(provide 'circe-lagmon) +;;; circe-lagmon.el ends here diff --git a/elpa/circe-20161102.1405/circe-new-day-notifier.el b/elpa/circe-20161102.1405/circe-new-day-notifier.el new file mode 100644 index 00000000..88d9a4b3 --- /dev/null +++ b/elpa/circe-20161102.1405/circe-new-day-notifier.el @@ -0,0 +1,86 @@ +;;; circe-new-day-notifier.el --- Send a message every midnight to all +;;; channels + +;; Copyright (C) 2015 Pásztor János + +;; Author: Pásztor János + +;; This file is part of Circe. + +;; This program is free software; you can 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, write to the Free Software +;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; This Circe module adds the ability to send a notification to all +;; channels every midnight + +;; Some ideas/code copied from circe-lagmon.el and +;; circe-color-nicks.el + +;; To use it, put the following into your .emacs: + +;; (require 'circe-new-day-notifier) +;; (enable-circe-new-day-notifier) + +;;; Code: + +(require 'circe) + +(defgroup circe-new-day-notifier nil + "Midnight notification to Circe" + :prefix "circe-new-day-notifier-" + :group 'circe) + +(defcustom circe-new-day-notifier-format-message "*** Day changed to {day}" + "The format string which will be printed to the channels. It +should contain {day} to print the date. See `circe-display' for +further documentation" + :type 'string + :group 'circe-new-day-notifier) + +(defcustom circe-new-day-notifier-date-format "%Y-%m-%d, %A" + "The date format, which will be used at +circe-new-day-notifier-format-message. See `format-time-string' for +documentation" + :type 'string + :group 'circe-new-day-notifier) + +(defvar circe-new-day-notifier-timer nil) + +;;;###autoload +(defun enable-circe-new-day-notifier () + (interactive) + (unless circe-new-day-notifier-timer + (setq circe-new-day-notifier-timer + (run-at-time "24:00:00" (* 24 60 60) 'circe-new-day-notification)))) + +;;;###autoload +(defun disable-circe-new-day-notifier () + (interactive) + (when circe-new-day-notifier-timer + (cancel-timer circe-new-day-notifier-timer) + (setq circe-new-day-notifier-timer nil))) + +(defun circe-new-day-notification () + "This function prints the new day notification to each query and chat buffer" + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (derived-mode-p 'circe-chat-mode) + (circe-display 'circe-new-day-notifier-format-message + :day (format-time-string circe-new-day-notifier-date-format)))))) + +(provide 'circe-new-day-notifier) +;;; circe-new-day-notifier.el ends here diff --git a/elpa/circe-20161102.1405/circe-pkg.el b/elpa/circe-20161102.1405/circe-pkg.el new file mode 100644 index 00000000..7eaaee3c --- /dev/null +++ b/elpa/circe-20161102.1405/circe-pkg.el @@ -0,0 +1,6 @@ +(define-package "circe" "20161102.1405" "Client for IRC in Emacs" + '((cl-lib "0.5")) + :url "https://github.com/jorgenschaefer/circe") +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/circe-20161102.1405/circe.el b/elpa/circe-20161102.1405/circe.el new file mode 100644 index 00000000..dbd657c6 --- /dev/null +++ b/elpa/circe-20161102.1405/circe.el @@ -0,0 +1,3590 @@ +;;; circe.el --- Client for IRC in Emacs -*- lexical-binding: t -*- + +;; Copyright (C) 2005 - 2015 Jorgen Schaefer + +;; Version: 2.3 +;; Keywords: IRC, chat +;; Author: Jorgen Schaefer +;; URL: https://github.com/jorgenschaefer/circe + +;; This file is part of Circe. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General 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: + +;; Circe is a Client for IRC in Emacs. It integrates well with the rest +;; of the editor, using standard Emacs key bindings and indicating +;; activity in channels in the status bar so it stays out of your way +;; unless you want to use it. + +;;; Code: + +(defvar circe-version "2.3" + "Circe version string.") + +(require 'circe-compat) + +(require 'ring) +(require 'timer) +(require 'lui) +(require 'lui-format) +(require 'lcs) +(require 'irc) + +;; Used to be optional. But sorry, we're in the 21st century already. +(require 'lui-irc-colors) + +;; necessary for inheriting from diff-added and diff-removed faces +(require 'diff-mode) + +(defgroup circe nil + "Yet Another Emacs IRC Client." + :prefix "circe-" + :group 'applications) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Customization Options ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;; +;;;; Faces ;;;; +;;;;;;;;;;;;;;; + +(defface circe-prompt-face + '((t (:weight bold :foreground "Black" :background "LightSeaGreen"))) + "The face for the Circe prompt." + :group 'circe) + +(defface circe-server-face + '((((type tty)) (:foreground "blue" :weight bold)) + (((background dark)) (:foreground "#5095cf")) + (((background light)) (:foreground "#3840b0")) + (t (:foreground "SteelBlue"))) + "The face used to highlight server messages." + :group 'circe) + +(defface circe-highlight-nick-face + '((default (:weight bold)) + (((type tty)) (:foreground "cyan")) + (((background dark)) (:foreground "#82e2ed")) + (((background light)) (:foreground "#0445b7")) + (t (:foreground "CadetBlue3"))) + "The face used to highlight messages directed to us." + :group 'circe) + +(defface circe-my-message-face '((t)) + "The face used to highlight our own messages." + :group 'circe) + +(defface circe-originator-face '((t)) + "The face used to highlight the originator of a message." + :group 'circe) + +(defface circe-topic-diff-new-face '((t (:inherit diff-added))) + "The face used for text added to a topic. +See the {topic-diff} parameter to `circe-format-server-topic'." + :group 'circe) + +(defface circe-topic-diff-removed-face '((t (:inherit diff-removed))) + "The face used for text removed from a topic. +See the {topic-diff} parameter to `circe-format-server-topic'." + :group 'circe) + +(defface circe-fool-face + '((((type tty)) (:foreground "grey40" :bold t)) + (t (:foreground "grey40"))) + "The face used for fools. +See `circe-fool-list'." + :group 'circe) + +;;;;;;;;;;;;;;;;;;; +;;;; Variables ;;;; +;;;;;;;;;;;;;;;;;;; + +(defcustom circe-default-nick (user-login-name) + "The default nick for circe." + :type 'string + :group 'circe) + +(defcustom circe-default-user circe-default-nick + "The default user name for circe." + :type 'string + :group 'circe) + +(defcustom circe-default-realname (if (string= (user-full-name) "") + circe-default-nick + (user-full-name)) + "The default real name for circe." + :type 'string + :group 'circe) + +(defcustom circe-default-ip-family nil + "Default IP family to use. + + 'nil - Use either IPv4 or IPv6. + + 'ipv4 - Use IPv4 + + 'ipv6 - Use IPv6" + :type '(choice (const :tag "Both" nil) + (const :tag "IPv4" ipv4) + (const :tag "IPv6" ipv6)) + :group 'circe) + +(defcustom circe-default-directory "~/" + "The value of `default-directory' for Circe buffers." + :type 'string + :group 'circe) + +(defcustom circe-network-options nil + "Network options. + +This alist maps network names to respective options. + +Common options: + + :pass - The IRC server password to use for this network, or a + function to fetch it. + :nick - The nick name to use (defaults to `circe-default-nick') + :user - The user name to use (defaults to `circe-default-user') + :realname - The real name to use (defaults to `circe-default-realname') + + :channels - A plist of channels to join (see `circe-channels'). + :server-buffer-name - Format to be used for the server buffer name + (see `circe-server-buffer-name') + + :host - The host name of the server to connect to. + :port - The port or service name for the server. + :use-tls - A boolean indicating as to whether to use TLS or + not (defaults to nil). If you set this, you'll likely + have to set :port as well. + :ip-family - Option to enforce a specific IP version + (defaults to `circe-default-ip-family') + + :nickserv-nick - The nick to authenticate with to nickserv, if configured. + (defaults to the value of :nick) + :nickserv-password - The password to use for nickserv + authentication or a function to fetch it. + + :sasl-username - The username for SASL authentication. + :sasl-password - The password for SASL authentication." + :type '(alist :key-type string :value-type plist) + :group 'circe) + +(defvar circe-network-defaults + '(("Freenode" :host "irc.freenode.net" :port (6667 . 6697) + :tls t + :nickserv-mask "^NickServ!NickServ@services\\.$" + :nickserv-identify-challenge "\C-b/msg\\s-NickServ\\s-identify\\s-\C-b" + :nickserv-identify-command "PRIVMSG NickServ :IDENTIFY {nick} {password}" + :nickserv-identify-confirmation "^You are now identified for .*\\.$" + :nickserv-ghost-command "PRIVMSG NickServ :GHOST {nick} {password}" + :nickserv-ghost-confirmation "has been ghosted\\.$\\|is not online\\.$" + ) + ("Coldfront" :host "irc.coldfront.net" :port 6667 + :nickserv-mask "^NickServ!services@coldfront\\.net$" + :nickserv-identify-challenge "/msg\\s-NickServ\\s-IDENTIFY\\s-\C-_password\C-_" + :nickserv-identify-command "PRIVMSG NickServ :IDENTIFY {password}" + ) + ("Bitlbee" :host "localhost" :port 6667 + :nickserv-mask "\\(bitlbee\\|root\\)!\\(bitlbee\\|root\\)@" + :nickserv-identify-challenge "use the \x02identify\x02 command to identify yourself" + :nickserv-identify-command "PRIVMSG &bitlbee :identify {password}" + :nickserv-identify-confirmation "Password accepted, settings and accounts loaded" + :lagmon-disabled t + ) + ("OFTC" :host "irc.oftc.net" :port (6667 . 6697) + :nickserv-mask "^NickServ!services@services\\.oftc\\.net$" + :nickserv-identify-challenge "This nickname is registered and protected." + :nickserv-identify-command "PRIVMSG NickServ :IDENTIFY {password} {nick}" + :nickserv-identify-confirmation "^You are successfully identified as .*\\.$" + ) + ) + "Alist of networks and connection settings. + +See the `circe' command for details of this variable.") + +(defcustom circe-default-quit-message "Using Circe, the loveliest of all IRC clients" + "The default quit message when no other is given. + +This is sent when the server buffer is killed or when /QUIT is +given with no argument." + :type 'string + :group 'circe) + +(defcustom circe-default-part-message "Using Circe, the loveliest of all IRC clients" + "How to part when a channel buffer is killed, or when no +argument is given to /PART." + :type 'string + :group 'circe) + +(defcustom circe-auto-query-max 23 + "The maximum number of queries which are opened automatically. +If more messages arrive - typically in a flood situation - they +are displayed in the server buffer." + :type 'integer + :group 'circe) + +(defcustom circe-use-cycle-completion nil + "Whether Circe should use cycle completion. + +If this is not nil, Circe will set `completion-cycle-threshold' +to t locally in Circe buffers, enabling cycle completion for +nicks no matter what completion style you use in the rest of +Emacs. If you set this to nil, Circe will not touch your default +completion style." + :type 'boolean + :group 'circe) + +(defcustom circe-reduce-lurker-spam nil + "If enabled, Circe will stop showing some messages. + +This means that JOIN, PART, QUIT and NICK messages are not shown +for users on channels that have not spoken yet (\"lurker\"), or +haven't spoken in `circe-active-users-timeout' seconds. When they +speak for the first time, Circe displays their join time." + :type 'boolean + :group 'circe) + +(defcustom circe-active-users-timeout nil + "When non-nil, should be the number of seconds after which +active users are regarded as inactive again after speaking." + :type 'integer + :group 'circe) + +(defcustom circe-prompt-string (concat (propertize ">" + 'face 'circe-prompt-face) + " ") + "The string to initialize the prompt with. +To change the prompt dynamically or just in specific buffers, use +`lui-set-prompt' in the appropriate hooks." + :type 'string + :group 'circe) + +(defcustom circe-extra-nicks nil + "List of other nicks than your current one to highlight." + :type '(repeat string) + :group 'circe) + +(defcustom circe-highlight-nick-type 'sender + "How to highlight occurrences of our own nick. + + 'sender - Highlight the nick of the sender + (messages without a sender and your + own are highlighted with the occurrence + type instead) + 'occurrence - Highlight the occurrences of the nick + 'message - Highlight the message without the sender + 'all - Highlight the whole line" + :type '(choice (const :tag "Sender" sender) + (const :tag "Occurrences" occurrence) + (const :tag "Message" message) + (const :tag "Whole line" all)) + :group 'circe) + +(defcustom circe-inhibit-nick-highlight-function nil + "Function for inhibiting nick highlighting. +If non-nil, its value is called with the respective buffer +selected and point in the line that's about to get highlighted. +A non-nil return value inhibits any highlighting." + :type '(choice (const :tag "None" nil) + function) + :group 'circe) + +(defcustom circe-completion-suffix ": " + "A suffix for completed nicks at the beginning of a line." + :type '(choice (const :tag "The standard suffix" ": ")) + :group 'circe) + +(defcustom circe-ignore-list nil + "List of regular expressions to ignore. + +Each regular expression is matched against nick!user@host." + :type '(repeat regexp) + :group 'circe) + +(defcustom circe-fool-list nil + "List of regular expressions for fools. + +Each regular expression is matched against nick!user@host. + +Messages from such people are still inserted, but not shown. They +can be displayed using \\[lui-toggle-ignored]." + :type '(repeat regexp) + :group 'circe) + +(defcustom circe-ignore-functions nil + "A list of functions to check whether we should ignore a message. + +These functions get three arguments: NICK, USERHOST, and BODY. If +one of them returns a non-nil value, the message is ignored." + :type 'hook + :group 'circe) + +(defcustom circe-split-line-length 440 + "The maximum length of a single message. +If a message exceeds this size, it is broken into multiple ones. + +IRC allows for lines up to 512 bytes. Two of them are CR LF. +And a typical message looks like this: + + :nicky!uhuser@host212223.dialin.fnordisp.net PRIVMSG #lazybastards :Hello! + +You can limit here the maximum length of the \"Hello!\" part. +Good luck." + :type 'integer + :group 'circe) + +(defcustom circe-server-max-reconnect-attempts 5 + "How often Circe should attempt to reconnect to the server. +If this is 0, Circe will not reconnect at all. If this is nil, +it will try to reconnect forever (not recommended)." + :type 'integer + :group 'circe) + +(defcustom circe-netsplit-delay 60 + "The number of seconds a netsplit may be dormant. +If anything happens with a netsplit after this amount of time, +the user is re-notified." + :type 'number + :group 'circe) + +(defcustom circe-server-killed-confirmation 'ask-and-kill-all + "How to ask for confirmation when a server buffer is killed. +This can be one of the following values: + ask - Ask the user for confirmation + ask-and-kill-all - Ask the user, and kill all associated buffers + kill-all - Don't ask the user, and kill all associated buffers + nil - Kill first, ask never" + :type '(choice (const :tag "Ask before killing" ask) + (const :tag "Ask, then kill all associated buffers" + ask-and-kill-all) + (const :tag "Don't ask, then kill all associated buffers" + kill-all) + (const :tag "Don't ask" nil)) + :group 'circe) + +(defcustom circe-channel-killed-confirmation 'ask + "How to ask for confirmation when a channel buffer is killed. +This can be one of the following values: + ask - Ask the user for confirmation + nil - Don't ask, just kill" + :type '(choice (const :tag "Ask before killing" ask) + (const :tag "Don't ask" nil)) + :group 'circe) + +(defcustom circe-track-faces-priorities '(circe-highlight-nick-face + lui-highlight-face + circe-my-message-face + circe-server-face) + "A list of faces which should show up in the tracking. +The first face is kept if the new message has only lower faces, +or faces that don't show up at all." + :type '(repeat face) + :group 'circe) + +(defcustom circe-server-send-unknown-command-p nil + "Non-nil when Circe should just pass on commands it doesn't know. +E.g. /fnord foo bar would then just send \"fnord foo bar\" to the +server." + :type 'boolean + :group 'circe) + +(defcustom circe-server-connected-hook nil + "Hook run when we successfully connected to a server. +This is run from a 001 (RPL_WELCOME) message handler." + :type 'hook + :group 'circe) + +(defcustom circe-server-auto-join-default-type :immediate + "The default auto-join type to use. + +Possible options: + +:immediate - Immediately after registering on the server +:after-auth - After nickserv authentication succeeded +:after-cloak - After we have acquired a cloaked host name +:after-nick - After we regained our preferred nick, or after + nickserv authentication if we don't need to regain + it. See `circe-nickserv-ghost-style'. + +See `circe-channels' for more details." + :type '(choice (const :tag "Immediately" :immediate) + (const :tag "After Authentication" :after-auth) + (const :tag "After Cloaking" :after-cloak) + (const :tag "After Nick Regain" :after-nick)) + :group 'circe) + +;;;;;;;;;;;;;;;;; +;;;; Formats ;;;; +;;;;;;;;;;;;;;;;; + +(defgroup circe-format nil + "Format strings for Circe. +All these formats always allow the {mynick} and {chattarget} format +strings." + :prefix "circe-format-" + :group 'circe) + +(defcustom circe-format-not-tracked + '(circe-format-server-message + circe-format-server-notice + circe--irc-format-server-numeric + circe-format-server-topic + circe-format-server-rejoin + circe-format-server-lurker-activity + circe-format-server-topic-time + circe-format-server-topic-time-for-channel + circe-format-server-netmerge + circe-format-server-join + circe-format-server-join-in-channel + circe-format-server-mode-change + circe-format-server-nick-change-self + circe-format-server-nick-change + circe-format-server-nick-regain + circe-format-server-part + circe-format-server-netsplit + circe-format-server-quit-channel + circe-format-server-quit) + "A list of formats that should not trigger tracking." + :type '(repeat symbol) + :group 'circe-format) + +(defcustom circe-format-server-message "*** {body}" + "The format for generic server messages. +{body} - The body of the message." + :type 'string + :group 'circe-format) + +(defcustom circe-format-self-say "> {body}" + "The format for messages to queries or channels. +{nick} - Your nick. +{body} - The body of the message." + :type 'string + :group 'circe-format) + +(defcustom circe-format-self-action "* {nick} {body}" + "The format for actions to queries or channels. +{nick} - Your nick. +{body} - The body of the action." + :type 'string + :group 'circe-format) + +(defcustom circe-format-self-message "-> *{chattarget}* {body}" + "The format for messages sent to other people outside of queries. +{chattarget} - The target nick. +{body} - The body of the message." + :type 'string + :group 'circe-format) + +(defcustom circe-format-action "* {nick} {body}" + "The format for actions in queries or channels. +{nick} - The nick doing the action. +{body} - The body of the action." + :type 'string + :group 'circe-format) + +(defcustom circe-format-message-action "* *{nick}* {body}" + "The format for actions in messages outside of queries. +{nick} - The nick doing the action. +{body} - The body of the action." + :type 'string + :group 'circe-format) + +(defcustom circe-format-say "<{nick}> {body}" + "The format for normal channel or query talk. +{nick} - The nick talking. +{body} - The message." + :type 'string + :group 'circe-format) + +(defcustom circe-format-message "*{nick}* {body}" + "The format for a message outside of a query. +{nick} - The originator. +{body} - The message." + :type 'string + :group 'circe-format) + +(defcustom circe-format-notice "-{nick}- {body}" + "The format for a notice. +{nick} - The originator. +{body} - The notice." + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-notice "-Server Notice- {body}" + "The format for a server notice. +{body} - The notice." + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-topic "*** Topic change by {nick} ({userhost}): {new-topic}" + "The format for topic changes. + +The following format arguments are available: + + nick - The nick of the user who changed the topic + userhost - The user@host string of that user + channel - Where the topic change happened + new-topic - The new topic + old-topic - The previous topic + topic-diff - A colorized diff of the topics" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-lurker-activity + "*** First activity: {nick} joined {joindelta} ago." + "The format for the first-activity notice of a user. +{nick} - The originator. +{jointime} - The join time of the user (in seconds). +{joindelta} - The duration from joining until now." + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-rejoin + "*** Re-join: {nick} ({userinfo}), left {departuredelta} ago" + "The format for the re-join notice of a user. + +The following format arguments are available: + + nick - The nick of the user who joined + userhost - The user@host string of the user who joined + accountname - The account name, if the server supports this + realname - The real name, if the server supports this + userinfo - A combination of userhost, accountname, and realname + channel - A date string describing this time + departuretime - Time in seconds when the originator had left. + departuredelta - Description of the time delta since the originator left." + :type 'string + :group 'circe-format) + +(defcustom circe-server-buffer-name "{host}:{port}" + "The format for the server buffer name. + +The following format arguments are available: + + network - The name of the network + host - The host name of the server + port - The port number or service name + service - Alias for port" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-whois-idle-with-signon "*** {whois-nick} is {idle-duration} idle (signon on {signon-date}, {signon-ago} ago)" + "Format for RPL_WHOISIDLE messages. + +The following format arguments are available: + + whois-nick - The nick this is about + idle-seconds - The number of seconds this nick has been idle + idle-duration - A textual description of the duration of the idle time + signon-time - The time (in seconds since the epoch) when this user + signed on + signon-date - A date string describing this time + signon-ago - A textual description of the duraction since signon" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-whois-idle "*** {whois-nick} is {idle-duration} idle" + "Format for RPL_WHOISIDLE messages. + +The following format arguments are available: + + whois-nick - The nick this is about + idle-seconds - The number of seconds this nick has been idle + idle-duration - A textual description of the duration of the idle time" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-topic-time "*** Topic set by {setter} on {topic-date}, {topic-ago} ago" + "Format for RPL_TOPICWHOTIME messages for the current channel. + +The following format arguments are available: + + channel - The channel the topic is for + setter - The nick of the person who set the topic + setter-userhost - The user@host string of the person who set the topic + topic-time - The time the topic was set, in seconds since the epoch + topic-date - A date string describing this time + topic-ago - A textual description of the duration since the topic + was set" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-topic-time-for-channel "*** Topic for {channel} set by {setter} on {topic-date}, {topic-ago} ago" + "Format for RPL_TOPICWHOTIME messages for a channel we are not on. + +The following format arguments are available: + + channel - The channel the topic is for + setter - The nick of the person who set the topic + setter-userhost - The user@host string of the person who set the topic + topic-time - The time the topic was set, in seconds since the epoch + topic-date - A date string describing this time + topic-ago - A textual description of the duration since the topic + was set" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-channel-creation-time "*** Channel {channel} created on {date}, {ago} ago" + "Format for RPL_CREATIONTIME messages for the current channel. + +The following format arguments are available: + + channel - The channel the topic is for + date - A date string describing this time + ago - A textual description of the duration since the channel + was created" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-ctcp-ping "*** CTCP PING request from {nick} ({userhost}) to {target}: {body} ({ago} ago)" + "Format for CTCP PING requests. + +The following format arguments are available: + + nick - The nick of the user who sent this PING request + userhost - The user@host string of the user who sent this request + target - The target of the message, usually us, but can be a channel + body - The argument of the PING request, usually a number + ago - A textual description of the duration since the request + was sent, if parseable" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-ctcp-ping-reply "*** CTCP PING reply from {nick} ({userhost}) to {target}: {ago} ago ({body})" + "Format for CTCP PING replies. + +The following format arguments are available: + + nick - The nick of the user who sent this PING request + userhost - The user@host string of the user who sent this request + target - The target of the message, usually us, but can be a channel + body - The argument of the PING request, usually a number + ago - A textual description of the duration since the request + was sent, if parseable" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-ctcp "*** CTCP {command} request from {nick} ({userhost}) to {target}: {body}" + "Format for CTCP requests. + +The following format arguments are available: + + nick - The nick of the user who sent this PING request + userhost - The user@host string of the user who sent this request + target - The target of the message, usually us, but can be a channel + command - The CTCP command used + body - The argument of the PING request, usually a number" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-netsplit "*** Netsplit: {split} (Use /WL to see who left)" + "Format for netsplit notifications. + +The following format arguments are available: + + split - The name of the split, usually describing the servers involved" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-netmerge "*** Netmerge: {split}, split {ago} ago (Use /WL to see who's still missing)" + "Format for netmerge notifications. + +The following format arguments are available: + + split - The name of the split, usually describing the servers involved + time - The time when this split happened, in seconds + date - A date string describing this time + ago - A textual description of the duration since the split happened" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-join "*** Join: {nick} ({userinfo})" + "Format for join messages in a channel buffer. + +The following format arguments are available: + + nick - The nick of the user joining + userhost - The user@host string for the user + accountname - The account name, if the server supports this + realname - The real name, if the server supports this + userinfo - A combination of userhost, accountname, and realname + channel - The channel this user is joining" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-join-in-channel "*** Join: {nick} ({userinfo}) joined {channel}" + "Format for join messages in query buffers of the joining user. + +The following format arguments are available: + + nick - The nick of the user joining + userhost - The user@host string for the user + accountname - The account name, if the server supports this + realname - The real name, if the server supports this + userinfo - A combination of userhost, accountname, and realname + channel - The channel this user is joining" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-mode-change "*** Mode change: {change} on {target} by {setter} ({userhost})" + "Format for mode changes. + +The following format arguments are available: + + setter - The name of the split, usually describing the servers involved + userhost - The user@host string for the user + target - The target of this mode change + change - The actual changed modes" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-nick-change-self "*** Nick change: You are now known as {new-nick}" + "Format for nick changes of the current user. + +The following format arguments are available: + + old-nick - The old nick this change was from + new-nick - The new nick this change was to + userhost - The user@host string for the user" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-nick-change "*** Nick change: {old-nick} ({userhost}) is now known as {new-nick}" + "Format for nick changes of the current user. + +The following format arguments are available: + + old-nick - The old nick this change was from + new-nick - The new nick this change was to + userhost - The user@host string for the user" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-nick-regain "*** Nick regain: {old-nick} ({userhost}) is now known as {new-nick}" + "Format for nick changes of the current user. + +The following format arguments are available: + + old-nick - The old nick this change was from + new-nick - The new nick this change was to + userhost - The user@host string for the user" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-part "*** Part: {nick} ({userhost}) left {channel}: {reason}" + "Format for users parting a channel. + +The following format arguments are available: + + nick - The nick of the user who left + userhost - The user@host string for this user + channel - The channel they left + reason - The reason they gave for leaving" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-quit-channel "*** Quit: {nick} ({userhost}) left {channel}: {reason}" + "Format for users quitting from a channel. + +The following format arguments are available: + + nick - The nick of the user who left + userhost - The user@host string for this user + channel - The channel they left + reason - The reason they gave for leaving" + :type 'string + :group 'circe-format) + +(defcustom circe-format-server-quit "*** Quit: {nick} ({userhost}) left IRC: {reason}" + "Format for users quitting. + +The following format arguments are available: + + nick - The nick of the user who left + userhost - The user@host string for this user + reason - The reason they gave for leaving" + :type 'string + :group 'circe-format) + +;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Private variables ;;; +;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar circe-source-url "https://github.com/jorgenschaefer/circe" + "URL to Circe's source repository") + +(defvar circe-host nil + "The name of the server we're currently connected to.") +(make-variable-buffer-local 'circe-host) + +(defvar circe-port nil + "The port number or service name of the server.") +(make-variable-buffer-local 'circe-host) + +(defvar circe-network nil + "The network name of the server we're currently connected to.") +(make-variable-buffer-local 'circe-network) + +(defvar circe-ip-family nil + "The IP family in use. +See `make-network-process' and :family for valid values.") +(make-variable-buffer-local 'circe-ip-family) + +(defvar circe-nick nil + "Our current nick.") +(make-variable-buffer-local 'circe-nick) + +(defvar circe-user nil + "The current user name.") +(make-variable-buffer-local 'circe-user) + +(defvar circe-realname nil + "The current real name.") +(make-variable-buffer-local 'circe-realname) + +(defvar circe-pass nil + "The password for the current server or a function to recall it. + +If a function is set it will be called with the value of `circe-host'.") +(make-variable-buffer-local 'circe-pass) + +(defvar circe-sasl-username nil + "The username for SASL authentication.") +(make-variable-buffer-local 'circe-sasl-username) + +(defvar circe-sasl-password nil + "The password for SASL authentication. + +If a function is set it will be called with the value of +`circe-host'.") +(make-variable-buffer-local 'circe-sasl-password) + +(defvar circe-use-tls nil + "If non-nil, use `open-tls-stream' to connect to the server.") +(make-variable-buffer-local 'circe-use-tls) + +(defvar circe-server-process nil + "The process of the server connection.") +(make-variable-buffer-local 'circe-server-process) + +(defvar circe-server-last-active-buffer nil + "The last active circe buffer.") +(make-variable-buffer-local 'circe-server-last-active-buffer) + +(defvar circe-display-table nil + "A hash table mapping commands to their display functions.") + +(defvar circe-server-inhibit-auto-reconnect-p nil + "Non-nil when Circe should not reconnect. + +This can be set from commands to avoid reconnecting when the +server disconnects.") +(make-variable-buffer-local 'circe-server-inhibit-auto-reconnect-p) + +(defvar circe-chat-calling-server-buffer-and-target nil + "Internal variable to pass the server buffer and target to chat modes.") + +(defvar circe-chat-target nil + "The current target for the buffer. +This is either a channel or a nick name.") +(make-variable-buffer-local 'circe-chat-target) + +(defvar circe-nick-syntax-table + (let ((table (make-syntax-table text-mode-syntax-table)) + (special (string-to-list "[]\`_^{}|-"))) + (dolist (char special) + (modify-syntax-entry char "w" table)) + table) + "Syntax table to treat nicks as words. +This is not entirely accurate, as exact chars constituting a nick +can vary between networks.") + +(defvar circe-nickserv-mask nil + "The regular expression to identify the nickserv on this network. + +Matched against nick!user@host.") +(make-variable-buffer-local 'circe-nickserv-mask) + +(defvar circe-nickserv-identify-challenge nil + "A regular expression matching the nickserv challenge to identify.") +(make-variable-buffer-local 'circe-nickserv-identify-challenge) + +(defvar circe-nickserv-identify-command nil + "The IRC command to send to identify with nickserv. + +This must be a full IRC command. It accepts the following +formatting options: + + {nick} - The nick to identify as + {password} - The configured nickserv password") +(make-variable-buffer-local 'circe-nickserv-identify-command) + +(defvar circe-nickserv-identify-confirmation nil + "A regular expression matching a confirmation of authentication.") +(make-variable-buffer-local 'circe-nickserv-identify-confirmation) + +(defvar circe-nickserv-ghost-command nil + "The IRC command to send to regain/ghost your nick. + +This must be a full IRC command. It accepts the following +formatting options: + + {nick} - The nick to ghost + {password} - The configured nickserv password") +(make-variable-buffer-local 'circe-nickserv-ghost-command) + +(defvar circe-nickserv-ghost-confirmation nil + "A regular expression matching a confirmation for the GHOST command. + +This is used to know when we can set our nick to the regained one +Leave nil if regaining automatically sets your nick") +(make-variable-buffer-local 'circe-nickserv-ghost-confirmation) + +(defvar circe-nickserv-nick nil + "The nick we are registered with for nickserv. + +Do not set this variable directly. Use `circe-network-options' or +pass an argument to the `circe' function for this.") +(make-variable-buffer-local 'circe-nickserv-nick) + +(defvar circe-nickserv-password nil + "The password we use for nickserv on this network. + +Can be either a string or a unary function of the nick returning +a string. + +Do not set this variable directly. Use `circe-network-options' or +pass an argument to the `circe' function for this.") +(make-variable-buffer-local 'circe-nickserv-password) + +(defvar circe-channels nil + "The default channels to join on this server. + +Don't set this variable by hand, use `circe-network-options'. + +The value should be a list of channels to join, with optional +keywords to configure the behavior of the following channels. + +Best explained in an example: + +\(\"#emacs\" :after-auth \"#channel\" \"#channel2\") + +Possible keyword options are: + +:immediate - Immediately after registering on the server +:after-auth - After nickserv authentication succeeded +:after-cloak - After we have acquired a cloaked host name +:after-nick - After we regained our preferred nick, or after + nickserv authentication if we don't need to regain + it. See `circe-nickserv-ghost-style'. + +The default is set in `circe-server-auto-join-default-type'. + +A keyword in the first position of the channels list overrides +`circe-server-auto-join-default-type' for re-joining manually +joined channels.") +(make-variable-buffer-local 'circe-channels) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Server Buffer Management ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Every Circe buffer has an associated server buffer (which might be +;; the buffer itself). Circe buffers should set the +;; `circe-server-buffer' variable to the associated server buffer. + +(defun circe-server-buffer () + "Return the server buffer for the current buffer." + (let ((buf (if (eq major-mode 'circe-server-mode) + (current-buffer) + circe-server-buffer))) + (cond + ((not buf) + (error "Not in a Circe buffer")) + ((not (buffer-live-p buf)) + (error "The server buffer died, functionality is limited")) + (t + buf)))) + +(defmacro with-circe-server-buffer (&rest body) + "Run BODY with the current buffer being the current server buffer." + (declare (indent 0)) + `(with-current-buffer (circe-server-buffer) + ,@body)) + +;;;;;;;;;;;;;;;;;;;;;;; +;;; Editor Commands ;;; +;;;;;;;;;;;;;;;;;;;;;;; + +;;;###autoload +(defun circe-version () + "Display Circe's version." + (interactive) + (message "Circe %s" (circe--version))) + +(defun circe--version () + "Return Circe's version" + (let ((circe-git-version (circe--git-version))) + (if circe-git-version + (format "%s-%s" circe-version circe-git-version) + (format "%s" circe-version)))) + +(defun circe--git-version () + (let* ((current-file-path (or load-file-name buffer-file-name + (locate-library "circe.el"))) + (vcs-path (locate-dominating-file current-file-path ".git"))) + (when vcs-path + (let ((default-directory vcs-path)) + ;; chop off the trailing newline + (substring (shell-command-to-string "git rev-parse --short HEAD") + 0 -1))))) + +;;;###autoload +(defun circe (network-or-server &rest server-options) + "Connect to IRC. + +Connect to the given network specified by NETWORK-OR-SERVER. + +When this function is called, it collects options from the +SERVER-OPTIONS argument, the user variable +`circe-network-options', and the defaults found in +`circe-network-defaults', in this order. + +If NETWORK-OR-SERVER is not found in any of these variables, the +argument is assumed to be the host name for the server, and all +relevant settings must be passed via SERVER-OPTIONS. + +All SERVER-OPTIONS are treated as variables by getting the string +\"circe-\" prepended to their name. This variable is then set +locally in the server buffer. + +See `circe-network-options' for a list of common options." + (interactive (circe--read-network-and-options)) + (let* ((options (circe--server-get-network-options network-or-server + server-options)) + (buffer (circe--server-generate-buffer options))) + (with-current-buffer buffer + (circe-server-mode) + (circe--server-set-variables options) + (circe-reconnect)) + (pop-to-buffer-same-window buffer))) + +(defun circe--read-network-and-options () + "Read a host or network name with completion. + +If it's not a network, also read some extra options. + +This uses `circe-network-defaults' and `circe-network-options' for +network names." + (let ((default-network (if (null circe-network-options) + (caar circe-network-defaults) + (caar circe-network-options))) + (networks nil) + (completion-ignore-case t) + network-or-host) + (dolist (network-spec (append circe-network-options + circe-network-defaults)) + (when (not (member (car network-spec) networks)) + (push (car network-spec) networks))) + (setq networks (sort networks 'string-lessp)) + (setq network-or-host (completing-read "Network or host: " + networks + nil nil nil nil + default-network)) + (dolist (network-name networks) + (when (equal (downcase network-or-host) + (downcase network-name)) + (setq network-or-host network-name))) + (if (member network-or-host networks) + (list network-or-host) + (list network-or-host + :host network-or-host + :port (read-number "Port: " 6667))))) + +(defun circe--server-get-network-options (network server-options) + "Combine server and network options with network defaults. + +See `circe-network-options' and `circe-network-defaults'." + (let ((options (mapcar 'circe--translate-option-names + (append server-options + (cdr (assoc network circe-network-options)) + (cdr (assoc network circe-network-defaults)) + (list :network network))))) + (when (not (plist-get options :host)) + (plist-put options :host network)) + (let ((port (plist-get options :port)) + (use-tls (plist-get options :use-tls))) + (when (consp port) + (if use-tls + (plist-put options :port (cdr port)) + (plist-put options :port (car port))))) + (dolist (required-option '(:host :port)) + (when (not (plist-get options required-option)) + (error (format "Network option %s not specified" required-option)))) + options)) + +(defun circe--translate-option-names (option) + "Translate option names to make them unique. + +Some options have multiple names, mainly for historical reasons. +Unify them here." + (cond + ((eq option :service) :port) + ((eq option :tls) :use-tls) + ((eq option :family) :ip-family) + (t option))) + +(defun circe--server-generate-buffer (options) + "Return the server buffer for the connection described in OPTIONS." + (let* ((network (plist-get options :network)) + (host (plist-get options :host)) + (port (plist-get options :port)) + (buffer-name (lui-format (or (plist-get options :server-buffer-name) + circe-server-buffer-name) + :network network + :host host + :port port + :service port))) + (generate-new-buffer buffer-name))) + +(defun circe--server-set-variables (options) + "Set buffer-local variables described in OPTIONS. + +OPTIONS is a plist as passed to `circe'. All options therein are +set as buffer-local variables. Only the first occurrence of each +variable is set." + (setq circe-nick circe-default-nick + circe-user circe-default-user + circe-realname circe-default-realname + circe-ip-family circe-default-ip-family) + (let ((done nil) + (todo options)) + (while todo + (when (not (memq (car todo) done)) + (push (car todo) done) + (let ((var (intern (format "circe-%s" + (substring (symbol-name (car todo)) 1)))) + (val (cadr todo))) + (if (boundp var) + (set (make-local-variable var) val) + (warn "Unknown option %s, ignored" (car todo))))) + (setq todo (cddr todo))))) + +(defvar circe-server-reconnect-attempts 0 + "The number of reconnect attempts that Circe has done so far. +See `circe-server-max-reconnect-attempts'.") +(make-variable-buffer-local 'circe-server-reconnect-attempts) + +(defun circe-reconnect () + "Reconnect the current server." + (interactive) + (with-circe-server-buffer + (when (or (called-interactively-p 'any) + (circe--reconnect-p)) + (setq circe-server-inhibit-auto-reconnect-p t + circe-server-reconnect-attempts (+ circe-server-reconnect-attempts + 1)) + (unwind-protect + (circe-reconnect--internal) + (setq circe-server-inhibit-auto-reconnect-p nil))))) + +(defun circe--reconnect-p () + (cond + (circe-server-inhibit-auto-reconnect-p + nil) + ((not circe-server-max-reconnect-attempts) + t) + ((<= circe-server-reconnect-attempts + circe-server-max-reconnect-attempts) + t) + (t + nil))) + +(defun circe-reconnect--internal () + "The internal function called for reconnecting unconditionally. + +Do not use this directly, use `circe-reconnect'" + (when (and circe-server-process + (process-live-p circe-server-process)) + (delete-process circe-server-process)) + (circe-display-server-message "Connecting...") + (dolist (buf (circe-server-chat-buffers)) + (with-current-buffer buf + (circe-display-server-message "Connecting..."))) + (setq circe-server-process + (irc-connect + :host circe-host + :service circe-port + :tls circe-use-tls + :ip-family circe-ip-family + :handler-table (circe-irc-handler-table) + :server-buffer (current-buffer) + :nick circe-nick + :nick-alternatives (list (circe--nick-next circe-nick) + (circe--nick-next + (circe--nick-next circe-nick))) + :user circe-user + :mode 8 + :realname circe-realname + :pass (if (functionp circe-pass) + (funcall circe-pass circe-host) + circe-pass) + :cap-req (append (when (and circe-sasl-username + circe-sasl-password) + '("sasl")) + '("extended-join")) + :nickserv-nick (or circe-nickserv-nick + circe-nick) + :nickserv-password (if (functionp circe-nickserv-password) + (funcall circe-nickserv-password circe-host) + circe-nickserv-password) + :nickserv-mask circe-nickserv-mask + :nickserv-identify-challenge circe-nickserv-identify-challenge + :nickserv-identify-command circe-nickserv-identify-command + :nickserv-identify-confirmation + circe-nickserv-identify-confirmation + :nickserv-ghost-command circe-nickserv-ghost-command + :nickserv-ghost-confirmation circe-nickserv-ghost-confirmation + :sasl-username circe-sasl-username + :sasl-password (if (functionp circe-sasl-password) + (funcall circe-sasl-password + circe-host) + circe-sasl-password) + :ctcp-version (format "Circe: Client for IRC in Emacs, version %s" + circe-version) + :ctcp-source circe-source-url + :ctcp-clientinfo "CLIENTINFO PING SOURCE TIME VERSION" + :auto-join-after-registration + (append (circe--auto-join-channel-buffers) + (circe--auto-join-list :immediate)) + :auto-join-after-host-hiding + (circe--auto-join-list :after-cloak) + :auto-join-after-nick-acquisition + (circe--auto-join-list :after-nick) + :auto-join-after-nickserv-identification + (circe--auto-join-list :after-auth) + :auto-join-after-sasl-login + (circe--auto-join-list :after-auth)))) + +(defun circe-reconnect-all () + "Reconnect all Circe connections." + (interactive) + (dolist (buf (circe-server-buffers)) + (with-current-buffer buf + (if (called-interactively-p 'any) + (call-interactively 'circe-reconnect) + (circe-reconnect))))) + +(defun circe--auto-join-list (type) + "Return the list of channels to join for type TYPE." + (let ((result nil) + (current-type circe-server-auto-join-default-type)) + (dolist (channel circe-channels) + (cond + ((keywordp channel) + (setq current-type channel)) + ((eq current-type type) + (push channel result)))) + (nreverse result))) + +(defun circe--auto-join-channel-buffers () + "Return a list of channels to join based on channel buffers. + +This includes all channel buffers of the current server, but +excludes and channel that is already listed in +`circe-channels'." + (let ((channels nil)) + (dolist (buf (circe-server-chat-buffers)) + (let ((name (with-current-buffer buf + (when (derived-mode-p 'circe-channel-mode) + circe-chat-target)))) + (when (and name + (not (member name circe-channels))) + (push name channels)))) + channels)) + +;;;;;;;;;;;;;;;;; +;;; Base Mode ;;; +;;;;;;;;;;;;;;;;; + +(defvar circe-mode-hook nil + "Hook run for any Circe mode.") + +(defvar circe-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-j") 'circe-command-JOIN) + (define-key map (kbd "C-c C-r") 'circe-reconnect) + map) + "The base keymap for all Circe modes (server, channel, query)") + +(defvar circe-server-buffer nil + "The buffer of the server associated with the current chat buffer.") +(make-variable-buffer-local 'circe-server-buffer) + +(define-derived-mode circe-mode lui-mode "Circe" + "Base mode for all Circe buffers. + +A buffer should never be in this mode directly, but rather in +modes that derive from this. + +The mode inheritance hierarchy looks like this: + +lui-mode +`-circe-mode + `-circe-server-mode + `-circe-chat-mode + `-circe-channel-mode + `-circe-query-mode" + (add-hook 'lui-pre-output-hook 'lui-irc-colors + t t) + (add-hook 'lui-pre-output-hook 'circe--output-highlight-nick + t t) + (add-hook 'completion-at-point-functions 'circe--completion-at-point + nil t) + (lui-set-prompt circe-prompt-string) + (goto-char (point-max)) + (setq lui-input-function 'circe--input + default-directory (expand-file-name circe-default-directory) + circe-server-last-active-buffer (current-buffer) + flyspell-generic-check-word-p 'circe--flyspell-check-word-p) + (when circe-use-cycle-completion + (set (make-local-variable 'completion-cycle-threshold) + t)) + ;; Tab completion should be case-insensitive + (set (make-local-variable 'completion-ignore-case) + t) + (set (make-local-variable 'tracking-faces-priorities) + circe-track-faces-priorities)) + +;;;;;;;;;;;;;;;;;;;; +;;;; Displaying ;;;; +;;;;;;;;;;;;;;;;;;;; + +(defun circe-display (format &rest keywords) + "Display FORMAT formatted with KEYWORDS in the current Circe buffer. +See `lui-format' for a description of the format. + +If FORMAT contains the word server, the resulting string receives +a `circe-server-face'. If FORMAT contains the word self, the +whole string receives a `circe-my-message-face'. If FORMAT is in +`circe-format-not-tracked', a message of this type is never +tracked by Lui. + +Keywords with the name :nick receive a `circe-originator-face'. + +It is always possible to use the mynick or target formats." + (when (not (circe--display-ignored-p format keywords)) + (let* ((name (symbol-name format)) + (face (cond + ((string-match "\\" name) + 'circe-server-face) + ((string-match "\\" name) + 'circe-my-message-face))) + (keywords (append `(:mynick ,(circe-nick) + :chattarget ,circe-chat-target) + (circe--display-add-nick-property + (if (and (not (null keywords)) + (null (cdr keywords))) + (car keywords) + keywords)))) + (text (lui-format format keywords))) + (when (circe--display-fool-p format keywords) + (add-face-text-property 0 (length text) + 'circe-fool-face t text) + (put-text-property 0 (length text) + 'lui-fool t + text)) + (when face + (add-face-text-property 0 (length text) + face t text)) + (lui-insert text + (memq format circe-format-not-tracked))))) + +(defun circe-display-server-message (message) + "Display MESSAGE as a server message." + (circe-display 'circe-format-server-message + :body message)) + +(defun circe--display-add-nick-property (keywords) + "Add a face to the value of the :nick property in KEYWORDS." + (let ((keyword nil)) + (mapcar (lambda (entry) + (cond + ((or (eq keyword :nick) + (eq keyword 'nick)) + (setq keyword nil) + (propertize entry 'face 'circe-originator-face)) + (t + (setq keyword entry) + entry))) + keywords))) + +(defun circe--display-ignored-p (_format keywords) + (let ((nick (plist-get keywords :nick)) + (userhost (plist-get keywords :userhost)) + (body (plist-get keywords :body))) + (circe--ignored-p nick userhost body))) + +(defun circe--display-fool-p (_format keywords) + (let ((nick (plist-get keywords :nick)) + (userhost (plist-get keywords :userhost)) + (body (plist-get keywords :body))) + (circe--fool-p nick userhost body))) + +(defun circe--ignored-p (nick userhost body) + "True if this user or message is being ignored. + +See `circe-ignore-functions' and `circe-ignore-list'. + +NICK, USER and HOST should be the sender of a the command +COMMAND, which had the arguments ARGS." + (or (run-hook-with-args-until-success 'circe-ignore-functions + nick userhost body) + (circe--ignore-matches-p nick userhost body circe-ignore-list))) + +(defun circe--fool-p (nick userhost body) + "True if this user or message is a fool. + +See `circe-fool-list'. + +NICK, USER and HOST should be the sender of a the command +COMMAND, which had the arguments ARGS." + (circe--ignore-matches-p nick userhost body circe-fool-list)) + +(defun circe--ignore-matches-p (nick userhost body patterns) + "Check if a given command does match an ignore pattern. + +A pattern matches if it either matches the user NICK!USER@HOST, +or if it matches the first word in BODY. + +PATTERNS should be the list of regular expressions." + (let ((string (format "%s!%s" nick userhost)) + (target (when (and body + (string-match "^\\([^ ]*\\)[:,]" body)) + (match-string 1 body)))) + (catch 'return + (dolist (regex patterns) + (when (string-match regex string) + (throw 'return t)) + (when (and (stringp target) + (string-match regex target)) + (throw 'return t))) + nil))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Nick Highlighting ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun circe--output-highlight-nick () + "Highlight the nick of the user in the buffer. + +This is used in `lui-pre-output-hook'." + (goto-char (or (text-property-any (point-min) (point-max) + 'lui-format-argument 'body) + (point-min))) + (when (or (not circe-inhibit-nick-highlight-function) + (not (funcall circe-inhibit-nick-highlight-function))) + (let* ((nick (circe-nick)) + (nicks (append (and nick (list nick)) + circe-extra-nicks))) + (when nicks + ;; Can't use \<...\> because that won't match for \ We + ;; might eventually use \_< ... \_> if we define symbols to be + ;; nicks \\= is necessary, because it might be found right where we + ;; are, and that might not be the beginning of a line... (We start + ;; searching from the beginning of the body) + (let ((nick-regex (concat "\\(?:^\\|\\W\\|\\=\\)" + "\\(" (regexp-opt nicks) "\\)" + "\\(?:$\\|\\W\\)"))) + (cond + ((eq circe-highlight-nick-type 'sender) + (if (text-property-any (point-min) + (point-max) + 'face 'circe-originator-face) + (when (re-search-forward nick-regex nil t) + (circe--extend-text-having-face + (point-min) (point-max) + 'circe-originator-face + 'circe-highlight-nick-face)) + (let ((circe-highlight-nick-type 'occurrence)) + (circe--output-highlight-nick)))) + ((eq circe-highlight-nick-type 'occurrence) + (while (re-search-forward nick-regex nil t) + (add-face-text-property (match-beginning 1) + (match-end 1) + 'circe-highlight-nick-face))) + ((eq circe-highlight-nick-type 'message) + (when (re-search-forward nick-regex nil t) + (let* ((start (text-property-any (point-min) + (point-max) + 'lui-format-argument 'body)) + (end (when start + (next-single-property-change start + 'lui-format-argument)))) + (when (and start end) + (add-face-text-property start end + 'circe-highlight-nick-face))))) + ((eq circe-highlight-nick-type 'all) + (when (re-search-forward nick-regex nil t) + (add-face-text-property (point-min) (point-max) + 'circe-highlight-nick-face))))))))) + +(defun circe--extend-text-having-face (from to existing new) + "Extend property values. + +In the text between FROM and TO, find any text that has its face +property set to EXISTING, and prepend NEW to the value of its +face property, when necessary by turning it into a list." + (let ((beg (text-property-any from to 'face existing))) + (while beg + (let ((end (next-single-property-change beg 'face))) + (add-face-text-property beg end new) + (setq beg (text-property-any end to 'face existing)))))) + +;;;;;;;;;;;;;;; +;;;; Input ;;;; +;;;;;;;;;;;;;;; + +(defun circe--input (str) + "Process STR as input. + +This detects commands and interprets them, or sends the input +using the /SAY command." + (set-text-properties 0 (length str) nil str) + (cond + ((string= str "") + nil) + ;; Ignore commands in multiline input + ((and (not (string-match "\n" str)) + (string-match "\\`/\\([^/ ][^ ]*\\|[^/ ]*\\) ?\\([^\n]*\\)\\'" str)) + (let* ((command (match-string 1 str)) + (args (match-string 2 str)) + (handler (intern-soft (format "circe-command-%s" + (upcase command))))) + (cond + ((string= command "") + (circe-command-SAY args)) + (handler + (funcall handler args)) + (circe-server-send-unknown-command-p + (irc-send-raw (circe-server-process) + (format "%s %s" + (upcase command) + args))) + (t + (circe-display-server-message (format "Unknown command: %s" + command)))))) + (t + (mapc #'circe-command-SAY + (circe--list-drop-right (split-string str "\n") + "^ *$"))))) + +;;;;;;;;;;;;;;;;;; +;;;; Flyspell ;;;; +;;;;;;;;;;;;;;;;;; + +(defun circe--flyspell-check-word-p () + "Return a true value if flyspell check the word before point. + +This is a suitable value for `flyspell-generic-check-word-p'. It +will also call `lui-flyspell-check-word-p'." + (cond + ((not (lui-flyspell-check-word-p)) + nil) + ((circe-channel-user-p (circe--flyspell-nick-before-point)) + nil) + (t + t))) + +(defun circe--flyspell-nick-before-point () + "Return the IRC nick before point" + (with-syntax-table circe-nick-syntax-table + (let (beg end) + (save-excursion + (forward-word -1) + (setq beg (point)) + (forward-word 1) + (setq end (point))) + (buffer-substring beg end)))) + +;;;;;;;;;;;;;;;;;;;; +;;;; Completion ;;;; +;;;;;;;;;;;;;;;;;;;; + +(defun circe--completion-at-point () + "Return a list of possible completions for the current buffer. + +This is used in `completion-at-point-functions'." + ;; Use markers so they move when input happens + (let ((start (make-marker)) + (end (make-marker))) + (set-marker end (point)) + (set-marker start + (save-excursion + (when (or (looking-back (regexp-quote + circe-completion-suffix) + (length circe-completion-suffix)) + (looking-back " " 1)) + (goto-char (match-beginning 0))) + (cond + ((<= (point) lui-input-marker) + lui-input-marker) + ((re-search-backward "\\s-" lui-input-marker t) + (1+ (point))) + (t + lui-input-marker)))) + (list start end 'circe--completion-table))) + +(defun circe--completion-table (string pred action) + "Completion table to use for Circe buffers. + +See `minibuffer-completion-table' for details." + (cond + ;; Best completion of STRING + ((eq action nil) + (try-completion string + (circe--completion-candidates + (if (= (- (point) (length string)) + lui-input-marker) + circe-completion-suffix + " ")) + pred)) + ;; A list of possible completions of STRING + ((eq action t) + (all-completions string + (circe--completion-candidates + (if (= (- (point) (length string)) + lui-input-marker) + circe-completion-suffix + " ")) + pred)) + ;; t iff STRING is a valid completion as it stands + ((eq action 'lambda) + (test-completion string + (circe--completion-candidates + (if (= (- (point) (length string)) + lui-input-marker) + circe-completion-suffix + " ")) + pred)) + ;; Boundaries + ((eq (car-safe action) 'boundaries) + `(boundaries 0 . ,(length (cdr action)))) + ;; Metadata + ((eq action 'metadata) + '(metadata (cycle-sort-function . circe--completion-sort))))) + +(defun circe--completion-clean-nick (string) + (with-temp-buffer + (insert string) + (goto-char (point-max)) + (when (or (looking-back circe-completion-suffix nil) + (looking-back " " nil)) + (replace-match "")) + (buffer-string))) + +(defun circe--completion-sort (collection) + "Sort the COLLECTION by channel activity for nicks." + (let* ((proc (circe-server-process)) + (channel (when (and circe-chat-target proc) + (irc-connection-channel proc circe-chat-target))) + (decorated (mapcar (lambda (entry) + (let* ((nick (circe--completion-clean-nick + entry)) + (user (when channel + (irc-channel-user channel nick)))) + (list (when user + (irc-user-last-activity-time user)) + (length entry) + entry))) + collection)) + (sorted (sort decorated + (lambda (a b) + (cond + ((and (car a) + (car b)) + (> (car a) + (car b))) + ((and (not (car a)) + (not (car b))) + (< (cadr a) + (cadr b))) + ((car a) + t) + (t + nil)))))) + (mapcar (lambda (entry) + (nth 2 entry)) + sorted))) + +;; FIXME: I do not know why this is here. +(defvar circe--completion-old-completion-all-sorted-completions nil + "Variable to know if we can return a cached result.") +(make-variable-buffer-local + 'circe--completion-old-completion-all-sorted-completions) +(defvar circe--completion-cache nil + "The results we can cache.") +(make-variable-buffer-local 'circe--completion-cache) + +(defun circe--completion-candidates (nick-suffix) + (if (and circe--completion-old-completion-all-sorted-completions + (eq completion-all-sorted-completions + circe--completion-old-completion-all-sorted-completions)) + circe--completion-cache + (let ((completions (append (circe--commands-list) + (mapcar (lambda (buf) + (with-current-buffer buf + circe-chat-target)) + (circe-server-channel-buffers))))) + (cond + ;; In a server buffer, complete all nicks in all channels + ((eq major-mode 'circe-server-mode) + (dolist (buf (circe-server-channel-buffers)) + (with-current-buffer buf + (dolist (nick (circe-channel-nicks)) + (setq completions (cons (concat nick nick-suffix) + completions)))))) + ;; In a channel buffer, only complete nicks in this channel + ((eq major-mode 'circe-channel-mode) + (setq completions (append (delete (concat (circe-nick) + nick-suffix) + (mapcar (lambda (nick) + (concat nick nick-suffix)) + (circe-channel-nicks))) + completions))) + ;; In a query buffer, only complete this query partner + ((eq major-mode 'circe-query-mode) + (setq completions (cons (concat circe-chat-target nick-suffix) + completions))) + ;; Else, we're doing something wrong + (t + (error "`circe-possible-completions' called outside of Circe"))) + (setq circe--completion-old-completion-all-sorted-completions + completion-all-sorted-completions + circe--completion-cache completions) + completions))) + +(defun circe--commands-list () + "Return a list of possible Circe commands." + (mapcar (lambda (symbol) + (let ((str (symbol-name symbol))) + (if (string-match "^circe-command-\\(.*\\)" str) + (concat "/" (match-string 1 str) " ") + str))) + (apropos-internal "^circe-command-"))) + +;;;;;;;;;;;;;;;;;;; +;;; Server Mode ;;; +;;;;;;;;;;;;;;;;;;; + +(defvar circe-server-mode-hook nil + "Hook run when a new Circe server buffer is created.") + +(defvar circe-server-mode-map (make-sparse-keymap) + "The key map for server mode buffers.") + +(define-derived-mode circe-server-mode circe-mode "Circe Server" + "The mode for circe server buffers. + +This buffer represents a server connection. When you kill it, the +server connection is closed. This will make all associated +buffers unusable. Be sure to use \\[circe-reconnect] if you want +to reconnect to the server. + +\\{circe-server-mode-map}" + (add-hook 'kill-buffer-hook 'circe-server-killed nil t)) + +(defun circe-server-killed () + "Run when the server buffer got killed. + +This will IRC, and ask the user whether to kill all of the +server's chat buffers." + (when circe-server-killed-confirmation + (when (not (y-or-n-p + (if (eq circe-server-killed-confirmation 'ask-and-kill-all) + "Really kill all buffers of this server? (if not, try `circe-reconnect') " + "Really kill the IRC connection? (if not, try `circe-reconnect') "))) + (error "Buffer not killed as per user request"))) + (setq circe-server-inhibit-auto-reconnect-p t) + (ignore-errors + (irc-send-QUIT circe-server-process circe-default-quit-message)) + (ignore-errors + (delete-process circe-server-process)) + (when (or (eq circe-server-killed-confirmation 'ask-and-kill-all) + (eq circe-server-killed-confirmation 'kill-all)) + (dolist (buf (circe-server-chat-buffers)) + (let ((circe-channel-killed-confirmation nil)) + (kill-buffer buf))))) + +(defun circe-server-buffers () + "Return a list of all server buffers in this Emacs instance." + (let ((result nil)) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (eq major-mode 'circe-server-mode) + (setq result (cons buf result))))) + (nreverse result))) + +(defun circe-server-process () + "Return the current server process." + (with-circe-server-buffer + circe-server-process)) + +(defun circe-server-my-nick-p (nick) + "Return non-nil when NICK is our current nick." + (let ((proc (circe-server-process))) + (when proc + (irc-current-nick-p proc nick)))) + +(defun circe-nick () + "Return our current nick." + (let ((proc (circe-server-process))) + (when proc + (irc-current-nick proc)))) + +(defun circe-server-last-active-buffer () + "Return the last active buffer of this server." + (with-circe-server-buffer + (if (and circe-server-last-active-buffer + (bufferp circe-server-last-active-buffer) + (buffer-live-p circe-server-last-active-buffer)) + circe-server-last-active-buffer + (current-buffer)))) + +;; There really ought to be a hook for this +(defadvice select-window (after circe-server-track-select-window + (window &optional norecord)) + "Remember the current buffer as the last active buffer. +This is used by Circe to know where to put spurious messages." + (with-current-buffer (window-buffer window) + (when (derived-mode-p 'circe-mode) + (let ((buf (current-buffer))) + (ignore-errors + (with-circe-server-buffer + (setq circe-server-last-active-buffer buf))))))) +(ad-activate 'select-window) + +(defun circe-reduce-lurker-spam () + "Return the value of `circe-reduce-lurker-spam'. + +This uses a buffer-local value first, then the one in the server +buffer. + +Use this instead of accessing the variable directly to enable +setting the variable through network options." + (if (local-variable-p 'circe-reduce-lurker-spam) + circe-reduce-lurker-spam + (with-circe-server-buffer + circe-reduce-lurker-spam))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Chat Buffer Management ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Server buffers keep track of associated chat buffers. This enables +;; us to not rely on buffer names staying the same, as well as keeping +;; buffers from different servers and even server connections apart +;; cleanly. + +(defvar circe-server-chat-buffer-table nil + "A hash table of chat buffers associated with this server.") +(make-variable-buffer-local 'circe-server-chat-buffer-table) + +(defun circe-server-get-chat-buffer (target) + "Return the chat buffer addressing TARGET, or nil if none." + (with-circe-server-buffer + (when circe-server-chat-buffer-table + (let* ((target-name (irc-isupport--case-fold (circe-server-process) + target)) + (buf (gethash target-name circe-server-chat-buffer-table))) + (if (buffer-live-p buf) + buf + (remhash target-name circe-server-chat-buffer-table) + nil))))) + +(defun circe-server-create-chat-buffer (target chat-mode) + "Return a new buffer addressing TARGET in CHAT-MODE." + (with-circe-server-buffer + (let* ((target-name (irc-isupport--case-fold (circe-server-process) + target)) + (chat-buffer (generate-new-buffer target)) + (server-buffer (current-buffer)) + (circe-chat-calling-server-buffer-and-target (cons server-buffer + target-name))) + (when (not circe-server-chat-buffer-table) + (setq circe-server-chat-buffer-table (make-hash-table :test 'equal))) + (puthash target-name chat-buffer circe-server-chat-buffer-table) + (with-current-buffer chat-buffer + (funcall chat-mode)) + chat-buffer))) + +(defun circe-server-get-or-create-chat-buffer (target chat-mode) + "Return a buffer addressing TARGET; create one in CHAT-MODE if none exists." + (let ((buf (circe-server-get-chat-buffer target))) + (if buf + buf + (circe-server-create-chat-buffer target chat-mode)))) + +(defun circe-server-remove-chat-buffer (target-or-buffer) + "Remove the buffer addressing TARGET-OR-BUFFER." + (with-circe-server-buffer + (let* ((target (if (bufferp target-or-buffer) + (circe-server-chat-buffer-target target-or-buffer) + target-or-buffer)) + (target-name (irc-isupport--case-fold (circe-server-process) + target))) + (remhash target-name circe-server-chat-buffer-table)))) + +(defun circe-server-rename-chat-buffer (old-name new-name) + "Note that the chat buffer addressing OLD-NAME now addresses NEW-NAME." + (with-circe-server-buffer + (let* ((old-target-name (irc-isupport--case-fold (circe-server-process) + old-name)) + (new-target-name (irc-isupport--case-fold (circe-server-process) + new-name)) + (buf (gethash old-target-name circe-server-chat-buffer-table))) + (when buf + (remhash old-target-name circe-server-chat-buffer-table) + (puthash new-target-name buf circe-server-chat-buffer-table) + (with-current-buffer buf + (setq circe-chat-target new-name) + (rename-buffer new-name t)))))) + +(defun circe-server-chat-buffer-target (&optional buffer) + "Return the chat target of BUFFER, or the current buffer if none." + (if buffer + (with-current-buffer buffer + circe-chat-target) + circe-chat-target)) + +(defun circe-server-chat-buffers () + "Return the list of chat buffers on this server." + (with-circe-server-buffer + (when circe-server-chat-buffer-table + (let ((buffer-list nil)) + (maphash (lambda (target-name buffer) + (if (buffer-live-p buffer) + (push buffer buffer-list) + (remhash target-name circe-server-chat-buffer-table))) + circe-server-chat-buffer-table) + buffer-list)))) + +(defun circe-server-channel-buffers () + "Return a list of all channel buffers of this server." + (let ((result nil)) + (dolist (buf (circe-server-chat-buffers)) + (with-current-buffer buf + (when (eq major-mode 'circe-channel-mode) + (setq result (cons buf result))))) + (nreverse result))) + +;;;;;;;;;;;;;;;;; +;;; Chat Mode ;;; +;;;;;;;;;;;;;;;;; + +(defvar circe-chat-mode-hook nil + "Hook run when a new chat buffer (channel or query) is created.") + +(defvar circe-chat-mode-map (make-sparse-keymap) + "Base key map for all Circe chat buffers (channel, query).") + +;; Defined here as we use it, but do not necessarily want to use the +;; full module. +(defvar lui-logging-format-arguments nil + "A list of arguments to be passed to `lui-format'. +This can be used to extend the formatting possibilities of the +file name for lui applications.") +(make-variable-buffer-local 'lui-logging-format-arguments) + +(define-derived-mode circe-chat-mode circe-mode "Circe Chat" + "The circe chat major mode. + +This is the common mode used for both queries and channels. +It should not be used directly. +TARGET is the default target to send data to. +SERVER-BUFFER is the server buffer of this chat buffer." + (setq circe-server-buffer (car circe-chat-calling-server-buffer-and-target) + circe-chat-target (cdr circe-chat-calling-server-buffer-and-target)) + (let ((network (with-circe-server-buffer + circe-network))) + (make-local-variable 'mode-line-buffer-identification) + (setq mode-line-buffer-identification + (list (format "%%b@%-8s" network))) + (setq lui-logging-format-arguments + `(:target ,circe-chat-target :network ,network))) + (when (equal circe-chat-target "#emacs-circe") + (set (make-local-variable 'lui-button-issue-tracker) + "https://github.com/jorgenschaefer/circe/issues/%s"))) + +(defun circe-chat-disconnected () + "The current buffer got disconnected." + (circe-display-server-message "Disconnected")) + +;;;;;;;;;;;;;;;;;;;; +;;; Channel Mode ;;; +;;;;;;;;;;;;;;;;;;;; + +(defvar circe-channel-mode-hook nil + "Hook run in a new channel buffer.") + +(defvar circe-channel-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-n") 'circe-command-NAMES) + (define-key map (kbd "C-c C-t") 'circe-command-CHTOPIC) + map) + "The key map for channel mode buffers.") + +(define-derived-mode circe-channel-mode circe-chat-mode "Circe Channel" + "The circe channel chat major mode. +This mode represents a channel you are talking in. + +TARGET is the default target to send data to. +SERVER-BUFFER is the server buffer of this chat buffer. + +\\{circe-channel-mode-map}" + (add-hook 'kill-buffer-hook 'circe-channel-killed nil t)) + +(defun circe-channel-killed () + "Called when the channel buffer got killed. + +If we are not on the channel being killed, do nothing. Otherwise, +if the server is live, and the user wants to kill the buffer, +send PART to the server and clean up the channel's remaining +state." + (when (buffer-live-p circe-server-buffer) + (when (and circe-channel-killed-confirmation + (not (y-or-n-p "Really leave this channel? "))) + (error "Channel not left.")) + (ignore-errors + (irc-send-PART (circe-server-process) + circe-chat-target + circe-default-part-message)) + (ignore-errors + (circe-server-remove-chat-buffer circe-chat-target)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Channel User Tracking ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Channel mode buffers provide some utility functions to check if a +;; given user is idle or not. + +(defun circe-channel-user-nick-regain-p (_old new) + "Return true if a nick change from OLD to NEW constitutes a nick regain. + +A nick was regained if the NEW nick was also a recent user." + (let ((channel (irc-connection-channel (circe-server-process) + circe-chat-target))) + (when channel + (irc-channel-recent-user channel new)))) + +(defun circe-channel-user-p (nick) + "Return non-nil when NICK belongs to a channel user." + (cond + ((eq major-mode 'circe-query-mode) + (irc-string-equal-p (circe-server-process) + nick + circe-chat-target)) + ((eq major-mode 'circe-channel-mode) + (let ((channel (irc-connection-channel (circe-server-process) + circe-chat-target))) + (when channel + (if (irc-channel-user channel nick) + t + nil)))))) + +(defun circe-channel-nicks () + "Return a list of nicks in the current channel." + (let* ((channel (irc-connection-channel (circe-server-process) + circe-chat-target)) + (nicks nil)) + (when channel + (maphash (lambda (_folded-nick user) + (push (irc-user-nick user) nicks)) + (irc-channel-users channel))) + nicks)) + +(defun circe-user-channels (nick) + "Return a list of channel buffers for the user named NICK." + (let* ((result nil)) + (dolist (channel (irc-connection-channel-list (circe-server-process))) + (when (irc-channel-user channel nick) + (let* ((name (irc-channel-name channel)) + (buf (circe-server-get-chat-buffer name))) + (when buf + (push buf result))))) + result)) + +(defun circe-lurker-p (nick) + "Return a true value if this nick is regarded inactive." + (let* ((channel (irc-connection-channel (circe-server-process) + circe-chat-target)) + (user (when channel + (irc-channel-user channel nick))) + (recent-user (when channel + (irc-channel-recent-user channel nick))) + (last-active (cond + (user + (irc-user-last-activity-time user)) + (recent-user + (irc-user-last-activity-time recent-user))))) + (cond + ;; If we do not track lurkers, no one is ever a lurker. + ((not (circe-reduce-lurker-spam)) + nil) + ;; We ourselves are never lurkers (in this sense). + ((circe-server-my-nick-p nick) + nil) + ;; Someone who isn't even on the channel (e.g. NickServ) isn't a + ;; lurker, either. + ((and (not user) + (not recent-user)) + nil) + ;; If someone has never been active, they most definitely *are* a + ;; lurker. + ((not last-active) + t) + ;; But if someone has been active, and we mark active users + ;; inactive again after a timeout ... + (circe-active-users-timeout + ;; They are still lurkers if their activity has been too long + ;; ago. + (> (- (float-time) + last-active) + circe-active-users-timeout)) + ;; Otherwise, they have been active and we don't mark active + ;; users inactive again, so nope, not a lurker. + (t + nil)))) + +(defun circe-lurker-rejoin-p (nick channel) + "Return true if NICK is rejoining CHANNEL. + +A user is considered to be rejoining if they were on the channel +shortly before, and were active then." + (let* ((channel (irc-connection-channel (circe-server-process) + channel)) + (user (when channel + (irc-channel-recent-user channel nick)))) + (when user + (irc-user-last-activity-time user)))) + +(defun circe-lurker-display-active (nick userhost) + "Show that this user is active if they are a lurker." + (let* ((channel (irc-connection-channel (circe-server-process) + circe-chat-target)) + (user (when channel + (irc-channel-user channel nick))) + (join-time (when user + (irc-user-join-time user)))) + (when (and (circe-lurker-p nick) + ;; If we saw them when we joined the channel, no need to + ;; say "they're suddenly active!!111one". + join-time) + (circe-display 'circe-format-server-lurker-activity + :nick nick + :userhost (or userhost "server") + :jointime join-time + :joindelta (circe-duration-string + (- (float-time) + join-time)))))) + +;;;;;;;;;;;;;;;;;; +;;; Query Mode ;;; +;;;;;;;;;;;;;;;;;; + +(defvar circe-query-mode-hook nil + "Hook run when query mode is activated.") + +(defvar circe-query-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map circe-chat-mode-map) + map) + "The key map for query mode buffers.") + +(define-derived-mode circe-query-mode circe-chat-mode "Circe Query" + "The circe query chat major mode. +This mode represents a query you are talking in. + +TARGET is the default target to send data to. +SERVER-BUFFER is the server buffer of this chat buffer. + +\\{circe-query-mode-map}" + (add-hook 'kill-buffer-hook 'circe-query-killed nil t)) + +(defun circe-query-killed () + "Called when the query buffer got killed." + (ignore-errors + (circe-server-remove-chat-buffer circe-chat-target))) + +(defun circe-query-auto-query-buffer (who) + "Return a buffer for a query with `WHO'. + +This adheres to `circe-auto-query-max'." + (or (circe-server-get-chat-buffer who) + (when (< (circe--query-count) + circe-auto-query-max) + (circe-server-get-or-create-chat-buffer who 'circe-query-mode)))) + +(defun circe--query-count () + "Return the number of queries on the current server." + (let ((num 0)) + (dolist (buf (circe-server-chat-buffers)) + (with-current-buffer buf + (when (eq major-mode 'circe-query-mode) + (setq num (+ num 1))))) + num)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; IRC Protocol Handling ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar circe--irc-handler-table nil + "The handler table for Circe's IRC connections. + +Do not use this directly. Instead, call `circe-irc-handler-table'.") + +(defun circe-irc-handler-table () + (when (not circe--irc-handler-table) + (let ((table (irc-handler-table))) + (irc-handler-add table "irc.registered" #'circe--irc-conn-registered) + (irc-handler-add table "conn.disconnected" #'circe--irc-conn-disconnected) + (irc-handler-add table nil #'circe--irc-display-event) + (irc-handle-registration table) + (irc-handle-ping-pong table) + (irc-handle-isupport table) + (irc-handle-initial-nick-acquisition table) + (irc-handle-ctcp table) + (irc-handle-state-tracking table) + (irc-handle-nickserv table) + (irc-handle-auto-join table) + (setq circe--irc-handler-table table))) + circe--irc-handler-table) + +(defun circe--irc-conn-registered (conn _event _nick) + (with-current-buffer (irc-connection-get conn :server-buffer) + (setq circe-server-reconnect-attempts 0) + (run-hooks 'circe-server-connected-hook))) + +(defun circe--irc-conn-disconnected (conn _event) + (with-current-buffer (irc-connection-get conn :server-buffer) + (dolist (buf (circe-server-chat-buffers)) + (with-current-buffer buf + (circe-chat-disconnected))) + + (circe-reconnect))) + +(defun circe--irc-display-event (conn event &optional sender &rest args) + "Display an IRC message. + +NICK, USER and HOST specify the originator of COMMAND with ARGS +as arguments." + (with-current-buffer (irc-connection-get conn :server-buffer) + (let* ((display (circe-get-display-handler event)) + (nick (when sender + (irc-userstring-nick sender))) + (userhost (when sender + (irc-userstring-userhost sender)))) + (cond + ;; Functions get called + ((functionp display) + (apply display nick userhost event args)) + ;; Lists describe patterns + ((consp display) + (circe--irc-display-format (elt display 1) + (elt display 0) + nick userhost event args)) + ;; No configured display handler, show a default + (t + (circe--irc-display-default nick userhost event args)))))) + +(defvar circe--irc-format-server-numeric "*** %s" + "The format to use for server messages. Do not set this.") + +(defun circe--irc-display-format (format target nick userhost event args) + (let* ((target+name (circe--irc-display-target target nick args)) + (target (car target+name)) + (name (cdr target+name)) + (origin (if userhost + (format "%s (%s)" nick userhost) + (format "%s" nick)))) + (with-current-buffer (or target + (circe-server-last-active-buffer)) + (let ((circe--irc-format-server-numeric + (if target + (format "*** %s" format) + (format "*** [%s] %s" name format)))) + (circe-display 'circe--irc-format-server-numeric + :nick (or nick "(unknown)") + :userhost (or userhost "server") + :origin origin + :event event + :command event + :target name + :indexed-args args))))) + +(defun circe--irc-display-target (target nick args) + "Return the target buffer and name. +The buffer might be nil if it is not alive. + +See `circe-set-display-handler' for a description of target. + +NICK and USERHOST are the originator of COMMAND which had ARGS as +arguments." + (cond + ((eq target 'nick) + (cons (circe-server-get-chat-buffer nick) + nick)) + ((numberp target) + (let ((name (nth target + args))) + (cons (circe-server-get-chat-buffer name) + name))) + ((eq target 'active) + (let ((buf (circe-server-last-active-buffer))) + (cons buf + (buffer-name buf)))) + ((eq target 'server) + (cons (current-buffer) (buffer-name))) + (t + (error "Bad target in format string: %s" target)))) + +(defun circe--irc-display-default (nick userhost event args) + (with-current-buffer (circe-server-last-active-buffer) + (let ((target (if (circe-server-my-nick-p (car args)) + "" + (format " to %s" (car args))))) + (cond + ((string-match "\\`irc.ctcpreply.\\(.*\\)\\'" event) + (circe-display-server-message + (format "CTCP %s reply from %s (%s)%s: %s" + (match-string 1 event) nick userhost target (cadr args)))) + ((string-match "\\`irc.ctcp.\\(.*\\)\\'" event) + (circe-display-server-message + (format "Unknown CTCP request %s from %s (%s)%s: %s" + (match-string 1 event) nick userhost target (cadr args)))) + (t + (circe-display-server-message + (format "[%s from %s%s] %s" + event + nick + (if userhost + (format " (%s)" userhost) + "") + (mapconcat #'identity args " ")))))))) + +(defun circe-set-display-handler (command handler) + "Set the display handler for COMMAND to HANDLER. + +A handler is either a function or a list. + +A function gets called in the server buffer with at least three +arguments, but possibly more. There's at least NICK and USERHOST +of the sender, which can be nil, and COMMAND, which is the event +which triggered this. Further arguments are arguments to the +event. + +Alternatively, the handler can be a list of two elements: + + target - The target of this message + format - The format for this string + +The target can be any of: + + 'active - The last active buffer of this server + 'nick - The nick who sent this message + 'server - The server buffer for this server + number - The index of the argument of the target + +The format is passed to `lui-format'. Possible format string +substitutions are {mynick}, {target}, {nick}, {userhost}, +{origin}, {command}, {target}, and indexed arguments for the +arguments to the IRC message." + (when (not circe-display-table) + (setq circe-display-table (make-hash-table :test 'equal))) + (puthash command handler circe-display-table)) + +(defun circe-get-display-handler (command) + "Return the display handler for COMMAND. + +See `circe-set-display-handler' for more information." + (when circe-display-table + (gethash command circe-display-table))) + +;;;;;;;;;;;;;;;; +;;; Commands ;;; +;;;;;;;;;;;;;;;; + +(defun circe-command-AWAY (reason) + "Set yourself away with REASON." + (interactive "sReason: ") + (irc-send-AWAY (circe-server-process) reason)) + +(defun circe-command-BACK (&optional ignored) + "Mark yourself not away anymore. + +Arguments are IGNORED." + (interactive) + (irc-send-AWAY (circe-server-process))) + +(defun circe-command-CHTOPIC (&optional ignored) + "Insert the topic of the current channel. + +Arguments are IGNORED." + (interactive) + (if (not circe-chat-target) + (circe-display-server-message "No target for current buffer") + (let* ((channel (irc-connection-channel (circe-server-process) + circe-chat-target)) + (topic (when channel + (irc-channel-topic channel)))) + (lui-replace-input (format "/TOPIC %s %s" + circe-chat-target (or topic "")))) + (goto-char (point-max)))) + +(defun circe-command-CLEAR (&optional ignored) + "Delete all buffer contents before the lui prompt." + (let ((inhibit-read-only t)) + (delete-region (point-min) lui-output-marker))) + +(defun circe-command-CTCP (who &optional command argument) + "Send a CTCP message to WHO containing COMMAND with ARGUMENT. +If COMMAND is not given, WHO is parsed to contain all of who, +command and argument. +If ARGUMENT is nil, it is interpreted as no argument." + (when (not command) + (if (string-match "^\\([^ ]*\\) *\\([^ ]*\\) *\\(.*\\)" who) + (setq command (upcase (match-string 2 who)) + argument (match-string 3 who) + who (match-string 1 who)) + (circe-display-server-message "Usage: /CTCP "))) + (when (not (string= "" command)) + (irc-send-ctcp (circe-server-process) + who + command + (if (and argument (not (equal argument ""))) + argument + nil)))) + +(defun circe-command-FOOL (line) + "Add the regex on LINE to the `circe-fool-list'." + (with-current-buffer (circe-server-last-active-buffer) + (cond + ((string-match "\\S-+" line) + (let ((regex (match-string 0 line))) + (add-to-list 'circe-fool-list regex) + (circe-display-server-message (format "Recognizing %s as a fool" + regex)))) + ((not circe-fool-list) + (circe-display-server-message "Your do not know any fools")) + (t + (circe-display-server-message "Your list of fools:") + (dolist (regex circe-fool-list) + (circe-display-server-message (format "- %s" regex))))))) + +(defun circe-command-GAWAY (reason) + "Set yourself away on all servers with reason REASON." + (interactive "sReason: ") + (dolist (buf (circe-server-buffers)) + (with-current-buffer buf + (irc-send-AWAY circe-server-process reason)))) + +(defun circe-command-GQUIT (reason) + "Quit all servers with reason REASON." + (interactive "sReason: ") + (dolist (buf (circe-server-buffers)) + (with-current-buffer buf + (when (eq (process-status circe-server-process) + 'open) + (irc-send-QUIT circe-server-process reason))))) + +(defun circe-command-HELP (&optional ignored) + "Display a list of recognized commands, nicely formatted." + (circe-display-server-message + (concat "Recognized commands are: " + (mapconcat (lambda (s) s) (circe--commands-list) "")))) + +(defun circe-command-IGNORE (line) + "Add the regex on LINE to the `circe-ignore-list'." + (with-current-buffer (circe-server-last-active-buffer) + (cond + ((string-match "\\S-+" line) + (let ((regex (match-string 0 line))) + (add-to-list 'circe-ignore-list regex) + (circe-display-server-message (format "Ignore list, meet %s" + regex)))) + ((not circe-ignore-list) + (circe-display-server-message "Your ignore list is empty")) + (t + (circe-display-server-message "Your ignore list:") + (dolist (regex circe-ignore-list) + (circe-display-server-message (format "- %s" regex))))))) + +(defun circe-command-INVITE (nick &optional channel) + "Invite NICK to CHANNEL. +When CHANNEL is not given, NICK is assumed to be a string +consisting of two words, the nick and the channel." + (interactive "sInvite who: \nsWhere: ") + (when (not channel) + (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)" nick) + (setq channel (match-string 2 nick) + nick (match-string 1 nick)) + (when (or (string= "" nick) (null nick)) + (circe-display-server-message "Usage: /INVITE ")))) + (irc-send-INVITE (circe-server-process) + nick + (if (and (null channel) + (not (null nick))) + circe-chat-target + channel))) + +(defun circe-command-JOIN (channel) + "Join CHANNEL. This can also contain a key." + (interactive "sChannel: ") + (let (channels keys) + (when (string-match "^\\s-*\\([^ ]+\\)\\(:? \\([^ ]+\\)\\)?$" channel) + (setq channels (match-string 1 channel) + keys (match-string 3 channel)) + (dolist (channel (split-string channels ",")) + (pop-to-buffer + (circe-server-get-or-create-chat-buffer channel + 'circe-channel-mode))) + (irc-send-JOIN (circe-server-process) channels keys)))) + +(defun circe-command-ME (line) + "Send LINE to IRC as an action." + (interactive "sAction: ") + (if (not circe-chat-target) + (circe-display-server-message "No target for current buffer") + (circe-display 'circe-format-self-action + :body line + :nick (circe-nick)) + (irc-send-ctcp (circe-server-process) + circe-chat-target + "ACTION" line))) + +(defun circe-command-MSG (who &optional what) + "Send a message. + +Send WHO a message containing WHAT. + +If WHAT is not given, WHO should contain both the nick and the +message separated by a space." + (when (not what) + (if (string-match "^\\([^ ]*\\) \\(.*\\)" who) + (setq what (match-string 2 who) + who (match-string 1 who)) + (circe-display-server-message "Usage: /MSG "))) + (when what + (let ((buf (circe-query-auto-query-buffer who))) + (if buf + (with-current-buffer buf + (circe-command-SAY what) + (lui-add-input what)) + (with-current-buffer (circe-server-last-active-buffer) + (irc-send-PRIVMSG (circe-server-process) + who what) + (circe-display 'circe-format-self-message + :target who + :body what)))))) + +(defun circe-command-NAMES (&optional channel) + "List the names of the current channel or CHANNEL." + (interactive) + (let ((target (when channel + (string-trim channel)))) + (when (or (not target) + (equal target "")) + (setq target circe-chat-target)) + (if (not target) + (circe-display-server-message "No target for current buffer") + (irc-send-NAMES (circe-server-process) + target)))) + +(defun circe-command-NICK (newnick) + "Change nick to NEWNICK." + (interactive "sNew nick: ") + (let ((newnick (string-trim newnick))) + (irc-send-NICK (circe-server-process) newnick))) + +(defun circe-command-PART (reason) + "Part the current channel because of REASON." + (interactive "sReason: ") + (if (not circe-chat-target) + (circe-display-server-message "No target for current buffer") + (irc-send-PART (circe-server-process) + circe-chat-target + (if (equal "" reason) + circe-default-part-message + reason)))) + +(defun circe-command-PING (target) + "Send a CTCP PING request to TARGET." + (interactive "sWho: ") + (let ((target (string-trim target))) + (irc-send-ctcp (circe-server-process) + target + "PING" (format "%s" (float-time))))) + +(defun circe-command-QUERY (arg) + "Open a query with WHO." + ;; Eventually, this should probably be just the same as + ;; circe-command-MSG + (interactive "sQuery with: ") + (let* (who what) + (if (string-match "\\`\\s-*\\(\\S-+\\)\\s-\\(\\s-*\\S-.*\\)\\'" arg) + (setq who (match-string 1 arg) + what (match-string 2 arg)) + (setq who (string-trim arg))) + (when (string= who "") + (circe-display-server-message "Usage: /query [something to say]")) + (pop-to-buffer + (circe-server-get-or-create-chat-buffer who 'circe-query-mode)) + (when what + (circe-command-SAY what) + (lui-add-input what)))) + +(defun circe-command-QUIT (reason) + "Quit the current server giving REASON." + (interactive "sReason: ") + (with-circe-server-buffer + (setq circe-server-inhibit-auto-reconnect-p t) + (irc-send-QUIT (circe-server-process) + (if (equal "" reason) + circe-default-quit-message + reason)))) + +(defun circe-command-QUOTE (line) + "Send LINE verbatim to the server." + (interactive "Line: ") + (irc-send-raw (circe-server-process) line) + (with-current-buffer (circe-server-last-active-buffer) + (circe-display-server-message (format "Sent to server: %s" + line)))) + +(defun circe-command-SAY (line) + "Say LINE to the current target." + (interactive "sSay: ") + (if (not circe-chat-target) + (circe-display-server-message "No target for current buffer") + (dolist (line (circe--split-line line)) + (circe-display 'circe-format-self-say + :body line + :nick (circe-nick)) + (irc-send-PRIVMSG (circe-server-process) + circe-chat-target + ;; Some IRC servers give an error if there is + ;; no text at all. + (if (string= line "") + " " + line))))) + +(defun circe--split-line (longline) + "Splits LONGLINE into smaller components. + +IRC silently truncates long lines. This splits a long line into +parts that each are not longer than `circe-split-line-length'." + (if (< (length longline) + circe-split-line-length) + (list longline) + (with-temp-buffer + (insert longline) + (let ((fill-column circe-split-line-length)) + (fill-region (point-min) (point-max) + nil t)) + (split-string (buffer-string) "\n")))) + +(defun circe-command-SV (&optional ignored) + "Tell the current channel about your client and Emacs version. + +Arguments are IGNORED." + (interactive) + (circe-command-SAY (format (concat "I'm using Circe version %s " + "with %s %s (of %s)") + (circe--version) + "GNU Emacs" + emacs-version + (format-time-string "%Y-%m-%d" + emacs-build-time)))) + +(defun circe-command-TOPIC (channel &optional newtopic) + "Change the topic of CHANNEL to NEWTOPIC." + (interactive "sChannel: \nsNew topic: ") + (when (string-match "^\\s-*$" channel) + (setq channel nil)) + (when (and channel + (not newtopic) + (string-match "^\\s-*\\(\\S-+\\)\\( \\(.*\\)\\)?" channel)) + (setq newtopic (match-string 3 channel) + channel (match-string 1 channel))) + (cond + ((and channel newtopic) + (irc-send-TOPIC (circe-server-process) channel newtopic)) + (channel + (irc-send-TOPIC (circe-server-process) channel)) + (circe-chat-target + (irc-send-TOPIC (circe-server-process) circe-chat-target)) + (t + (circe-display-server-message "No channel given, and no default target.")))) + +(defun circe-command-UNFOOL (line) + "Remove the entry LINE from `circe-fool-list'." + (with-current-buffer (circe-server-last-active-buffer) + (cond + ((string-match "\\S-+" line) + (let ((regex (match-string 0 line))) + (setq circe-fool-list (delete regex circe-fool-list)) + (circe-display-server-message (format "Assuming %s is not a fool anymore" + regex)))) + (t + (circe-display-server-message + "No one is not a fool anymore? UNFOOL requires one argument"))))) + +(defun circe-command-UNIGNORE (line) + "Remove the entry LINE from `circe-ignore-list'." + (with-current-buffer (circe-server-last-active-buffer) + (cond + ((string-match "\\S-+" line) + (let ((regex (match-string 0 line))) + (setq circe-ignore-list (delete regex circe-ignore-list)) + (circe-display-server-message (format "Ignore list forgot about %s" + regex)))) + (t + (circe-display-server-message + "Who do you want to unignore? UNIGNORE requires one argument"))))) + +(defun circe-command-WHOAMI (&optional ignored) + "Request WHOIS information about yourself. + +Arguments are IGNORED." + (interactive) + (irc-send-WHOIS (circe-server-process) + (circe-nick))) + +(defun circe-command-WHOIS (whom) + "Request WHOIS information about WHOM." + (interactive "sWhois: ") + (let* ((whom-server-name (split-string whom)) + (whom (car whom-server-name)) + (server-or-name (cadr whom-server-name))) + (irc-send-WHOIS (circe-server-process) whom server-or-name))) + +(defun circe-command-WHOWAS (whom) + "Request WHOWAS information about WHOM." + (interactive "sWhois: ") + (let ((whom (string-trim whom))) + (irc-send-WHOWAS (circe-server-process) whom))) + +(defun circe-command-WL (&optional split) + "Show the people who left in a netsplit. +Without any arguments, shows shows the current netsplits and how +many people are missing. With an argument SPLIT, which must be a +number, it shows the missing people due to that split." + (let ((circe-netsplit-list (with-circe-server-buffer + circe-netsplit-list))) + (if (or (not split) + (and (stringp split) + (string= split ""))) + (if (null circe-netsplit-list) + (circe-display-server-message "No net split at the moment") + (let ((n 0)) + (dolist (entry circe-netsplit-list) + (circe-display-server-message (format "(%d) Missing %d people due to %s" + n + (hash-table-count (nth 3 entry)) + (car entry))) + (setq n (+ n 1))))) + (let* ((index (if (numberp split) + split + (string-to-number split))) + (entry (nth index circe-netsplit-list))) + (if (not entry) + (circe-display-server-message (format "No split number %s - use /WL to see a list" + split)) + (let ((missing nil)) + (maphash (lambda (_key value) + (setq missing (cons value missing))) + (nth 3 entry)) + (circe-display-server-message + (format "Missing people due to %s: %s" + (car entry) + (mapconcat 'identity + (sort missing + (lambda (a b) + (string< (downcase a) + (downcase b)))) + ", "))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;; +;;; Display Handlers ;;; +;;;;;;;;;;;;;;;;;;;;;;;; + +(defun circe-display-ignore (_nick _userhost _command &rest _args) + "Don't show a this message. + +NICK and USERHOST are the originator of COMMAND which had ARGS as +arguments." + 'noop) + +(circe-set-display-handler "317" 'circe-display-317) +(defun circe-display-317 (_sender ignored _numeric _target nick + idletime &optional signon-time body) + "Show a 317 numeric (RPL_WHOISIDLE). + +Arguments are either of the two: + +: 317 :seconds idle +: 317 :seconds idle, signon time" + (with-current-buffer (circe-server-last-active-buffer) + (let ((seconds-idle (string-to-number idletime)) + (signon-time (when body + (string-to-number signon-time)))) + (if signon-time + (circe-display 'circe-format-server-whois-idle-with-signon + :whois-nick nick + :idle-seconds seconds-idle + :idle-duration (circe-duration-string seconds-idle) + :signon-time signon-time + :signon-date (current-time-string + (seconds-to-time signon-time)) + :signon-ago (circe-duration-string (- (float-time) + signon-time))) + (circe-display 'circe-format-server-whois-idle + :whois-nick nick + :idle-seconds seconds-idle + :idle-duration (circe-duration-string seconds-idle)))))) + +(circe-set-display-handler "329" 'circe-display-329) +(defun circe-display-329 (_server ignored _numeric _target channel timestamp) + "Show a 329 numeric (RPL_CREATIONTIME)." + (with-current-buffer (or (circe-server-get-chat-buffer channel) + (circe-server-last-active-buffer)) + (let ((creation-time (string-to-number timestamp))) + (circe-display 'circe-format-server-channel-creation-time + :channel channel + :date (current-time-string + (seconds-to-time creation-time)) + :ago (circe-duration-string (- (float-time) + creation-time)))))) + +(circe-set-display-handler "333" 'circe-display-333) +(defun circe-display-333 (_server ignored _numeric target + channel setter topic-time) + "Show a 333 numeric (RPL_TOPICWHOTIME). + +Arguments are either of the two: + +: 333 1434996762 +: 333 !@ 1434996803" + (let ((channel-buffer (circe-server-get-chat-buffer channel)) + (topic-time (string-to-number topic-time))) + (with-current-buffer (or channel-buffer + (circe-server-last-active-buffer)) + (circe-display (if channel-buffer + 'circe-format-server-topic-time + 'circe-format-server-topic-time-for-channel) + :nick target + :channel channel + :setter (irc-userstring-nick setter) + :setter-userhost (or (irc-userstring-userhost setter) + "(unknown)") + :topic-time topic-time + :topic-date (current-time-string + (seconds-to-time topic-time)) + :topic-ago (circe-duration-string (- (float-time) + topic-time)))))) + +(circe-set-display-handler "AUTHENTICATE" 'circe-display-ignore) +(circe-set-display-handler "CAP" 'circe-display-ignore) +(circe-set-display-handler "conn.connected" 'circe-display-ignore) +(circe-set-display-handler "conn.disconnected" 'circe-display-ignore) + +(circe-set-display-handler "irc.ctcp" 'circe-display-ignore) +(circe-set-display-handler "irc.ctcpreply" 'circe-display-ignore) + +(circe-set-display-handler "irc.ctcp.ACTION" 'circe-display-ctcp-action) +(defun circe-display-ctcp-action (nick userhost _command target text) + "Show an ACTION." + (cond + ;; Query + ((circe-server-my-nick-p target) + (let ((query-buffer (circe-query-auto-query-buffer nick))) + (with-current-buffer (or query-buffer + (circe-server-last-active-buffer)) + (circe-display (if query-buffer + 'circe-format-action + 'circe-format-message-action) + :nick nick + :userhost (or userhost "server") + :body text)))) + ;; Channel + (t + (with-current-buffer (circe-server-get-or-create-chat-buffer + target 'circe-channel-mode) + (circe-lurker-display-active nick userhost) + (circe-display 'circe-format-action + :nick nick + :userhost (or userhost "server") + :body text))))) + +(circe-set-display-handler "irc.ctcp.CLIENTINFO" 'circe-display-ctcp) + +(circe-set-display-handler "irc.ctcp.PING" 'circe-display-ctcp-ping) +(defun circe-display-ctcp-ping (nick userhost _command target text) + "Show a CTCP PING request." + (with-current-buffer (circe-server-last-active-buffer) + (circe-display 'circe-format-server-ctcp-ping + :nick nick + :userhost (or userhost "server") + :target target + :body (or text "") + :ago (let ((time (string-to-number text))) + (if time + (format "%.2f seconds" (- (float-time) time)) + "unknown seconds"))))) + +(circe-set-display-handler "irc.ctcpreply.PING" 'circe-display-ctcp-ping-reply) +(defun circe-display-ctcp-ping-reply (nick userhost _command target text) + "Show a CTCP PING reply." + (with-current-buffer (circe-server-last-active-buffer) + (circe-display 'circe-format-server-ctcp-ping-reply + :nick nick + :userhost (or userhost "server") + :target target + :body text + :ago (let ((time (string-to-number text))) + (if time + (format "%.2f seconds" (- (float-time) time)) + "unknown seconds"))))) + +(circe-set-display-handler "irc.ctcp.SOURCE" 'circe-display-ctcp) +(circe-set-display-handler "irc.ctcp.TIME" 'circe-display-ctcp) +(circe-set-display-handler "irc.ctcp.VERSION" 'circe-display-ctcp) +(defun circe-display-ctcp (nick userhost command target text) + "Show a CTCP request that does not require special handling." + (with-current-buffer (circe-server-last-active-buffer) + (circe-display 'circe-format-server-ctcp + :nick nick + :userhost (or userhost "server") + :target target + :command (substring command 9) + :body (or text "")))) + +(circe-set-display-handler "irc.registered" 'circe-display-ignore) + +(circe-set-display-handler "JOIN" 'circe-display-JOIN) +(defun circe-display-JOIN (nick userhost _command channel + &optional accountname realname) + "Show a JOIN message. + +The command receives an extra argument, the account name, on some +IRC servers." + (let* ((accountname (if (equal accountname "*") + "(unauthenticated)" + accountname)) + (userinfo (if accountname + (format "%s, %s: %s" userhost accountname realname) + userhost)) + (split (circe--netsplit-join nick))) + ;; First, update the channel + (with-current-buffer (circe-server-get-or-create-chat-buffer + channel 'circe-channel-mode) + (cond + (split + (let ((split-time (cadr split))) + (when (< (+ split-time circe-netsplit-delay) + (float-time)) + (circe-display 'circe-format-server-netmerge + :split (car split) + :time (cadr split) + :date (current-time-string + (seconds-to-time (cadr split))) + :ago (circe-duration-string + (- (float-time) (cadr split))))))) + ((and (circe-reduce-lurker-spam) + (circe-lurker-rejoin-p nick circe-chat-target)) + (let* ((channel (irc-connection-channel (circe-server-process) + circe-chat-target)) + (user (when channel + (irc-channel-recent-user channel nick))) + (departed (when user + (irc-user-part-time user)))) + (circe-display 'circe-format-server-rejoin + :nick nick + :userhost (or userhost "server") + :accountname accountname + :realname realname + :userinfo userinfo + :departuretime departed + :departuredelta (circe-duration-string + (- (float-time) + departed))))) + ((not (circe-reduce-lurker-spam)) + (circe-display 'circe-format-server-join + :nick nick + :userhost (or userhost "server") + :accountname accountname + :realname realname + :userinfo userinfo + :channel circe-chat-target)))) + ;; Next, a possible query buffer. We do this even when the message + ;; should be ignored by a netsplit, since this can't flood. + (let ((buf (circe-server-get-chat-buffer nick))) + (when buf + (with-current-buffer buf + (circe-display 'circe-format-server-join-in-channel + :nick nick + :userhost (or userhost "server") + :accountname accountname + :realname realname + :userinfo userinfo + :channel circe-chat-target)))))) + +(circe-set-display-handler "MODE" 'circe-display-MODE) +(defun circe-display-MODE (setter userhost _command target &rest modes) + "Show a MODE message." + (with-current-buffer (or (circe-server-get-chat-buffer target) + (circe-server-last-active-buffer)) + (circe-display 'circe-format-server-mode-change + :setter setter + :userhost (or userhost "server") + :target target + :change (mapconcat #'identity modes " ")))) + +(circe-set-display-handler "NICK" 'circe-display-NICK) +(defun circe-display-NICK (old-nick userhost _command new-nick) + "Show a nick change." + (if (circe-server-my-nick-p new-nick) + (dolist (buf (cons (or circe-server-buffer + (current-buffer)) + (circe-server-chat-buffers))) + (with-current-buffer buf + (circe-display 'circe-format-server-nick-change-self + :old-nick old-nick + :userhost (or userhost "server") + :new-nick new-nick))) + (let ((query-buffer (circe-server-get-chat-buffer old-nick))) + (when query-buffer + (with-current-buffer query-buffer + (circe-server-rename-chat-buffer old-nick new-nick) + (circe-display 'circe-format-server-nick-change + :old-nick old-nick + :new-nick new-nick + :userhost (or userhost "server"))))) + (dolist (buf (circe-user-channels new-nick)) + (with-current-buffer buf + (cond + ((and (circe-reduce-lurker-spam) + (circe-lurker-p new-nick)) + nil) + ((circe-channel-user-nick-regain-p old-nick new-nick) + (circe-display 'circe-format-server-nick-regain + :old-nick old-nick + :new-nick new-nick + :userhost (or userhost "server"))) + (t + (circe-display 'circe-format-server-nick-change + :old-nick old-nick + :new-nick new-nick + :userhost (or userhost "server")))))))) + +(circe-set-display-handler "nickserv.identified" 'circe-display-ignore) + +;; NOTICE is also used to encode CTCP replies. irc.el will send +;; irc.notice events for NOTICEs without CTCP replies, so we show +;; that, not the raw notice. +(circe-set-display-handler "NOTICE" 'circe-display-ignore) +(circe-set-display-handler "irc.notice" 'circe-display-NOTICE) +(defun circe-display-NOTICE (nick userhost _command target text) + "Show a NOTICE message." + (cond + ((not userhost) + (with-current-buffer (circe-server-last-active-buffer) + (circe-display 'circe-format-server-notice + :server nick + :body text))) + ((circe-server-my-nick-p target) + (with-current-buffer (or (circe-server-get-chat-buffer nick) + (circe-server-last-active-buffer)) + (circe-display 'circe-format-notice + :nick nick + :userhost (or userhost "server") + :body text))) + (t + (with-current-buffer (or (circe-server-get-chat-buffer target) + (circe-server-last-active-buffer)) + (circe-display 'circe-format-notice + :nick nick + :userhost (or userhost "server") + :body text))))) + +(circe-set-display-handler "PART" 'circe-display-PART) +(defun circe-display-PART (nick userhost _command channel &optional reason) + "Show a PART message." + (with-current-buffer (or (circe-server-get-chat-buffer channel) + (circe-server-last-active-buffer)) + (when (or (not circe-chat-target) + (not (circe-lurker-p nick))) + (circe-display 'circe-format-server-part + :nick nick + :userhost (or userhost "server") + :channel channel + :reason (or reason "[No reason given]"))))) + +(circe-set-display-handler "PING" 'circe-display-ignore) +(circe-set-display-handler "PONG" 'circe-display-ignore) + +;; PRIVMSG is also used to encode CTCP requests. irc.el will send +;; irc.message events for PRIVMSGs without CTCP messages, so we show +;; that, not the raw message. +(circe-set-display-handler "PRIVMSG" 'circe-display-ignore) +(circe-set-display-handler "irc.message" 'circe-display-PRIVMSG) +(defun circe-display-PRIVMSG (nick userhost _command target text) + "Show a PRIVMSG message." + (cond + ((circe-server-my-nick-p target) + (let ((buf (circe-query-auto-query-buffer nick))) + (if buf + (with-current-buffer buf + (circe-display 'circe-format-say + :nick nick + :userhost (or userhost "server") + :body text)) + (with-current-buffer (circe-server-last-active-buffer) + (circe-display 'circe-format-message + :nick nick + :userhost (or userhost "server") + :body text))))) + (t + (with-current-buffer (circe-server-get-or-create-chat-buffer + target 'circe-channel-mode) + (circe-lurker-display-active nick userhost) + (circe-display 'circe-format-say + :nick nick + :userhost (or userhost "server") + :body text))))) + +(circe-set-display-handler "TOPIC" 'circe-display-topic) +(defun circe-display-topic (nick userhost _command channel new-topic) + "Show a TOPIC change." + (with-current-buffer (circe-server-get-or-create-chat-buffer + channel 'circe-channel-mode) + (let* ((channel-obj (irc-connection-channel (circe-server-process) + channel)) + (old-topic (or (when channel + (irc-channel-last-topic channel-obj)) + ""))) + (circe-display 'circe-format-server-topic + :nick nick + :userhost (or userhost "server") + :channel channel + :new-topic new-topic + :old-topic old-topic + :topic-diff (circe--topic-diff old-topic new-topic))))) + +(defun circe--topic-diff (old new) + "Return a colored topic diff between OLD and NEW." + (mapconcat (lambda (elt) + (cond + ((eq '+ (car elt)) + (let ((s (cadr elt))) + (add-face-text-property 0 (length s) + 'circe-topic-diff-new-face nil s) + s)) + ((eq '- (car elt)) + (let ((s (cadr elt))) + (add-face-text-property 0 (length s) + 'circe-topic-diff-removed-face nil s) + s)) + (t + (cadr elt)))) + (lcs-unified-diff (circe--topic-diff-split old) + (circe--topic-diff-split new) + 'string=) + "")) + +(defun circe--topic-diff-split (str) + "Split STR into a list of components. +The list consists of words and spaces." + (let ((lis nil)) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (while (< (point) + (point-max)) + (if (or (looking-at "\\w+\\W*") + (looking-at ".\\s-*")) + (progn + (setq lis (cons (match-string 0) + lis)) + (replace-match "")) + (error "Can't happen")))) + (nreverse lis))) + +(circe-set-display-handler "channel.quit" 'circe-display-channel-quit) +(defun circe-display-channel-quit (nick userhost _command channel + &optional reason) + "Show a QUIT message." + (let ((split (circe--netsplit-quit reason nick))) + (with-current-buffer (circe-server-get-or-create-chat-buffer + channel 'circe-channel-mode) + (cond + (split + (when (< (+ split circe-netsplit-delay) + (float-time)) + (circe-display 'circe-format-server-netsplit + :split reason))) + ((not (circe-lurker-p nick)) + (circe-display 'circe-format-server-quit-channel + :nick nick + :userhost (or userhost "server") + :channel channel + :reason (or reason "[no reason given]"))))))) + +(circe-set-display-handler "QUIT" 'circe-display-QUIT) +(defun circe-display-QUIT (nick userhost _command &optional reason) + "Show a QUIT message. + +Channel quits are shown already, so just show quits in queries." + (let ((buf (circe-server-get-chat-buffer nick))) + (when buf + (with-current-buffer buf + (circe-display 'circe-format-server-quit + :nick nick + :userhost (or userhost "server") + :reason (or reason "[no reason given]")))))) + +(defvar circe-netsplit-list nil + "A list of recorded netsplits. +Every item is a list with four elements: +- The quit message for this split. +- The time when last we heard about a join in this split +- The time when last we heard about a quit in this split +- A hash table noting which nicks did leave") +(make-variable-buffer-local 'circe-netsplit-list) + +(defun circe--netsplit-join (nick) + "Search for NICK in the netsplit lists. +This either returns a pair whose car is the quit message of this +split, and the cadr the time we last heard anything of the split +of that user. If the NICK isn't split, this returns nil." + (with-circe-server-buffer + (catch 'return + (dolist (entry circe-netsplit-list) + (let ((table (nth 3 entry))) + (when (gethash nick table) + (let ((name (nth 0 entry)) + (time (nth 1 entry))) + (remhash nick table) + (when (= 0 (hash-table-count table)) + (setq circe-netsplit-list + (delq entry circe-netsplit-list))) + (setcar (cdr entry) + (float-time)) + (throw 'return (list name time)))))) + nil))) + +(defun circe--netsplit-quit (reason nick) + "If REASON indicates a netsplit, mark NICK as splitted. +This either returns the time when last we heard about this split, +or nil when this isn't a split." + (when (circe--netsplit-reason-p reason) + (with-circe-server-buffer + (let ((entry (assoc reason circe-netsplit-list))) + (if entry + (let ((time (nth 2 entry)) + (table (nth 3 entry))) + (setcar (cddr entry) + (float-time)) + (puthash nick nick table) + time) + ;; New split! + (let ((table (make-hash-table :test 'equal))) + (puthash nick nick table) + (setq circe-netsplit-list + (cons (list reason 0 (float-time) table) + circe-netsplit-list)) + 0)))))) + +(defun circe--netsplit-reason-p (reason) + "Return non-nil if REASON is the quit message of a netsplit. +This is true when it contains exactly two hosts, with a single +space in between them. The hosts must include at least one dot, +and must not include colons or slashes (else they might be +URLs). (Thanks to irssi for this criteria list)" + (if (string-match "^[^ :/]+\\.[^ :/]* [^ :/]+\\.[^ :/]*$" + reason) + t + nil)) + +(let ((simple-format-specifiers + '(("INVITE" active "Invite: {origin} invites you to {1}") + ("KICK" 0 "Kick: {1} kicked by {origin}: {2}") + ("ERROR" active "Error: {0-}") + ("001" server "{1}") + ("002" server "{1}") + ("003" server "{1}") + ("004" server "{1-}") + ("005" server "{1-}") + ;; IRCnet: * Please wait while we process your connection. + ("020" server "{0-}") + ;; IRCnet + ("042" server "Your unique ID is {1}") + ("200" active "{1-}") + ("201" active "{1-}") + ("203" active "{1-}") + ("204" active "{1-}") + ("205" active "{1-}") + ("206" active "{1-}") + ("207" active "{1-}") + ("208" active "{1-}") + ("209" active "{1-}") + ("211" active "{1-}") + ("212" active "{1-}") + ("219" active "{1-}") + ("221" active "User mode: {1-}") + ("234" active "Service: {1-}") + ("235" active "{1-}") + ("242" active "{1}") + ("243" active "{1-}") + ("250" server "{1}") + ("251" server "{1}") + ("252" server "{1-}") + ("253" server "{1-}") + ("254" server "{1-}") + ("255" server "{1}") + ("256" active "{1-}") + ("257" active "{1}") + ("258" active "{1}") + ("259" active "{1}") + ("261" active "{1-}") + ("262" active "{1-}") + ("263" active "{1-}") + ("265" server "{1-}") + ("266" server "{1-}") + ;; This is returned on both WHOIS and PRIVMSG. It + ;; should go to the active window for the former, and + ;; the query window for the latter. Oh well. + ("301" active "User away: {1}") + ("302" active "User hosts: {1}") + ("303" active "Users online: {1}") + ("305" active "{1}") + ("306" active "{1}") + ("307" active "{1-}") + ;; Coldfront: 310 is available for help. + ("310" active "{1-}") + ("311" active "{1} is {2}@{3} ({5})") + ("312" active "{1} is on {2} ({3})") + ("313" active "{1} {2}") + ("314" active "{1} was {2}@{3} ({5})") + ("315" active "{2}") + ("318" active "{2}") + ("319" active "{1} is on {2}") + ("320" active "{1-}") + ("322" active "{1-}") + ("323" active "{1-}") + ("324" 1 "Channel mode for {1}: {2-}") + ("325" 1 "Unique operator on {1} is {2}") + ("328" 1 "Channel homepage for {1}: {2-}") + ("330" active "{1} is logged in as {2}") + ("331" 1 "No topic for {1} set") + ("332" 1 "Topic for {1}: {2}") + ("341" active "Inviting {1} to {2}") + ("346" 1 "Invite mask: {2}") + ("347" 1 "{2}") + ("348" 1 "Except mask: {2}") + ("349" 1 "{2}") + ("351" active "{1-}") + ("352" active "{5} ({2}@{3}) in {1} on {4}: {6-}") + ("353" 2 "Names: {3}") + ("364" active "{1-}") + ("365" active "{1-}") + ("366" 1 "{2}") + ("367" 1 "Ban mask: {2}") + ("368" 1 "{2}") + ("369" active "{1} {2}") + ("371" active "{1}") + ("372" server "{1}") + ("374" active "{1}") + ("375" server "{1}") + ("376" server "{1}") + ("378" active "{1-}") + ("381" active "{1}") + ("382" active "{1-}") + ("391" active "Time on {1}: {2}") + ("401" active "No such nick: {1}") + ("402" active "No such server: {1}") + ("403" active "No such channel: {1}") + ("404" 1 "Can not send to channel {1}") + ("405" active "Can not join {1}: {2}") + ("406" active "{1-}") + ("407" active "{1-}") + ("408" active "No such service: {1}") + ("422" active "{1}") + ("432" active "Erroneous nick name: {1}") + ("433" active "Nick name in use: {1}") + ("437" active "Nick/channel is temporarily unavailable: {1}") + ("441" 2 "User not on channel: {1}") + ("442" active "You are not on {1}") + ("443" 2 "User {1} is already on channel {2}") + ;; Coldfront: 451 * :You have not registered + ("451" active "{1-}") + ("467" 1 "{2}") + ("470" 1 "{1} made you join {2}: {3-}") + ("471" 1 "{2}") + ("472" active "{1-}") + ("473" active "{1-}") + ("474" active "{1-}") + ("475" active "{1-}") + ("476" active "{1-}") + ("477" active "{1-}") + ("481" 1 "{2-}") + ("484" active "{1-}") + ;; Coldfront: 671 is using a Secure Connection + ("671" active "{1-}") + ("728" 1 "Quiet mask: {3}") + ("729" 1 "{3-}") + ;; Freenode SASL auth + ("900" active "SASL: {3-}") + ("903" active "{1-}")))) + (dolist (fmt simple-format-specifiers) + (circe-set-display-handler (car fmt) (cdr fmt)))) + +(defun circe-set-message-target (command target) + "Set the target of COMMAND to TARGET. + +This can be used to change format-based display handlers more +easily." + (let ((handler (circe-get-display-handler command))) + (when (not (consp handler)) + (error "Handler of command %s is not a list" command)) + (setcar handler target))) + +;;;;;;;;;;;;;;;;;;;;;;;; +;;; Helper Functions ;;; +;;;;;;;;;;;;;;;;;;;;;;;; + +(defun circe--list-drop-right (list pattern) + "Drop elements from the right of LIST that match PATTERN. + +LIST should be a list of strings, and PATTERN is used as a +regular expression." + (let ((list (reverse list))) + (while (and list + (string-match pattern (car list))) + (setq list (cdr list))) + (nreverse list))) + +(defun circe--nick-next (oldnick) + "Return a new nick to try for OLDNICK." + (cond + ;; If the nick ends with -+, replace those with _ + ((string-match "^\\(.*[^-]\\)\\(-+\\)$" oldnick) + (concat (match-string 1 oldnick) + (make-string (- (match-end 2) + (match-beginning 2)) + ?_))) + ;; If the nick is 9 chars long, take prefix and rotate. + ((>= (length oldnick) + 9) + (when (string-match "^\\(.*[^-_]\\)[-_]*$" oldnick) + (let ((nick (match-string 1 oldnick))) + (concat (substring nick 1) + (string (aref nick 0)))))) + ;; If the nick ends with _+ replace those with - and add one + ((string-match "^\\(.*[^_]\\)\\(_+\\)$" oldnick) + (concat (match-string 1 oldnick) + (make-string (- (match-end 2) + (match-beginning 2)) + ?-) + "-")) + ;; Else, just append - + (t + (concat oldnick "-")))) + +(defun circe-duration-string (duration) + "Return a description of a DURATION in seconds." + (let ((parts `((,(* 12 30 24 60 60) "year") + (,(* 30 24 60 60) "month") + (,(* 24 60 60) "day") + (,(* 60 60) "hour") + (60 "minute") + (1 "second"))) + (duration (round duration)) + (result nil)) + (dolist (part parts) + (let* ((seconds-per-part (car part)) + (description (cadr part)) + (count (/ duration seconds-per-part))) + (when (not (zerop count)) + (setq result (cons (format "%d %s%s" + count description + (if (= count 1) "" "s")) + result))) + (setq duration (- duration (* count seconds-per-part))))) + (if result + (mapconcat #'identity + (nreverse result) + " ") + "a moment"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Deprecated functions and variables + +(define-obsolete-function-alias 'circe-server-nick 'circe-nick + "Circe 2.0") + +(define-obsolete-function-alias 'circe-server-message + 'circe-display-server-message + "Circe 2.0") + +(define-obsolete-variable-alias 'circe-networks 'circe-network-defaults + "Circe 2.0") + +(define-obsolete-variable-alias 'circe-server-name 'circe-host + "Circe 2.0") + +(define-obsolete-variable-alias 'circe-server-service 'circe-port + "Circe 2.0") + +(define-obsolete-variable-alias 'circe-server-network 'circe-network + "Circe 2.0") + +(define-obsolete-variable-alias 'circe-server-ip-family 'circe-ip-family + "Circe 2.0") + +(define-obsolete-variable-alias 'circe-server-nick 'circe-nick + "Circe 2.0") + +(define-obsolete-variable-alias 'circe-server-user 'circe-user + "Circe 2.0") + +(define-obsolete-variable-alias 'circe-server-pass 'circe-pass + "Circe 2.0") + +(define-obsolete-variable-alias 'circe-server-realname 'circe-realname + "Circe 2.0") + +(define-obsolete-variable-alias 'circe-server-use-tls 'circe-use-tls + "Circe 2.0") + +(define-obsolete-variable-alias 'circe-server-auto-join-channels + 'circe-channels + "Circe 2.0") + +(provide 'circe) +;;; circe.el ends here diff --git a/elpa/circe-20161102.1405/irc.el b/elpa/circe-20161102.1405/irc.el new file mode 100644 index 00000000..d830e023 --- /dev/null +++ b/elpa/circe-20161102.1405/irc.el @@ -0,0 +1,1406 @@ +;;; irc.el --- Library to handle IRC connections -*- lexical-binding: t -*- + +;; Copyright (C) 2015 Jorgen Schaefer + +;; Author: Jorgen Schaefer +;; URL: https://github.com/jorgenschaefer/circe + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General 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 main entry function is `irc-connect'. This creates a new +;; connection to an IRC server, and also takes an event handler table +;; which is used to run various event handlers. Handlers receive a +;; connection object which can be used for other API calls. + +;; IRC connection objects also accept connection options. These can be +;; queried using `irc-connection-get', and are set by `irc-connect' or +;; later using `irc-connection-put'. + +;; Event handler tables are simple maps of names to functions. See +;; `irc-handler-table', `irc-handler-add' and `irc-handler-run' for +;; the API. + +;; To send commands to the server, use `irc-send-raw' or +;; `irc-send-command'. + +;; The rest of the library are handler packs that add support for +;; various IRC features. + +;;; Code: + +(require 'cl-lib) +(require 'make-tls-process) + +(defvar irc-debug-log nil + "Emit protocol debug info if this is non-nil.") + +;;;;;;;;;;;;;;;;;;;;;;; +;;; Connection function + +(defun irc-connect (&rest keywords) + "Connect to an IRC server. + +Supported keyword arguments: + +:name NAME -- The name for the process +:host HOST -- The host to connect to +:service SERVICE -- The service or port to connect to +:tls BOOL -- Whether to use TLS +:family IP-FAMILY -- Force using of ipv4 or ipv6 +:handler-table HANDLER -- The event handler table to send events to. + +The following events are supported: + +conn.connected conn -- The connection was established +conn.failed conn -- The connection could not be established +conn.disconnected conn -- A previously established connection was lost + +NNN conn sender args... -- A numeric reply from IRC was received +COMMAND conn sender args... -- An IRC command message was received" + (let ((proc (funcall (if (plist-get keywords :tls) + #'make-tls-process + #'make-network-process) + :name (or (plist-get keywords :name) + (plist-get keywords :host)) + :host (or (plist-get keywords :host) + (error "Must specify a :host to connect to")) + :service (or (plist-get keywords :service) + (error "Must specify a :service to connect to")) + :family (plist-get keywords :family) + :coding 'no-conversion + :nowait (featurep 'make-network-process '(:nowait t)) + :noquery t + :filter #'irc--filter + :sentinel #'irc--sentinel + :plist keywords + :keepalive t))) + ;; When we used `make-network-process' without :nowait, the + ;; sentinel is not called with the open event, so we do this + ;; manually. + (when (eq (process-status proc) 'open) + (irc--sentinel proc "open manually")) + proc)) + +(defun irc-connection-get (conn propname) + "Return the value of CONN's PROPNAME property." + (process-get conn propname)) + +(defun irc-connection-put (conn propname value) + "Change CONN's PROPNAME property to VALUE." + (process-put conn propname value)) + +(defun irc--sentinel (proc event) + (cond + ((string-match "\\`failed" event) + (irc-event-emit proc "conn.failed")) + ((string-match "\\`open" event) + (irc-event-emit proc "conn.connected")) + ((string-match "\\`\\(connection broken\\|finished\\|exited abnormally\\)" + event) + (irc-event-emit proc "conn.disconnected")) + ((string-match "\\`\\(deleted\\|killed\\)" event) + nil) + (t + (error "Unknown event in IRC sentinel: %S" event)))) + +(defvar irc--filter-running-p nil + "Non-nil when we're currently processing a message. + +Yep, this is a mutex. Why would one need a mutex in Emacs, a +single-threaded application, you ask? Easy! + +When, during the execution of a process filter, any piece of code +waits for process output - e.g. because they started a some +external program - Emacs will process any input from external +processes. Including the one for the filter that is currently +running. + +If that process does emit output, the filter is run again, while +it is already running. If the filter is not careful, this can +cause data to arrive out of order, or get lost.") + +(defun irc--filter (proc data) + "Handle data from the process." + (irc-connection-put proc :conn-data + (concat (or (irc-connection-get proc :conn-data) + "") + data)) + (when (not irc--filter-running-p) + (let ((irc--filter-running-p t) + (data (irc-connection-get proc :conn-data))) + (while (string-match "\r?\n" data) + (let ((line (substring data 0 (match-beginning 0)))) + (setq data (substring data (match-end 0))) + (irc-connection-put proc :conn-data data) + (irc--handle-line proc line) + (setq data (irc-connection-get proc :conn-data))))))) + +(defun irc--handle-line (proc line) + "Handle a single line from the IRC server. + +The command is simply passed to the event handler of the IRC +connection." + (irc-debug-out proc "S: %s" line) + (let* ((parsed (irc--parse line)) + (sender (car parsed)) + (command (cadr parsed)) + (args (cddr parsed))) + (apply #'irc-event-emit proc command sender args))) + +(defun irc--parse (line) + "Parse a line from IRC. + +Returns a list: (sender command args...) + +A line from IRC is a space-separated list of arguments. If the +first word starts with a colon, that's the sender. The first or +second word is the command. All further words are arguments. The +first word to start with a colon ends the argument list. + +Examples: + +COMMAND +COMMAND arg +COMMAND arg1 arg2 +COMMAND arg1 arg2 :arg3 still arg3 +:sender COMMAND arg1 arg2 :arg3 still arg3" + (with-temp-buffer + (insert line) + (goto-char (point-min)) + (let ((sender nil) + (args nil)) + ;; Optional sender. + (when (looking-at ":\\([^ ]+\\) ") + (setq sender (decode-coding-string + (match-string 1) + 'undecided)) + (goto-char (match-end 0))) + + ;; COMMAND. + (unless (looking-at "\\([^ ]+\\)") + (error "Invalid message: %s" line)) + (push (decode-coding-string (match-string 1) 'undecided) + args) + (goto-char (match-end 0)) + + ;; Arguments. + (while (re-search-forward " :\\(.*\\)\\| \\([^ ]*\\)" nil t) + (push (decode-coding-string + (or (match-string 1) + (match-string 2)) + 'undecided) + args)) + + (cons sender (nreverse args))))) + +(defun irc-userstring-nick (userstring) + "Return the nick in a given USERSTRING. + +USERSTRING is a typical nick!user@host prefix as used by IRC." + (if (string-match "\\`\\([^!]+\\)!\\([^@]+\\)@\\(.*\\)\\'" userstring) + (match-string 1 userstring) + userstring)) + +(defun irc-userstring-userhost (userstring) + "Return the nick in a given USERSTRING. + +USERSTRING is a typical nick!user@host prefix as used by IRC." + (if (string-match "\\`\\([^!]+\\)!\\([^@]+@.*\\)\\'" userstring) + (match-string 2 userstring) + nil)) + +(defun irc-event-emit (conn event &rest args) + "Run the event handlers for EVENT in CONN with ARGS." + (irc-debug-out conn + "E: %S %s" + event + (mapconcat (lambda (elt) (format "%S" elt)) + args + " ")) + (let ((handler-table (irc-connection-get conn :handler-table))) + (when handler-table + (apply #'irc-handler-run handler-table event conn event args) + (apply #'irc-handler-run handler-table nil conn event args)))) + +;;;;;;;;;;;;;;;;;;;;;;; +;;; Event handler table + +(defun irc-handler-table () + "Return a new event handler table." + (make-hash-table :test 'equal)) + +(defun irc-handler-add (table event handler) + "Add HANDLER for EVENT to the event handler table TABLE." + (puthash event + (append (gethash event table) + (list handler)) + table)) + +(defun irc-handler-remove (table event handler) + "Remove HANDLER for EVENT to the event handler table TABLE." + (puthash event + (delete handler + (gethash event table)) + table)) + +(defun irc-handler-run (table event &rest args) + "Run the handlers for EVENT in TABLE, passing ARGS to each." + (dolist (handler (gethash event table)) + (if debug-on-error + (apply handler args) + (condition-case err + (apply handler args) + (error + (message "Error running event %S handler %S: %s (args were %S)" + event handler err args)))))) + +;;;;;;;;;;; +;;; Sending + +(defun irc-send-raw (conn line &optional flood-handling) + "Send a line LINE to the IRC connection CONN. + +LINE should not include the trailing newline. + +FLOOD-HANDLING defines how to handle the situation when we are +sending too much data. It can have three values: + +nil -- Add the message to a queue and send it later +:nowait -- Send the message immediately, circumventing flood protection +:drop -- Send the message only if we are not flooding, and drop it if + we have queued up messages. + +The flood protection algorithm works like the one detailed in RFC +2813, section 5.8 \"Flood control of clients\". + + * If `flood-last-message' is less than the current + time, set it equal. + * While `flood-last-message' is less than `flood-margin' + seconds ahead of the current time, send a message, and + increase `flood-last-message' by `flood-penalty'." + (cond + ((null flood-handling) + (irc-connection-put conn + :flood-queue + (append (irc-connection-get conn :flood-queue) + (list line))) + (irc-send--queue conn)) + ((eq flood-handling :nowait) + (irc-send--internal conn line)) + ((eq flood-handling :drop) + (let ((queue (irc-connection-get conn :flood-queue))) + (when (not queue) + (irc-connection-put conn :flood-queue (list line)) + (irc-send--queue conn)))))) + +(defun irc-send--queue (conn) + "Send messages from the flood queue in CONN. + +See `irc-send-raw' for the algorithm." + (let ((queue (irc-connection-get conn :flood-queue)) + (last-message (or (irc-connection-get conn :flood-last-message) + 0)) + (margin (or (irc-connection-get conn :flood-margin) + 10)) + (penalty (or (irc-connection-get conn :flood-penalty) + 3)) + (now (float-time))) + (when (< last-message now) + (setq last-message now)) + (while (and queue + (< last-message (+ now margin))) + (irc-send--internal conn (car queue)) + (setq queue (cdr queue) + last-message (+ last-message penalty))) + (irc-connection-put conn :flood-queue queue) + (irc-connection-put conn :flood-last-message last-message) + (let ((timer (irc-connection-get conn :flood-timer))) + (when timer + (cancel-timer timer) + (irc-connection-put conn :flood-timer nil)) + (when queue + (irc-connection-put conn + :flood-timer + (run-at-time 1 nil #'irc-send--queue conn)))))) + +(defun irc-send--internal (conn line) + "Send LINE to CONN." + (irc-debug-out conn "C: %s" line) + (process-send-string conn + (concat (encode-coding-string line 'utf-8) + "\r\n"))) + +(defun irc-send-command (conn command &rest args) + "Send COMMAND with ARGS to IRC connection CONN." + (irc-send-raw conn (apply #'irc--format-command command args))) + +(defun irc--format-command (command &rest args) + "Format COMMAND and ARGS for IRC. + +The last value in ARGS will be escaped with a leading colon if it +contains a space. All other arguments are checked to make sure +they do not contain a space." + (dolist (arg (cons command args)) + (when (not (stringp arg)) + (error "Argument must be a string"))) + (let* ((prefix (cons command (butlast args))) + (last (last args))) + (dolist (arg prefix) + (when (string-match " " arg) + (error "IRC protocol error: Argument %S must not contain space" + arg))) + (when (and last (or (string-match " " (car last)) + (string-match "^:" (car last)) + (equal "" (car last)))) + (setcar last (concat ":" (car last)))) + (mapconcat #'identity + (append prefix last) + " "))) + +(defun irc-send-AUTHENTICATE (conn arg) + "Send an AUTHENTICATE message with ARG. + +See https://github.com/atheme/charybdis/blob/master/doc/sasl.txt +for details." + (irc-send-command conn "AUTHENTICATE" arg)) + +(defun irc-send-AWAY (conn &optional reason) + "Mark yourself as AWAY with reason REASON, or back if reason is nil." + (if reason + (irc-send-command conn "AWAY" reason) + (irc-send-command conn "AWAY"))) + +(defun irc-send-CAP (conn &rest args) + "Send a CAP message. + +See https://tools.ietf.org/html/draft-mitchell-irc-capabilities-01 +for details." + (apply #'irc-send-command conn "CAP" args)) + +(defun irc-send-INVITE (conn nick channel) + "Invite NICK to CHANNEL." + (irc-send-command conn "INVITE" nick channel)) + +(defun irc-send-JOIN (conn channel &optional key) + "Join CHANNEL. + +If KEY is given, use it to join the password-protected channel." + (if key + (irc-send-command conn "JOIN" channel key) + (irc-send-command conn "JOIN" channel))) + +(defun irc-send-NAMES (conn &optional channel) + "Retrieve user names from the server, optionally limited to CHANNEL." + (if channel + (irc-send-command conn "NAMES" channel) + (irc-send-command conn "NAMES"))) + +(defun irc-send-NICK (conn nick) + "Change your own nick to NICK." + (irc-send-command conn "NICK" nick)) + +(defun irc-send-NOTICE (conn msgtarget text-to-be-sent) + "Send a private notice containing TEXT-TO-BE-SENT to MSGTARGET. + +MSGTARGET can be either a nick or a channel." + (irc-send-command conn "NOTICE" msgtarget text-to-be-sent)) + +(defun irc-send-PART (conn channel reason) + "Leave CHANNEL with reason REASON." + (irc-send-command conn "PART" channel reason)) + +(defun irc-send-PASS (conn password) + "Authenticate to the server using PASSWORD." + (irc-send-command conn "PASS" password)) + +(defun irc-send-PONG (conn server) + "Respond to a PING message." + (irc-send-raw conn + (irc--format-command "PONG" server) + :nowait)) + +(defun irc-send-PRIVMSG (conn msgtarget text-to-be-sent) + "Send a private message containing TEXT-TO-BE-SENT to MSGTARGET. + +MSGTARGET can be either a nick or a channel." + (irc-send-command conn "PRIVMSG" msgtarget text-to-be-sent)) + +(defun irc-send-QUIT (conn reason) + "Leave IRC with reason REASON." + (irc-send-command conn "QUIT" reason)) + +(defun irc-send-TOPIC (conn channel &optional new-topic) + "Retrieve or set the topic of CHANNEL + +If NEW-TOPIC is given, set this as the new topic. If it is +omitted, retrieve the current topic." + (if new-topic + (irc-send-command conn "TOPIC" channel new-topic) + (irc-send-command conn "TOPIC" channel))) + +(defun irc-send-USER (conn user mode realname) + "Send a USER message for registration. + +MODE should be an integer as per RFC 2812" + (irc-send-command conn "USER" user (format "%s" mode) "*" realname)) + +(defun irc-send-WHOIS (conn target &optional server-or-name) + "Retrieve current whois information on TARGET." + (if server-or-name + (irc-send-command conn "WHOIS" target server-or-name) + (irc-send-command conn "WHOIS" target))) + +(defun irc-send-WHOWAS (conn target) + "Retrieve past whois information on TARGET." + (irc-send-command conn "WHOWAS" target)) + +;;;;;;;;;;;;;;; +;;; Debug stuff + +(defun irc-debug-out (conn fmt &rest args) + (when irc-debug-log + (let ((name (format "*IRC Protocol %s:%s*" + (irc-connection-get conn :host) + (irc-connection-get conn :service)))) + (with-current-buffer (get-buffer-create name) + (save-excursion + (goto-char (point-max)) + (insert (apply #'format fmt args) "\n")))))) + +;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Handler: Registration + +(defun irc-handle-registration (table) + "Add command handlers to TABLE to handle registration. + +This will send the usual startup messages after we are connected. + +Events emitted: + +\"irc.registered\" current-nick -- We have successfully + registered with the IRC server. Most commands can be used now. + In particular, joining channels is only possible now. + +\"sasl.login\" nick!user@host account -- SASL log in was + successful. + +Connection options used: + +:nick -- The nick to use to register with the server +:user -- The user name to use +:mode -- The initial mode to use; an integer. See RFC 2812 for + the meaning. +:realname -- The realname to use for the registration +:pass -- The server password to send +:cap-req -- CAP protocol capabilities to request, if available +:sasl-username -- The SASL username to send, if sasl is available +:sasl-password -- The SASL password to send, if sasl is available + +Connection options set: + +:connection-state -- One of nil, connected, registered, disconnected + See `irc-connection-state' for an interface to this. +:cap-supported-p -- Non-nil if the server supports the CAP protocol +:cap-ack -- The list of active capabilities negotiated with the server" + (irc-handler-add table "conn.connected" + #'irc-handle-registration--connected) + (irc-handler-add table "conn.disconnected" + #'irc-handle-registration--disconnected) + (irc-handler-add table "001" ;; RPL_WELCOME + #'irc-handle-registration--rpl-welcome) + (irc-handler-add table "CAP" + #'irc-handle-registration--cap) + (irc-handler-add table "AUTHENTICATE" + #'irc-handle-registration--authenticate) + (irc-handler-add table "900" ;; RPL_LOGGEDIN + #'irc-handle-registration--logged-in)) + +(defun irc-handle-registration--connected (conn _event) + (irc-connection-put conn :connection-state 'connected) + (when (irc-connection-get conn :cap-req) + (irc-send-CAP conn "LS")) + (let ((password (irc-connection-get conn :pass))) + (when password + (irc-send-PASS conn password))) + (irc-send-NICK conn (irc-connection-get conn :nick)) + (irc-send-USER conn + (irc-connection-get conn :user) + (irc-connection-get conn :mode) + (irc-connection-get conn :realname))) + +(defun irc-handle-registration--disconnected (conn _event) + (irc-connection-put conn :connection-state 'disconnected)) + +(defun irc-handle-registration--rpl-welcome (conn _event _sender target + &rest ignored) + (irc-connection-put conn :connection-state 'registered) + (irc-event-emit conn "irc.registered" target)) + +(defun irc-handle-registration--cap (conn _event _sender _target + subcommand arg) + (cond + ((equal subcommand "LS") + (let ((supported (split-string arg)) + (wanted nil)) + (dolist (cap (irc-connection-get conn :cap-req)) + (when (member cap supported) + (setq wanted (append wanted (list cap))))) + (if wanted + (irc-send-CAP conn "REQ" (mapconcat #'identity wanted " ")) + (irc-send-CAP conn "END")))) + ((equal subcommand "ACK") + (let ((acked (split-string arg))) + (irc-connection-put conn :cap-ack acked) + (if (and (member "sasl" acked) + (irc-connection-get conn :sasl-username) + (irc-connection-get conn :sasl-password)) + (irc-send-AUTHENTICATE conn "PLAIN") + (irc-send-CAP conn "END")))) + (t + (message "Unknown CAP response from server: %s %s" subcommand arg)))) + +(defun irc-handle-registration--authenticate (conn _event _sender arg) + (if (equal arg "+") + (let ((username (irc-connection-get conn :sasl-username)) + (password (irc-connection-get conn :sasl-password))) + (irc-send-AUTHENTICATE conn (base64-encode-string + (format "%s\x00%s\x00%s" + username username password))) + (irc-send-CAP conn "END")) + (message "Unknown AUTHENTICATE response from server: %s" arg))) + +(defun irc-handle-registration--logged-in (conn _event _sender _target + userhost account _message) + (irc-event-emit conn "sasl.login" userhost account)) + +(defun irc-connection-state (conn) + "connecting connected registered disconnected" + (let ((state (irc-connection-get conn :connection-state))) + (if (null state) + 'connecting + state))) + +;;;;;;;;;;;;;;;;;;;;;; +;;; Handler: Ping-Pong + +(defun irc-handle-ping-pong (table) + "Add command handlers to respond to PING requests." + (irc-handler-add table "PING" #'irc-handle-ping-pong--ping)) + +(defun irc-handle-ping-pong--ping (conn _event _sender argument) + (irc-send-PONG conn argument)) + +;;;;;;;;;;;;;;;;;;;;; +;;; Handler: ISUPPORT + +(defun irc-handle-isupport (table) + "Add command handlers to track 005 RPL_ISUPPORT capabilities." + (irc-handler-add table "005" #'irc-handle-isupport--005)) + +(defun irc-handle-isupport--005 (conn _event _sender _target &rest args) + (irc-connection-put + conn :isupport + (append (irc-connection-get conn :isupport) + (irc-handle-isupport--capabilities-to-alist args)))) + +(defun irc-handle-isupport--capabilities-to-alist (capabilities) + (mapcar (lambda (cap) + (if (string-match "\\`\\([^=]+\\)=\\(.*\\)\\'" cap) + (cons (match-string 1 cap) + (match-string 2 cap)) + (cons cap t))) + capabilities)) + +(defun irc-isupport (conn capability) + "Return the value of CAPABILITY of CONN. + +These capabilities are set when the server sends a 005 +RPL_ISUPPORT message. The return value is either the value of the +capability, or t if it is a boolean capability that is present. +If the capability is not present, the return value is nil." + (cdr (assoc capability + (irc-connection-get conn :isupport)))) + +(defun irc-string-equal-p (conn s1 s2) + "Compare S1 to S2 case-insensitively. + +What case means is defined by the server of CONN." + (equal (irc-isupport--case-fold conn s1) + (irc-isupport--case-fold conn s2))) + +(defvar irc-isupport--ascii-table + (let ((table (make-string 128 0)) + (char 0)) + (while (<= char 127) + (if (and (<= ?A char) + (<= char ?Z)) + (aset table char (+ char (- ?a ?A))) + (aset table char char)) + (setq char (1+ char))) + table) + "A case mapping table for the ascii CASEMAPPING.") + +(defvar irc-isupport--rfc1459-table + (let ((table (concat irc-isupport--ascii-table))) ; copy string + (aset table ?\[ ?\{) + (aset table ?\] ?\}) + (aset table ?\\ ?\|) + (aset table ?^ ?\~) + table) + "A case mapping table for the rfc1459 CASEMAPPING.") + +(defvar irc-isupport--rfc1459-strict-table + (let ((table (concat irc-isupport--ascii-table))) ; copy string + (aset table ?\[ ?\{) + (aset table ?\] ?\}) + (aset table ?\\ ?\|) + table) + "A case mapping table for the rfc1459-strict CASEMAPPING.") + +(defun irc-isupport--case-fold (conn s) + "Translate S to be a lower-case. + +This uses the case mapping defined by the IRC server for CONN." + (with-temp-buffer + (insert s) + (let ((mapping (or (irc-isupport conn "CASEMAPPING") + "rfc1459"))) + (cond + ((equal mapping "rfc1459") + (translate-region (point-min) + (point-max) + irc-isupport--rfc1459-table)) + ((equal mapping "ascii") + (translate-region (point-min) + (point-max) + irc-isupport--ascii-table)) + ((equal mapping "rfc1459-strict") + (translate-region (point-min) + (point-max) + irc-isupport--rfc1459-strict-table)))) + (buffer-string))) + +(defun irc-channel-name-p (conn string) + "True iff STRING is a valid channel name for CONN. + +This depends on the CHANTYPES setting set by the server of CONN." + (let ((chantypes (string-to-list + (or (irc-isupport conn "CHANTYPES") + "#")))) + (if (and (> (length string) 0) + (member (aref string 0) chantypes)) + t + nil))) + +(defun irc-nick-without-prefix (conn nick) + "Return NICK without any mode prefixes. + +For example, a user with op status might be shown as @Nick. This +function would return Nick without the prefix. This uses the 005 +RPL_ISUPPORT setting of PREFIX set by the IRC server for CONN." + (let ((prefixes (irc-connection-get conn :nick-prefixes))) + (when (not prefixes) + (let ((prefix-string (or (irc-isupport conn "PREFIX") + "(qaohv)~&@%+"))) + (setq prefixes (string-to-list + (if (string-match "(.*)\\(.*\\)" prefix-string) + (match-string 1 prefix-string) + "~&@%+"))) + (irc-connection-put conn :nick-prefixes prefixes))) + (while (and (> (length nick) 0) + (member (aref nick 0) prefixes)) + (setq nick (substring nick 1))) + nick)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Handler: Initial nick acquisition + +(defun irc-handle-initial-nick-acquisition (table) + "Track the current nick of the user. + +Connection options used: + +:nick-alternatives -- A list of nicks to try if the first attempt + does not succeed." + (irc-handler-add table "432" ;; ERR_ERRONEUSNICKNAME + #'irc-handle-initial-nick-acquisition--get-initial-nick) + (irc-handler-add table "433" ;; ERR_NICKNAMEINUSE + #'irc-handle-initial-nick-acquisition--get-initial-nick) + (irc-handler-add table "437" ;; ERR_UNAVAILRESOURCE + #'irc-handle-initial-nick-acquisition--get-initial-nick)) + +(defun irc-handle-initial-nick-acquisition--get-initial-nick + (conn _event _sender current-nick _attempted-nick _reason) + (when (equal current-nick "*") + (let ((alternatives (irc-connection-get conn :nick-alternatives))) + (if (not alternatives) + (irc-send-NICK conn (irc-generate-nick)) + (irc-connection-put conn :nick-alternatives (cdr alternatives)) + (irc-send-NICK conn (car alternatives)))))) + +(defun irc-generate-nick () + "Return a random, valid IRC nick name. + +Valid nick names are at least (RFC 1459): + + ::= { | | } + ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}'" + (let ((chars "abcdefghijklmnopqrstuvwxyz")) + (mapconcat (lambda (_) + (make-string 1 (aref chars (random (length chars))))) + (make-string 9 0) + ""))) + +;;;;;;;;;;;;;;;;; +;;; Handler: CTCP + +(defun irc-handle-ctcp (table) + "Add command handlers to TABLE to handle the CTCP protocol. + +Connection options used: + +:ctcp-version -- The response to a CTCP VERSION request. +:ctcp-clientinfo -- The response to a CTCP CLIENTINFO request. +:ctcp-source -- The response to a CTCP SOURCE request. + +Events emitted: + +\"irc.message\" sender target body -- A non-CTCP PRIVMSG +\"irc.notice\" sender target body -- A non-CTCP NOTICE +\"irc.ctcp\" sender target verb argument -- A CTCP request. ARGUMENT + can be nil if there was no argument, or the empty string if the + argument was empty. +\"irc.ctcpreply\" sender target verb argument -- A CTCP reply. + ARGUMENT is similar to above. +\"irc.ctcp.VERB\" sender target argument -- A CTCP request of + this specific type. +\"irc.ctcpreply.VERB\" sender target argument -- A CTCP reply of + this specific type." + (irc-handler-add table "PRIVMSG" + #'irc-handle-ctcp--privmsg) + (irc-handler-add table "irc.ctcp" + #'irc-handle-ctcp--ctcp) + (irc-handler-add table "NOTICE" + #'irc-handle-ctcp--notice) + (irc-handler-add table "irc.ctcpreply" + #'irc-handle-ctcp--ctcpreply) + (irc-handler-add table "irc.ctcp.VERSION" + #'irc-handle-ctcp--ctcp-version) + (irc-handler-add table "irc.ctcp.CLIENTINFO" + #'irc-handle-ctcp--ctcp-clientinfo) + (irc-handler-add table "irc.ctcp.SOURCE" + #'irc-handle-ctcp--ctcp-source) + (irc-handler-add table "irc.ctcp.PING" + #'irc-handle-ctcp--ctcp-ping) + (irc-handler-add table "irc.ctcp.TIME" + #'irc-handle-ctcp--ctcp-time) + ) + +(defun irc-handle-ctcp--privmsg (conn _event sender target body) + (if (string-match "\\`\x01\\([^ ]+\\)\\(?: \\(.*\\)\\)?\x01\\'" + body) + (irc-event-emit conn "irc.ctcp" sender target + (match-string 1 body) + (match-string 2 body)) + (irc-event-emit conn "irc.message" sender target body))) + +(defun irc-handle-ctcp--ctcp (conn _event sender target verb argument) + (irc-event-emit conn + (format "irc.ctcp.%s" (upcase verb)) + sender + target + argument)) + +(defun irc-handle-ctcp--notice (conn _event sender target body) + (if (string-match "\\`\x01\\([^ ]+\\)\\(?: \\(.*\\)\\)?\x01\\'" + body) + (irc-event-emit conn "irc.ctcpreply" sender target + (match-string 1 body) + (match-string 2 body)) + (irc-event-emit conn "irc.notice" sender target body))) + +(defun irc-handle-ctcp--ctcpreply (conn _event sender target verb argument) + (irc-event-emit conn + (format "irc.ctcpreply.%s" (upcase verb)) + sender + target + argument)) + +(defun irc-handle-ctcp--ctcp-version (conn _event sender _target _argument) + (let ((version (irc-connection-get conn :ctcp-version))) + (when version + (irc-send-ctcpreply conn + (irc-userstring-nick sender) + "VERSION" + version)))) + +(defun irc-handle-ctcp--ctcp-clientinfo (conn _event sender _target _argument) + (let ((clientinfo (irc-connection-get conn :ctcp-clientinfo))) + (when clientinfo + (irc-send-ctcpreply conn + (irc-userstring-nick sender) + "CLIENTINFO" + clientinfo)))) + +(defun irc-handle-ctcp--ctcp-source (conn _event sender _target _argument) + (let ((source (irc-connection-get conn :ctcp-source))) + (when source + (irc-send-ctcpreply conn + (irc-userstring-nick sender) + "SOURCE" + source)))) + +(defun irc-handle-ctcp--ctcp-ping (conn _event sender _target argument) + (when argument + (irc-send-ctcpreply conn + (irc-userstring-nick sender) + "PING" + argument))) + +(defun irc-handle-ctcp--ctcp-time (conn _event sender _target _argument) + (irc-send-ctcpreply conn + (irc-userstring-nick sender) + "TIME" + (current-time-string))) + +(defun irc-send-ctcp (conn target verb &optional argument) + "Send a CTCP VERB request to TARGET, optionally with ARGUMENT." + (irc-send-PRIVMSG conn + target + (format "\x01%s%s\x01" + verb + (if argument + (concat " " argument) + "")))) + +(defun irc-send-ctcpreply (conn target verb &optional argument) + "Send a CTCP VERB reply to TARGET, optionally with ARGUMENT." + (irc-send-raw conn + (irc--format-command "NOTICE" + target + (format "\x01%s%s\x01" + verb + (if argument + (concat " " argument) + ""))) + :drop)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Handler: State tracking + +(defun irc-handle-state-tracking (table) + "Add command handlers to TABLE to track the IRC state. + +Connection options used: + +:current-nick -- The current nick, or nil if not known/set yet. + +Use helper functions to access the information tracked by this +handler: + +- `irc-current-nick' +- `irc-current-nick-p' + +Events emitted: + +\"channel.quit\" sender channel reason -- A user quit IRC and + left this channel that way." + (irc-handler-add table "001" ;; RPL_WELCOME + #'irc-handle-state-tracking--rpl-welcome) + (irc-handler-add table "JOIN" + #'irc-handle-state-tracking--JOIN) + (irc-handler-add table "PART" + #'irc-handle-state-tracking--PART) + (irc-handler-add table "KICK" + #'irc-handle-state-tracking--KICK) + (irc-handler-add table "QUIT" + #'irc-handle-state-tracking--QUIT) + (irc-handler-add table "NICK" + #'irc-handle-state-tracking--NICK) + (irc-handler-add table "PRIVMSG" + #'irc-handle-state-tracking--PRIVMSG) + (irc-handler-add table "353" ;; RPL_NAMREPLY + #'irc-handle-state-tracking--rpl-namreply) + (irc-handler-add table "366" ;; RPL_ENDOFNAMES + #'irc-handle-state-tracking--rpl-endofnames) + + (irc-handler-add table "TOPIC" + #'irc-handle-state-tracking--TOPIC) + (irc-handler-add table "331" ;; RPL_NOTOPIC + #'irc-handle-state-tracking--rpl-notopic) + (irc-handler-add table "332" ;; RPL_TOPIC + #'irc-handle-state-tracking--rpl-topic) + ) + +(cl-defstruct irc-channel + name + topic + last-topic + folded-name + users + recent-users + receiving-names + connection) + +(defun irc-channel-from-name (conn name) + "Create a new IRC channel object on CONN, named NAME." + (make-irc-channel :name name + :folded-name (irc-isupport--case-fold conn name) + :users (make-hash-table :test 'equal) + :recent-users (make-hash-table :test 'equal) + :connection conn)) + +(defun irc-connection-channel (conn channel-name) + "Return the channel object for CHANNEL-NAME on CONN." + (let ((channel-table (irc--connection-channel-table conn)) + (folded-name (irc-isupport--case-fold conn channel-name))) + (gethash folded-name channel-table))) + +(defun irc-connection-channel-list (conn) + "Return the list of channel object on CONN." + (let ((channel-list nil)) + (maphash (lambda (_folded-name channel) + (push channel channel-list)) + (irc--connection-channel-table conn)) + channel-list)) + +(defun irc-connection-add-channel (conn channel-name) + "Add CHANNEL-NAME to the channel table of CONN." + (let* ((channel-table (irc--connection-channel-table conn)) + (channel (irc-channel-from-name conn channel-name)) + (folded-name (irc-channel-folded-name channel))) + (when (not (gethash folded-name channel-table)) + (puthash folded-name channel channel-table)))) + +(defun irc-connection-remove-channel (conn channel-name) + "Remove CHANNEL-NAME from the channel table of CONN." + (let* ((channel-table (irc--connection-channel-table conn)) + (folded-name (irc-isupport--case-fold conn channel-name))) + (remhash folded-name channel-table))) + +(defun irc-current-nick (conn) + "Return the current nick on IRC connection CONN, or nil if not set yet." + (irc-connection-get conn :current-nick)) + +(defun irc-current-nick-p (conn nick) + "Return t if NICK is our current nick on IRC connection CONN." + (let ((current-nick (irc-current-nick conn))) + (if (and (stringp nick) + (stringp current-nick)) + (irc-string-equal-p conn current-nick nick) + nil))) + +(defun irc--connection-channel-table (conn) + (let ((table (irc-connection-get conn :channel-table))) + (when (not table) + (setq table (make-hash-table :test 'equal)) + (irc-connection-put conn :channel-table table)) + table)) + +(cl-defstruct irc-user + nick + folded-nick + userhost + join-time + last-activity-time + part-time + connection) + +(defun irc-user-from-userstring (conn userstring) + "Create an irc-user struct on CONN from USERSTRING. + +USERSTRING should be a s tring of the form \"nick!user@host\"." + (let ((nick (irc-userstring-nick userstring))) + (make-irc-user :nick nick + :folded-nick (irc-isupport--case-fold conn nick) + :userhost (let ((nick-len (length nick))) + (if (>= nick-len (length userstring)) + nil + (substring userstring (1+ nick-len)))) + :connection conn))) + +(defun irc-channel-user (channel nick) + "Return a user named NICK on channel CHANNEL." + (let ((user-table (irc-channel-users channel)) + (folded-nick (irc-isupport--case-fold (irc-channel-connection channel) + nick))) + (gethash folded-nick user-table))) + +(defun irc-channel-recent-user (channel nick) + "Return a recent user named NICK on channel CHANNEL." + (let ((user-table (irc-channel-recent-users channel)) + (folded-nick (irc-isupport--case-fold (irc-channel-connection channel) + nick))) + (gethash folded-nick user-table))) + +(defun irc-channel-add-user (channel userstring) + "Add USER to CHANNEL." + (let* ((user-table (irc-channel-users channel)) + (user (irc-user-from-userstring (irc-channel-connection channel) + userstring)) + (folded-nick (irc-user-folded-nick user)) + (recent-user (irc-channel-recent-user channel (irc-user-nick user)))) + (when (not (gethash folded-nick user-table)) + (when (and recent-user + (equal (irc-user-userhost recent-user) + (irc-user-userhost user))) + (setf (irc-user-last-activity-time user) + (irc-user-last-activity-time recent-user))) + (puthash folded-nick user user-table) + user))) + +(defun irc-channel-remove-user (channel nick) + "Remove NICK from CHANNEL." + (let* ((user-table (irc-channel-users channel)) + (recent-user-table (irc-channel-recent-users channel)) + (folded-nick (irc-isupport--case-fold (irc-channel-connection channel) + nick)) + (user (gethash folded-nick user-table))) + (remhash folded-nick user-table) + (when user + (setf (irc-user-part-time user) (float-time)) + (puthash folded-nick user recent-user-table) + (maphash (lambda (folded-nick user) + (when (< (irc-user-part-time user) + (- (float-time) + (* 60 60))) + (remhash folded-nick recent-user-table))) + recent-user-table)))) + +(defun irc-channel-rename-user (channel oldnick newnick) + "Update CHANNEL so that the user with nick OLDNICK now has nick NEWNICK." + (let ((user-table (irc-channel-users channel)) + (user (irc-channel-user channel oldnick)) + (newnick-folded (irc-isupport--case-fold + (irc-channel-connection channel) + newnick)) + (recent-user (irc-channel-recent-user channel newnick))) + (when user + (when (and recent-user + (equal (irc-user-userhost recent-user) + (irc-user-userhost user))) + (setf (irc-user-last-activity-time user) + (irc-user-last-activity-time recent-user))) + (remhash (irc-user-folded-nick user) user-table) + (setf (irc-user-nick user) newnick) + (setf (irc-user-folded-nick user) newnick-folded) + (puthash (irc-user-folded-nick user) user user-table)))) + +(defun irc-handle-state-tracking--rpl-welcome (conn _event _sender target + &rest ignored) + (irc-connection-put conn :current-nick target)) + +(defun irc-handle-state-tracking--JOIN (conn _event sender target + &optional _account _realname) + (let ((nick (irc-userstring-nick sender))) + (cond + ((irc-current-nick-p conn nick) + (irc-connection-add-channel conn target)) + (t + (let ((channel (irc-connection-channel conn target))) + (when channel + (let ((user (irc-channel-add-user channel sender))) + (when user + (setf (irc-user-join-time user) (float-time)))))))))) + +(defun irc-handle-state-tracking--PART (conn _event sender target + &optional _reason) + (let ((nick (irc-userstring-nick sender))) + (cond + ((irc-current-nick-p conn nick) + (irc-connection-remove-channel conn target)) + (t + (let ((channel (irc-connection-channel conn target))) + (when channel + (irc-channel-remove-user channel nick))))))) + +(defun irc-handle-state-tracking--KICK (conn _event _sender target nick + &optional _reason) + (cond + ((irc-current-nick-p conn nick) + (irc-connection-remove-channel conn target)) + (t + (let ((channel (irc-connection-channel conn target))) + (when channel + (irc-channel-remove-user channel nick)))))) + +(defun irc-handle-state-tracking--QUIT (conn _event sender + &optional reason) + (let ((nick (irc-userstring-nick sender))) + (if (irc-current-nick-p conn nick) + (dolist (channel (irc-connection-channel-list conn)) + (irc-connection-remove-channel conn + (irc-channel-folded-name channel))) + (dolist (channel (irc-connection-channel-list conn)) + (when (irc-channel-user channel nick) + (irc-event-emit conn "channel.quit" + sender + (irc-channel-name channel) + reason)) + (irc-channel-remove-user channel nick))))) + +(defun irc-handle-state-tracking--NICK (conn _event sender new-nick) + ;; Update channels + (let ((nick (irc-userstring-nick sender))) + (dolist (channel (irc-connection-channel-list conn)) + (irc-channel-rename-user channel nick new-nick))) + ;; Update our own nick + (when (irc-current-nick-p conn (irc-userstring-nick sender)) + (irc-connection-put conn :current-nick new-nick))) + +(defun irc-handle-state-tracking--PRIVMSG (conn _event sender target _message) + (let ((channel (irc-connection-channel conn target)) + (nick (irc-userstring-nick sender))) + (when channel + (let ((user (irc-channel-user channel nick))) + (when user + (setf (irc-user-last-activity-time user) (float-time))))))) + +(defun irc-handle-state-tracking--rpl-namreply + (conn _event _sender _current-nick _channel-type channel-name nicks) + (let ((channel (irc-connection-channel conn channel-name))) + (when channel + (setf (irc-channel-receiving-names channel) + (append (irc-channel-receiving-names channel) + (mapcar (lambda (nick) + (irc-nick-without-prefix + conn + (string-trim nick))) + (split-string nicks))))))) + +(defun irc-handle-state-tracking--rpl-endofnames + (conn _event _sender _current-nick channel-name _description) + (let ((channel (irc-connection-channel conn channel-name))) + (when channel + (irc-channel--synchronize-nicks channel + (irc-channel-receiving-names channel)) + (setf (irc-channel-receiving-names channel) nil)))) + +(defun irc-channel--synchronize-nicks (channel nicks) + "Update the user list of CHANNEL to match NICKS." + (let ((have (irc-channel-users channel)) + (want (make-hash-table :test 'equal))) + (dolist (nick nicks) + (puthash (irc-isupport--case-fold (irc-channel-connection channel) + nick) + nick + want)) + (maphash (lambda (nick-folded user) + (when (not (gethash nick-folded want)) + (irc-channel-remove-user channel + (irc-user-nick user)))) + have) + (maphash (lambda (_nick-folded nick) + (irc-channel-add-user channel nick)) + want))) + +(defun irc-handle-state-tracking--TOPIC (conn _event _sender channel new-topic) + (let ((channel (irc-connection-channel conn channel))) + (when channel + (setf (irc-channel-last-topic channel) + (irc-channel-topic channel)) + (setf (irc-channel-topic channel) new-topic)))) + +(defun irc-handle-state-tracking--rpl-notopic (conn _event _sender + _current-nick channel + _no-topic-desc) + (let ((channel (irc-connection-channel conn channel))) + (when channel + (setf (irc-channel-topic channel) nil)))) + +(defun irc-handle-state-tracking--rpl-topic (conn _event _sender _current-nick + channel topic) + (let ((channel (irc-connection-channel conn channel))) + (when channel + (setf (irc-channel-topic channel) topic)))) + +;;;;;;;;;;;;;;,;;;;;; +;;; Handler: NickServ + +(defun irc-handle-nickserv (table) + "Add command handlers to TABLE to deal with NickServ. + +Connection options used: + +:nickserv-nick -- The nick to register as + +:nickserv-password -- The password for nickserv; can be a function and + is then called with the IRC connection as its sole argument + +:nickserv-mask -- A regular expression matching the correct NickServ's + nick!user@host string to avoid fakes + +:nickserv-identify-challenge -- A regular expression matching the + challenge sent by NickServ to request identification + +:nickserv-identify-command -- The raw IRC command to send to identify; + expands {nick} and {password} when present + +:nickserv-identify-confirmation -- A regular expression matching the + confirmation message from NickServ after successful identification + +:nickserv-ghost-command -- The raw IRC comment to ghost your + original nick; expands {nick} and {password}. Set this to nil + to disable ghosting and nick regaining. + +:nickserv-ghost-confirmation -- A regular expression matching the + confirmation message that the nick was ghosted + +Events emitted: + +\"nickserv.identified\" -- We have successfully identified with nickserv. + +\"nickserv.ghosted\" -- We have ghosted a nick." + (irc-handler-add table "irc.registered" #'irc-handle-nickserv--registered) + (irc-handler-add table "NOTICE" #'irc-handle-nickserv--NOTICE) + (irc-handler-add table "PRIVMSG" #'irc-handle-nickserv--NOTICE) + (irc-handler-add table "NICK" #'irc-handle-nickserv--NICK)) + +(defun irc-handle-nickserv--password (conn) + (let ((password (irc-connection-get conn :nickserv-password))) + (if (functionp password) + (funcall password conn) + password))) + +(defun irc-handle-nickserv--registered (conn _event current-nick) + (let ((ghost-command (irc-connection-get conn :nickserv-ghost-command)) + (wanted-nick (irc-connection-get conn :nickserv-nick)) + (password (irc-handle-nickserv--password conn))) + (when (and ghost-command + wanted-nick + password + (not (irc-string-equal-p conn current-nick wanted-nick))) + (irc-send-raw conn + (irc-format ghost-command + 'nick wanted-nick + 'password password))))) + +(defun irc-handle-nickserv--NOTICE (conn _event sender _target message) + (let ((nickserv-mask (irc-connection-get conn :nickserv-mask)) + identify-challenge identify-command identify-confirmation + ghost-confirmation + nickserv-nick nickserv-password) + (when (and nickserv-mask (string-match nickserv-mask sender)) + (setq identify-challenge + (irc-connection-get conn :nickserv-identify-challenge)) + (setq identify-command + (irc-connection-get conn :nickserv-identify-command)) + (setq identify-confirmation + (irc-connection-get conn :nickserv-identify-confirmation)) + (setq ghost-confirmation + (irc-connection-get conn :nickserv-ghost-confirmation)) + (setq nickserv-nick (irc-connection-get conn :nickserv-nick)) + (setq nickserv-password (irc-handle-nickserv--password conn)) + (cond + ;; Identify + ((and identify-challenge + identify-command + nickserv-nick + nickserv-password + (string-match identify-challenge message)) + (irc-send-raw conn + (irc-format identify-command + 'nick nickserv-nick + 'password nickserv-password))) + ;; Identification confirmed + ((and identify-confirmation + (string-match identify-confirmation message)) + (irc-event-emit conn "nickserv.identified")) + ;; Ghosting confirmed + ((and ghost-confirmation + (string-match ghost-confirmation message)) + (irc-event-emit conn "nickserv.ghosted") + (irc-connection-put conn :nickserv-regaining-nick t) + (when nickserv-nick + (irc-send-NICK conn nickserv-nick))))))) + +(defun irc-handle-nickserv--NICK (conn _event _sender new-nick) + (when (and (irc-connection-get conn :nickserv-regaining-nick) + (irc-string-equal-p conn new-nick + (irc-connection-get conn :nickserv-nick))) + (irc-connection-put conn :nickserv-regaining-nick nil) + (irc-event-emit conn "nickserv.regained"))) + +(defun irc-format (format &rest args) + "Return a formatted version of FORMAT, using substitutions from ARGS. + +The substitutions are identified by braces ('{' and '}')." + (with-temp-buffer + (insert format) + (goto-char (point-min)) + (while (re-search-forward "{\\([^}]*\\)}" nil t) + (replace-match (format "%s" (plist-get args (intern (match-string 1)))))) + (buffer-string))) + +;;;;;;;;;;;;;;;;;;;;;; +;;; Handler: Auto-Join + +(defun irc-handle-auto-join (table) + "Add command handlers to TABLE to deal with NickServ. + +Connection options used: + +:auto-join-after-registration -- List of channels to join + immediately after registration with the server + +:auto-join-after-host-hiding -- List of channels to join + after our host was hidden + +:auto-join-after-nick-acquisition -- List of channels to join + after we gained our desired nick + +:auto-join-after-nickserv-identification -- List of channels + to join after we identified successfully with NickServ" + (irc-handler-add table "irc.registered" #'irc-handle-auto-join--registered) + (irc-handler-add table "396" ;; RPL_HOSTHIDDEN + #'irc-handle-auto-join--rpl-hosthidden) + (irc-handler-add table "nickserv.regained" + #'irc-handle-auto-join--nickserv-regained) + (irc-handler-add table "nickserv.identified" + #'irc-handle-auto-join--nickserv-identified) + (irc-handler-add table "sasl.login" + #'irc-handle-auto-join--sasl-login)) + +(defun irc-handle-auto-join--registered (conn _event _current-nick) + (dolist (channel (irc-connection-get conn :auto-join-after-registration)) + (irc-send-JOIN conn channel))) + +(defun irc-handle-auto-join--rpl-hosthidden (conn _event _sender _target _host + _description) + (dolist (channel (irc-connection-get conn :auto-join-after-host-hiding)) + (irc-send-JOIN conn channel))) + +(defun irc-handle-auto-join--nickserv-regained (conn _event) + (dolist (channel (irc-connection-get + conn :auto-join-after-nick-acquisition)) + (irc-send-JOIN conn channel))) + +(defun irc-handle-auto-join--nickserv-identified (conn event) + (dolist (channel (irc-connection-get + conn :auto-join-after-nickserv-identification)) + (irc-send-JOIN conn channel)) + (if (irc-string-equal-p conn + (irc-connection-get conn :nick) + (irc-connection-get conn :nickserv-nick)) + (irc-handle-auto-join--nickserv-regained conn event))) + +(defun irc-handle-auto-join--sasl-login (conn _event &rest ignored) + (dolist (channel (irc-connection-get + conn :auto-join-after-sasl-login)) + (irc-send-JOIN conn channel))) + +(provide 'irc) +;;; irc.el ends here diff --git a/elpa/circe-20161102.1405/lcs.el b/elpa/circe-20161102.1405/lcs.el new file mode 100644 index 00000000..b5beb12e --- /dev/null +++ b/elpa/circe-20161102.1405/lcs.el @@ -0,0 +1,202 @@ +;;; lcs.el --- find out the longest common sequence + +;; Copyright (c) 2002-2003 by Alex Shinn, All rights reserved. +;; Copyright (c) 2002-2003 by Shiro Kawai, All rights reserved. +;; Copyright (c) 2006, 2012 by Jorgen Schaefer, All rights reserved. + +;; Authors: Alex Shinn, Shiro Kawai +;; Maintainer: Jorgen Schaefer +;; URL: https://github.com/jorgenschaefer/circe/wiki/lcs + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: + +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. + +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. + +;; 3. Neither the name of the authors nor the names of its contributors +;; may be used to endorse or promote products derived from this +;; software without specific prior written permission. + +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Commentary: + +;; lcs.el is a library for other Emacs Lisp programs not useful by +;; itself. + +;; This library provides functions to find the Longest Common Sequence +;; (LCS) of two sequences. This is used to create a unified diff of to +;; two lists. See `lcs-unified-diff' for a useful function to be +;; called. + +;; The code is more or less a literal translation of (part of) +;; Gauche's util/lcs.scm module to Emacs Lisp. + +;;; Code: + +(put 'lcs-for 'lisp-indent-function 4) +(defmacro lcs-for (var from to step &rest body) + "A simple FOR loop macro. +Count VAR from FROM to TO by stepsize STEP. Evaluate BODY in each +iteration." + (let ((sto (make-symbol "to")) + (sstep (make-symbol "step"))) + `(let ((,var ,from) + (,sto ,to) + (,sstep ,step)) + (while (<= ,var ,sto) + (progn + ,@body) + (setq ,var (+ ,var ,sstep)))))) + +(defun lcs-split-at (lis pos) + "Return a cons cell of the first POS elements of LIS and the rest." + (let ((head nil)) + (while (> pos 0) + (setq head (cons (car lis) + head) + pos (- pos 1) + lis (cdr lis))) + (cons (reverse head) + lis))) + +(defun lcs-finish (M+N V_l vl V_r vr) + "Finalize the LCS algorithm. +Should be used only by `lcs-with-positions'." + (let ((maxl 0) + (r '())) + (lcs-for i (- M+N) M+N 1 + (when (> (funcall vl i) + maxl) + (setq maxl (funcall vl i) + r (funcall vr i)))) + (list maxl (reverse r)))) + +(defun lcs-with-positions (a-ls b-ls &optional equalp) + "Return the longest common subsequence (LCS) of A-LS and B-LS. +EQUALP can be any procedure which returns non-nil when two +elements should be considered equal." + (let* ((A (vconcat a-ls)) + (B (vconcat b-ls)) + (N (length A)) + (M (length B)) + (M+N (+ M N)) + (V_d (make-vector (+ 1 (* 2 M+N)) + 0)) + (V_r (make-vector (+ 1 (* 2 M+N)) + nil)) + (V_l (make-vector (+ 1 (* 2 M+N)) + 0)) + (vd (lambda (i &optional x) + (if x + (aset V_d (+ i M+N) x) + (aref V_d (+ i M+N))))) + (vr (lambda (i &optional x) + (if x + (aset V_r (+ i M+N) x) + (aref V_r (+ i M+N))))) + (vl (lambda (i &optional x) + (if x + (aset V_l (+ i M+N) x) + (aref V_l (+ i M+N)))))) + (when (not equalp) + (setq equalp 'equal)) + (catch 'return + (if (= M+N 0) + (throw 'return '(0 ())) + (lcs-for d 0 M+N 1 + (lcs-for k (- d) d 2 + (let ((x nil) + (y nil) + (l nil) + (r nil)) + (if (or (= k (- d)) + (and (not (= k d)) + (< (funcall vd (- k 1)) + (funcall vd (+ k 1))))) + (setq x (funcall vd (+ k 1)) + l (funcall vl (+ k 1)) + r (funcall vr (+ k 1))) + (setq x (+ 1 (funcall vd (- k 1))) + l (funcall vl (- k 1)) + r (funcall vr (- k 1)))) + (setq y (- x k)) + (while (and (< x N) + (< y M) + (funcall equalp (aref A x) (aref B y))) + (setq r (cons (list (aref A x) x y) + r) + x (+ x 1) + y (+ y 1) + l (+ l 1))) + (funcall vd k x) + (funcall vr k r) + (funcall vl k l) + (when (and (>= x N) + (>= y M)) + (throw 'return(lcs-finish M+N V_l vl V_r vr))))))) + (error "Can't happen")))) + +(defun lcs-unified-diff (a b &optional equalp) + "Return a unified diff of the lists A and B. +EQUALP should can be a procedure that returns non-nil when two +elements of A and B should be considered equal. It's `equal' by +default." + (let ((common (cadr (lcs-with-positions a b equalp))) + (a a) + (a-pos 0) + (b b) + (b-pos 0) + (diff '())) + (while common + (let* ((elt (car common)) + (a-off (nth 1 elt)) + (a-skip (- a-off a-pos)) + (b-off (nth 2 elt)) + (b-skip (- b-off b-pos)) + (a-split (lcs-split-at a a-skip)) + (a-head (car a-split)) + (a-tail (cdr a-split)) + (b-split (lcs-split-at b b-skip)) + (b-head (car b-split)) + (b-tail (cdr b-split))) + (setq diff (append diff + (mapcar (lambda (a) + `(- ,a)) + a-head) + (mapcar (lambda (b) + `(+ ,b)) + b-head) + `((! ,(car elt)))) + + common (cdr common) + a (cdr a-tail) + a-pos (+ a-off 1) + b (cdr b-tail) + b-pos (+ b-off 1)))) + (append diff + (mapcar (lambda (a) + `(- ,a)) + a) + (mapcar (lambda (b) + `(+ ,b)) + b)))) + +(provide 'lcs) +;;; lcs.el ends here diff --git a/elpa/circe-20161102.1405/lui-autopaste.el b/elpa/circe-20161102.1405/lui-autopaste.el new file mode 100644 index 00000000..7582839c --- /dev/null +++ b/elpa/circe-20161102.1405/lui-autopaste.el @@ -0,0 +1,115 @@ +;;; lui-autopaste.el --- Extension for lui for long text input + +;; Copyright (C) 2012 Jorgen Schaefer + +;; Author: Jorgen Schaefer + +;; This file is part of Lui. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General 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 extension for lui will intercept long input and replace it by +;; an URL to a paste service. + +;; What is considered "long" is defined by `lui-autopaste-lines'. You +;; can configure which paste service to use by changing +;; `lui-autopaste-function'. + +;; Run `enable-lui-autopaste' to enable this. + +;;; Code: + +(defgroup lui-autopaste nil + "The Lui autopaste extension." + :prefix "lui-autopaste-" + :group 'lui) + +(defcustom lui-autopaste-lines 3 + "Starting at this number of lines, Lui will ask to paste the input." + :type 'integer + :group 'lui-autopaste) + +(defcustom lui-autopaste-function 'lui-autopaste-service-ixio + "Which paste service to use. + +This function will be called with some text as its only argument, +and is expected to return an URL to view the contents." + :type '(choice (const :tag "ix.io" lui-autopaste-service-ixio) + (const :tag "ptpb.pw" lui-autopaste-service-ptpb-pw)) + :group 'lui-autopaste) + +;;;###autoload +(defun enable-lui-autopaste () + "Enable the lui autopaste feature. + +If you enter more than `lui-autopaste-lines' at once, Lui will +ask if you would prefer to use a paste service instead. If you +agree, Lui will paste your input to `lui-autopaste-function' and +replace it with the resulting URL." + (interactive) + (add-hook 'lui-pre-input-hook 'lui-autopaste)) + +;;;###autoload +(defun disable-lui-autopaste () + "Disable the lui autopaste feature." + (interactive) + (remove-hook 'lui-pre-input-hook 'lui-autopaste)) + +(defun lui-autopaste () + "Check if the lui input is too large. If so, paste it instead." + (when (and (>= (count-lines (point-min) (point-max)) + lui-autopaste-lines) + (y-or-n-p "That's pretty long, would you like to use a paste service instead? ")) + (let ((url (funcall lui-autopaste-function + (buffer-substring (point-min) + (point-max))))) + (delete-region (point-min) (point-max)) + (insert url)))) + +(defun lui-autopaste-service-ptpb-pw (text) + "Paste TEXT to ptpb.pw and return the paste url." + (let ((url-request-method "POST") + (url-request-extra-headers + '(("Content-Type" . "application/x-www-form-urlencoded"))) + (url-request-data (format "c=%s" (url-hexify-string text))) + (url-http-attempt-keepalives nil)) + (let ((buf (url-retrieve-synchronously "https://ptpb.pw/"))) + (unwind-protect + (with-current-buffer buf + (goto-char (point-min)) + (if (re-search-forward "^url: \\(.*\\)" nil t) + (match-string 1) + (error "Error during pasting to ptpb.pw"))) + (kill-buffer buf))))) + +(defun lui-autopaste-service-ixio (text) + "Paste TEXT to ix.io and return the paste url." + (let ((url-request-method "POST") + (url-request-extra-headers + '(("Content-Type" . "application/x-www-form-urlencoded"))) + (url-request-data (format "f:1=%s" (url-hexify-string text))) + (url-http-attempt-keepalives nil)) + (let ((buf (url-retrieve-synchronously "http://ix.io/"))) + (unwind-protect + (with-current-buffer buf + (goto-char (point-min)) + (if (re-search-forward "\n\n" nil t) + (buffer-substring (point) (point-at-eol)) + (error "Error during pasting to ix.io"))) + (kill-buffer buf))))) + +(provide 'lui-autopaste) +;;; lui-autopaste.el ends here diff --git a/elpa/circe-20161102.1405/lui-format.el b/elpa/circe-20161102.1405/lui-format.el new file mode 100644 index 00000000..68cc0ff0 --- /dev/null +++ b/elpa/circe-20161102.1405/lui-format.el @@ -0,0 +1,198 @@ +;;; lui-format.el --- A formatting function for use with Lui + +;; Copyright (C) 2005, 2012 Jorgen Schaefer + +;; Author: Jorgen Schaefer + +;; This file is part of Lui. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General 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: + +;; An improved formatting function using named parameters. +;; +;; See the docstring of `lui-format' for more details. +;; +;; Most of the design is borrowed from Python's string.format. + +;;; Code: + +(require 'lui) + +(defun lui-display (format not-tracked-p &rest keywords) + "Display a formatted string in the current Lui interface. + +The string is formatted using FORMAT and `lui-format'. + +If NOT-TRACKED-P is given, the inserted string won't trigger +tracking. See `lui-insert' for a description. + +KEYWORDS are the keyword arguments passed to `lui-format'. + +See `lui-format' for a full description of the arguments." + (lui-insert (lui-format format keywords) + not-tracked-p)) + +(defun lui-format (format &rest keywords) + "Display FORMAT formatted with KEYWORDS. +FORMAT should be a symbol whose value is taken. If the value is a +procedure, the keyword list is passed as a single argument to it, +and it should return the formatted string. If the value is a +string, it is formatted according to the rules below. + +KEYWORDS is a plist of keywords and strings, or symbols and +strings. They are used as format arguments. + +The string is taken verbatim, unless there is are opening or +closing braces. + +Double opening or closing braces are replaced by single +occurrences of those characters. Otherwise, the contents between +opening and closing braces is a format description and replaced +by a formatted string. + +The string between opening and closing braces is taken as a name +of a keyword argument, and replaced by that argument's value. If +there is a colon in the string, the keyword name is the part +before the colon. The part after the colon is used to format the +argument using standard `format' + +Example: + + (lui-format \"Hello {foo:.1f}\" :foo 3.1415) + +is equivalent to + + (format \"Hello %.1f\" 3.1415) + +If the name is either a number, a number followed by a dash, or +two numbers with a dash in between them, this is taken as a +special name that is looked up in the list given using the list +argument to the :indexed-args keyword. + +{1} refers to the second element (element 1) +{1-} refers to the second and all following elements +{1-3} refers to the second through fourth element + +If more than one element is selected, the elements are separated +by a single space character. + +All named arguments receive a property of `lui-format-argument' +with the respective name as value. The whole string receives a +`lui-format' property with FORMAT as a value, and a +`lui-keywords' argument with KEYWORDS as a value." + ;; If it's only a single argument, that argument is a list. + (when (not (cdr keywords)) + (setq keywords (car keywords))) + (cond + ((functionp format) + (apply format keywords)) + ((and (symbolp format) + (functionp (symbol-value format))) + (apply (symbol-value format) keywords)) + (t + (let* ((format-string (if (symbolp format) + (symbol-value format) + format)) + (plist (mapcar (lambda (entry) + (if (keywordp entry) + ;; Keyword -> symbol + (intern (substring (symbol-name entry) + 1)) + entry)) + keywords))) + (propertize (lui-format-internal format-string plist) + 'lui-format format + 'lui-keywords keywords))))) + +(defun lui-format-internal (fmt keywords) + "Internal function for `lui-format'. + +FMT is the format string and KEYWORDS is the symbol-based plist. + +See `lui-format'." + (with-temp-buffer + (insert fmt) + (goto-char (point-min)) + (while (re-search-forward "{{\\|}}\\|{\\([^}]*\\)}" nil t) + (cond + ((string-equal (match-string 0) "3.1") + (replace-match "{")) + ((string-equal (match-string 0) "}}") + (replace-match "}")) + (t ;; (match-string 1) + (replace-match (save-match-data + (lui-format-single (match-string 1) keywords)) + t t)))) + (buffer-string))) + +(defun lui-format-single (specifier keywords) + "Format a single braced SPECIFIER according to KEYWORDS. +See `lui-format' for details. + +This adds `lui-format-argument' as necessary." + (let* ((split (split-string specifier ":")) + (identifier (car split)) + (format (cadr split))) + (when (not format) + (setq format "s")) + (propertize (format (concat "%" format) + (lui-format-lookup identifier keywords)) + 'lui-format-argument (intern identifier)))) + +(defun lui-format-lookup (identifier keywords) + "Lookup the format IDENTIFIER in KEYWORDS. + +See `lui-format' for details." + (cond + ((string-match "^\\([0-9]+\\)\\(-\\([0-9]+\\)?\\)?$" identifier) + (let ((from (match-string 1 identifier)) + (rangep (match-string 2 identifier)) + (to (match-string 3 identifier)) + (indexed-args (plist-get keywords 'indexed-args))) + (if rangep + (mapconcat (lambda (element) + (if (stringp element) + element + (format "%s" element))) + (lui-sublist indexed-args + (string-to-number from) + (when to (string-to-number to))) + " ") + (or (nth (string-to-number from) + indexed-args) + "")))) + (t + (or (plist-get keywords (intern identifier)) + (error "Unknown keyword argument %S" identifier))))) + +(defun lui-sublist (list from &optional to) + "Return the sublist from LIST starting at FROM and ending at TO." + (if (not to) + (nthcdr from list) + (let ((from-list (nthcdr from list)) + (i (- to from)) + (to-list nil)) + (while (>= i 0) + (when (null from-list) + (error "Argument out of range: %S" to)) + (setq to-list (cons (car from-list) + to-list) + i (- i 1) + from-list (cdr from-list))) + (nreverse to-list)))) + +(provide 'lui-format) +;;; lui-format.el ends here diff --git a/elpa/circe-20161102.1405/lui-irc-colors.el b/elpa/circe-20161102.1405/lui-irc-colors.el new file mode 100644 index 00000000..9b16ead2 --- /dev/null +++ b/elpa/circe-20161102.1405/lui-irc-colors.el @@ -0,0 +1,182 @@ +;;; lui-irc-colors.el --- Add IRC color support to LUI + +;; Copyright (C) 2005 Jorgen Schaefer + +;; Author: Jorgen Schaefer + +;; This file is part of Lui. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; This tells LUI how to display IRC colors: +;; ^B - Bold +;; ^_ - Underline +;; ^V - Inverse +;; ^] - Italic +;; ^O - Return to normal +;; ^C1,2 - Colors + +;; The colors are documented at http://www.mirc.co.uk/help/color.txt + +;;; Code: + +(require 'lui) + +(defgroup lui-irc-colors nil + "LUI IRC colors faces." + :group 'circe) + +(defface lui-irc-colors-inverse-face + '((t (:inverse-video t))) + "Face used for inverse video." + :group 'lui-irc-colors) + +(defun lui-irc-defface (face property on-dark on-light rest doc) + (custom-declare-face + face + `((((type graphic) (class color) (background dark)) + (,property ,on-dark)) + (((type graphic) (class color) (background light)) + (,property ,on-light)) + (t (,property ,rest))) + doc + :group 'lui-irc-colors)) + +(defun lui-irc-defface-pair (number on-dark on-light rest name) + (lui-irc-defface + (intern (format "lui-irc-colors-fg-%d-face" number)) + :foreground + on-dark on-light rest + (concat "Face used for foreground IRC color " + (number-to-string number) " (" name ").")) + (lui-irc-defface + (intern (format "lui-irc-colors-bg-%d-face" number)) + :background + on-light on-dark rest + (concat "Face used for background IRC color " + (number-to-string number) " (" name ")."))) + +(defun lui-irc-defface-bulk (colors) + (dotimes (n (length colors)) + (apply 'lui-irc-defface-pair n (nth n colors)))) + +(lui-irc-defface-bulk + '(("#ffffff" "#585858" "white" "white") + ("#a5a5a5" "#000000" "black" "black") + ("#9b9bff" "#0000ff" "blue4" "blue") + ("#40eb51" "#006600" "green4" "green") + ("#ff9696" "#b60000" "red" "red") + ("#d19999" "#8f3d3d" "red4" "brown") + ("#d68fff" "#9c009c" "magenta4" "purple") + ("#ffb812" "#7a4f00" "yellow4" "orange") + ("#ffff00" "#5c5c00" "yellow" "yellow") + ("#80ff95" "#286338" "green" "light green") + ("#00b8b8" "#006078" "cyan4" "teal") + ("#00ffff" "#006363" "cyan" "light cyan") + ("#a8aeff" "#3f568c" "blue" "light blue") + ("#ff8bff" "#853885" "magenta" "pink") + ("#cfcfcf" "#171717" "dimgray" "grey") + ("#e6e6e6" "#303030" "gray" "light grey"))) + +(defvar lui-irc-colors-regex + "\\(\x02\\|\x1F\\|\x16\\|\x1D\\|\x0F\\|\x03\\)" + "A regular expression matching IRC control codes.") + +;;;###autoload +(defun enable-lui-irc-colors () + "Enable IRC color interpretation for Lui." + (interactive) + (add-hook 'lui-pre-output-hook 'lui-irc-colors)) + +(defun disable-lui-irc-colors () + "Disable IRC color interpretation for Lui." + (interactive) + (remove-hook 'lui-pre-output-hook 'lui-irc-colors)) + +(defun lui-irc-colors () + "Add color faces for IRC colors. +This is an appropriate function for `lui-pre-output-hook'." + (goto-char (point-min)) + (let ((start (point)) + (boldp nil) + (inversep nil) + (italicp nil) + (underlinep nil) + (fg nil) + (bg nil)) + (while (re-search-forward lui-irc-colors-regex nil t) + (lui-irc-propertize start (point) + boldp inversep italicp underlinep + fg bg) + (let ((code (match-string 1))) + (replace-match "") + (setq start (point)) + (cond + ((string= code "") + (setq boldp (not boldp))) + ((string= code "") + (setq inversep (not inversep))) + ((string= code "") + (setq italicp (not italicp))) + ((string= code "") + (setq underlinep (not underlinep))) + ((string= code "") + (setq boldp nil + inversep nil + italicp nil + underlinep nil + fg nil + bg nil)) + ((string= code "") + (if (looking-at "\\([0-9][0-9]?\\)\\(,\\([0-9][0-9]?\\)\\)?") + (progn + (setq fg (string-to-number (match-string 1)) + bg (if (match-string 2) + (string-to-number (match-string 3)) + bg)) + (setq fg (if (and fg (not (= fg 99))) (mod fg 16) nil) + bg (if (and bg (not (= bg 99))) (mod bg 16) nil)) + (replace-match "")) + (setq fg nil + bg nil))) + (t + (error "lui-irc-colors: Can't happen!"))))) + (lui-irc-propertize (point) (point-max) + boldp inversep italicp underlinep fg bg))) + +(defun lui-irc-propertize (start end boldp inversep italicp underlinep fg bg) + "Propertize the region between START and END." + (let ((faces (append (and boldp '(bold)) + (and inversep '(lui-irc-colors-inverse-face)) + (and italicp '(italic)) + (and underlinep '(underline)) + (and fg (list (lui-irc-colors-face 'fg fg))) + (and bg (list (lui-irc-colors-face 'bg bg)))))) + (when faces + (add-face-text-property start end faces)))) + +(defun lui-irc-colors-face (type n) + "Return a face appropriate for face number N. +TYPE is either 'fg or 'bg." + (if (and (<= 0 n) + (<= n 15)) + (intern (format "lui-irc-colors-%s-%s-face" type n)) + 'default-face)) + +(provide 'lui-irc-colors) +;;; lui-irc-colors.el ends here diff --git a/elpa/circe-20161102.1405/lui-logging.el b/elpa/circe-20161102.1405/lui-logging.el new file mode 100644 index 00000000..d24e051f --- /dev/null +++ b/elpa/circe-20161102.1405/lui-logging.el @@ -0,0 +1,201 @@ +;;; lui-logging.el --- Logging support for lui + +;; Copyright (C) 2006 Jorgen Schaefer, +;; 2012 Anthony Martinez + +;; Author: Anthony Martinez + +;; This file is part of Lui. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; This lui module enables logging. Lui applications can change the +;; values of `lui-logging-format-arguments' to provide further +;; possibilities of customizing `lui-logging-file-format' for users. + +;;; Code: + +(require 'lui-format) +(require 'url-util) + +(defgroup lui-logging nil + "Logging support." + :prefix "lui-logging-" + :group 'lui) + +(defcustom lui-logging-format "[%T] {text}" + "The format used for log file entries. +This is first passed through `format-time-string' and then through +`lui-format'. The following format strings exist: + + {text} - the text to be logged" + :type 'string + :group 'lui-logging) + +(defcustom lui-logging-directory "~/.logs" + "The directory where log files are stored." + :type 'directory + :group 'lui-logging) + +(defcustom lui-logging-file-format "{buffer}_%Y-%m-%d.txt" + "The format to be used for the log file name. +This is first passed through `format-time-string', and then +through `lui-format'. Possible lui format strings are: + + {buffer} - the buffer name where the logging happened. + +Lui applications can provide further format strings. See +`lui-logging-format-arguments' in the appropriate buffer." + :type 'string + :group 'lui-logging) + +(defcustom lui-logging-flush-delay 0 + "The number of seconds to delay writing newly-received messages +to disk. This can increase performance/decrease IO-wait at the +cost of a little bit of safety." + :type 'integer + :group 'lui-logging) + +(defvar lui-logging-format-arguments nil + "A list of arguments to be passed to `lui-format'. +This can be used to extend the formatting possibilities of the +file name for lui applications.") +(make-variable-buffer-local 'lui-logging-format-arguments) + +(defvar lui-logging-file-name-unreserved-chars + ;; All but '/' is fine actually, but also omit '%' because otherwise there's + ;; ambiguity between one introduced by encoding and a literal one. + '(?! ?\" ?# ?$ ?& ?` ?\( ?\) ?* ?+ ?,?: ?\; ?< ?= ?> ?? ?@?\[ ?\\ ?\] ?^ ?` + ?\{ ?| ?\}) + "A list of characters that should not be percent-encoded by +`url-hexify-string' while generating a logging file name.") + +(defvar lui-pending-logs + (make-hash-table :test 'equal) + "Storage for log messages awaiting write. It is structured as a +hash table mapping filenames to a list-of-strings, which serves as +a queue.") + +(defvar lui-logging-timer nil + "The timer used to flush lui-logged buffers") + +(defun lui-logging-delayed-p () + (> lui-logging-flush-delay 0)) + +(defun enable-lui-logging () + "Enable lui logging for this buffer. Also create the log +file's directory, should it not exist." + (interactive) + (add-hook 'lui-pre-output-hook 'lui-logging + nil t)) + +(defun disable-lui-logging () + "Disable lui logging for this buffer, and flush any pending +logs to disk." + (interactive) + (remove-hook 'lui-pre-output-hook 'lui-logging t) + (lui-logging-flush)) + +(defun enable-lui-logging-globally () + "Enable lui logging for all Lui buffers. + +This affects current as well as future buffers." + (interactive) + (add-hook 'lui-mode-hook 'enable-lui-logging) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when lui-input-marker + (enable-lui-logging))))) + +(defun disable-lui-logging-globally () + "Disable logging in all future Lui buffers. + +This affects current as well as future buffers." + (interactive) + (remove-hook 'lui-mode-hook 'enable-lui-logging) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when lui-input-marker + (disable-lui-logging))))) + +(defun lui-logging-file-name () + "Create the name of the log file based on `lui-logging-file-format'." + (let* ((time-formatted (format-time-string lui-logging-file-format)) + (buffer (let ((url-unreserved-chars + (append url-unreserved-chars + lui-logging-file-name-unreserved-chars)) + (downcased (downcase (buffer-name (current-buffer))))) + (url-hexify-string downcased))) + (filename (apply 'lui-format + time-formatted + :buffer buffer + lui-logging-format-arguments))) + (concat lui-logging-directory "/" filename))) + +(defun lui-logging-flush () + "Flush out the lui-logging queue, and clear the timer set by +`lui-logging'." + (maphash #'lui-logging-flush-file lui-pending-logs) + (clrhash lui-pending-logs) + (cancel-timer lui-logging-timer) + (setq lui-logging-timer nil)) + +(defun lui-logging-write-to-log (file-name content) + "Actually perform a write to the logfile." + (let ((coding-system-for-write 'raw-text) + (dir (file-name-directory file-name))) + (when (not (file-directory-p dir)) + (make-directory dir t)) + (write-region content nil file-name t 'nomessage))) + +(defun lui-logging-flush-file (file-name queue) + "Consume the logging queue and write the content to the log +file." + (let ((content (apply #'concat (nreverse queue)))) + (lui-logging-write-to-log file-name content))) + +(defun lui-logging-format-string (text) + "Generate a string to be either directly written or enqueued." + (substring-no-properties + (lui-format + (format-time-string lui-logging-format) + :text text))) + +(defun lui-logging-enqueue (file-name text) + "Given a filename, push text onto its queue, and tickle the +timer, if necessary." + (puthash file-name + (cons text (gethash file-name lui-pending-logs)) + lui-pending-logs) + (when (null lui-logging-timer) + (setq lui-logging-timer + (run-with-timer lui-logging-flush-delay nil + #'lui-logging-flush)))) + +(defun lui-logging () + "If output-queueing is enabled, append the to-be-logged string +to the output queue. Otherwise, write directly to the logfile. +This should be added to `lui-pre-output-hook' by way of +`enable-lui-logging'." + (let ((text (lui-logging-format-string (buffer-string)))) + (if (lui-logging-delayed-p) + (lui-logging-enqueue (lui-logging-file-name) text) + (lui-logging-write-to-log (lui-logging-file-name) text)))) + +(provide 'lui-logging) +;;; lui-logging.el ends here diff --git a/elpa/circe-20161102.1405/lui-track-bar.el b/elpa/circe-20161102.1405/lui-track-bar.el new file mode 100644 index 00000000..360ecf69 --- /dev/null +++ b/elpa/circe-20161102.1405/lui-track-bar.el @@ -0,0 +1,110 @@ +;;; lui-track-bar.el --- Provides a bar to track the last read position + +;; Copyright (C) 2016 Vasilij Schneidermann + +;; Author: Vasilij Schneidermann + +;; This file is part of LUI. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; This allows you to track where you've last left off a buffer. + +;; Use (enable-lui-track-bar) to enable this mode globally. You can +;; customize `lui-track-bar-behavior' to change when the track bar +;; moves. You can also use M-x lui-track-bar-move to move the track +;; bar manually. + +;;; Code: + +(require 'lui) +(require 'tracking) + +(defgroup lui-track-bar nil + "Last read position tracking for LUI" + :prefix "lui-track-bar-" + :group 'lui) + +(defcustom lui-track-bar-behavior 'before-switch-to-buffer + "When to move the track bar. + +The following values are possible. + +before-switch-to-buffer (default) + Move the bar to the bottom of the buffer when switching away + from a buffer. + +before-tracking-next-buffer + Move the bar when switching to the next buffer using + \\[tracking-next-buffer]. + +after-send + Move the bar after sending a message." + :type '(choice (const :tag "Before switching buffers" + before-switch-to-buffer) + (const :tag "Before tracking switch" + before-tracking-next-buffer) + (const :tag "After sending" + after-send)) + :group 'lui-track-bar) + +(defface lui-track-bar + '((((type graphic) (background light)) + :inherit default :background "dim gray" :height 0.1) + (((type graphic) (background dark)) + :inherit default :background "light gray" :height 0.1) + (((type tty)) + :inherit (font-lock-comment-face default) :underline t)) + "Track bar face" + :group 'lui-track-bar) + +(defvar lui-track-bar-overlay nil) +(make-variable-buffer-local 'lui-track-bar-overlay) + +;;;###autoload +(defun enable-lui-track-bar () + "Enable a bar in Lui buffers that shows where you stopped reading." + (interactive) + (defadvice switch-to-buffer (before lui-track-bar activate) + (when (and (eq lui-track-bar-behavior 'before-switch-to-buffer) + ;; Do not move the bar if the buffer is displayed still + (<= (length (get-buffer-window-list (current-buffer))) + 1)) + (lui-track-bar-move))) + (defadvice tracking-next-buffer (before lui-track-bar activate) + (when (eq lui-track-bar-behavior 'before-tracking-next-buffer) + (lui-track-bar-move))) + (add-hook 'lui-pre-input-hook 'lui-track-bar--move-pre-input)) + +(defun lui-track-bar--move-pre-input () + (when (eq lui-track-bar-behavior 'after-send) + (lui-track-bar-move))) + +(defun lui-track-bar-move () + "Move the track bar down." + (interactive) + (when (derived-mode-p 'lui-mode) + (when (not lui-track-bar-overlay) + (setq lui-track-bar-overlay (make-overlay (point-min) (point-min))) + (overlay-put lui-track-bar-overlay 'after-string + (propertize "\n" 'face 'lui-track-bar))) + (move-overlay lui-track-bar-overlay + lui-output-marker lui-output-marker))) + +(provide 'lui-track-bar) +;;; lui-track-bar.el ends here diff --git a/elpa/circe-20161102.1405/lui.el b/elpa/circe-20161102.1405/lui.el new file mode 100644 index 00000000..7a565541 --- /dev/null +++ b/elpa/circe-20161102.1405/lui.el @@ -0,0 +1,1343 @@ +;;; lui.el --- Linewise User Interface -*- lexical-binding: t -*- + +;; Copyright (C) 2005 - 2016 Jorgen Schaefer + +;; Author: Jorgen Schaefer +;; URL: https://github.com/jorgenschaefer/circe/wiki/Lui + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General 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: + +;; Lui is a library for other Emacs Lisp programs and not useful by +;; itself. + +;; This major mode provides a user interface for applications. The +;; user interface is quite simple, consisting of an input line, a +;; prompt, and some output area, but Lui includes a lot of common +;; options, such as time stamps, filling, colorization, etc. + +;; Application programs should create modes derived from lui-mode. + +;; The application API consists of: + +;; lui-mode +;; lui-set-prompt +;; lui-insert +;; lui-input-function +;; lui-completion-function +;; lui-time-stamp-time +;; lui-time-stamp-zone +;; and the 'lui-fool and 'lui-do-not-track text properties + +;;; Code: + +(require 'button) +(require 'flyspell) +(require 'help-mode) +(require 'ispell) +(require 'paren) +(require 'ring) +(require 'thingatpt) +(require 'rx) + +(require 'tracking) + + +;;;;;;;;;;;;;;;;;;;;; +;;; Customization ;;; +;;;;;;;;;;;;;;;;;;;;; + +(defgroup lui nil + "The Linewise User Interface." + :prefix "lui-" + :group 'applications) + +(defcustom lui-scroll-behavior t + "Set the behavior lui should exhibit for scrolling. + +The following values are possible. If in doubt, use post-output. + +nil + Use default Emacs scrolling. + +post-command + Keep the input line at the end of the window if point is + after the input mark. + +post-output + Keep the input line at the end of the window only after output. + +t + Combine both post-command and post-output. + +post-scroll + Keep the input line at the end of the window on every scroll + event. Careful, this might interact badly with other functions + on `window-scroll-functions'. + + +It would be entirely sensible for Emacs to provide a setting to +do this kind of scrolling by default in a buffer. It seems rather +intuitive and sensible. But as noted on emacs-devel: + + [T]hose who know the code know that it's going to be a pain to + implement, especially if you want acceptable performance. IOW, + patches welcome + +The full discussion can be found here: + +https://lists.gnu.org/archive/html/emacs-devel/2012-10/msg00652.html + +These settings are all hacks that try to give the user the choice +between most correct behavior (post-scroll) and most compliant +behavior (post-output)." + :type '(choice (const :tag "Post Command" t) + (const :tag "Post Output" post-output) + (const :tag "Post Scroll" post-scroll) + (const :tag "Use default scrolling" nil)) + :group 'lui) +(defvaralias 'lui-scroll-to-bottom-p 'lui-scroll-behavior) + +(defcustom lui-flyspell-p nil + "Non-nil if Lui should spell-check your input. +See the function `flyspell-mode' for more information." + :type 'boolean + :group 'lui) + +(defcustom lui-flyspell-alist nil + "Alist of buffer dictionaries. + +This is a list of mappings from buffers to dictionaries to use +for the function `flyspell-mode'. The appropriate dictionary is +automatically used when Lui is activated in a buffer with a +matching buffer name. + +The entries are of the form (REGEXP DICTIONARY), where REGEXP +must match a buffer name, and DICTIONARY specifies an existing +dictionary for the function `flyspell-mode'. See +`ispell-local-dictionary-alist' and `ispell-dictionary-alist' for +a valid list of dictionaries." + :type 'string + :group 'lui) + +(defcustom lui-highlight-keywords nil + "A list of keywords to highlight. + +This specifies a list of keywords that Lui should highlight. Each +entry is of one of the following forms (similar to +`font-lock-keywords'): + + REGEXP + Highlight every match in `lui-highlight-face' + (REGEXP SUBMATCH) + Highlight the SUBMATCH (a number) in REGEXP in + `lui-highlight-face' + (REGEXP FACE) + Highlight everything matching REGEXP in FACE (a symbol) + (REGEXP SUBMATCH FACE) + Highlight the SUBMATCH in REGEXP in FACE + +In all of these cases, the FACE can also be a property list which +is then associated with the match. + +All matches are run, which means later matches can override +changes by earlier ones." + :type '(repeat (choice + (string :tag "Regular Expression") + (list :tag "Submatch" + (string :tag "Regular Expression") + (integer :tag "Submatch")) + (list :tag "Regular Expression in Specific Face" + (string :tag "Regular Expression") + (face :tag "Face")) + (list :tag "Submatch in Specific Face" + (string :tag "Regular Expression") + (integer :tag "Submatch") + (face :tag "Face")))) + :group 'lui) + +(defface lui-strong-face + '((t (:inherit bold))) + "Face used for strong markup." + :group 'lui-irc-colors) + +(defface lui-emphasis-face + '((t (:inherit italic))) + "Face for emphasis markup." + :group 'lui-irc-colors) + +(defcustom lui-formatting-list nil + "List of enabled formatting types. +Each list item is a list consisting of a regular expression +matching the highlighted text, an integer for the submatch and a +face for highlighting the match." + :type `(set + (const :tag "*Strong* text" + (,(rx (or bol whitespace) + (group "*" (+? (not (any whitespace "*"))) "*") + (or eol whitespace)) + 1 lui-strong-face)) + (const :tag "_Emphasized_ text" + (,(rx (or bol whitespace) + (group "_" (+? (not (any whitespace "_"))) "_") + (or eol whitespace)) + 1 lui-emphasis-face))) + :group 'lui) + +(defcustom lui-buttons-list + `(("`\\([A-Za-z0-9+=*/-]+\\)'" 1 + lui-button-elisp-symbol 1) + ("\\") 'lui-previous-button) + (define-key map (kbd "") 'lui-previous-button) + (define-key map (kbd "M-p") 'lui-previous-input) + (define-key map (kbd "M-n") 'lui-next-input) + (define-key map (kbd "C-c C-u") 'lui-kill-to-beginning-of-line) + (define-key map (kbd "C-c C-i") 'lui-fool-toggle-display) + map) + "The key map used in Lui modes.") + +(defvar lui-input-marker nil + "The marker where input should be inserted.") +(make-variable-buffer-local 'lui-input-marker) + +(defvar lui-output-marker nil + "The marker where output should be inserted. +Use `lui-insert' instead of accessing this marker directly.") +(make-variable-buffer-local 'lui-output-marker) + +(defvar lui-input-ring nil + "The input history ring.") +(make-variable-buffer-local 'lui-input-ring) + +(defvar lui-input-ring-index nil + "The index to the current item in the input ring.") +(make-variable-buffer-local 'lui-input-ring-index) + + +;;;;;;;;;;;;;; +;;; Macros ;;; +;;;;;;;;;;;;;; + +(defmacro lui-save-undo-list (&rest body) + "Run BODY without modifying the undo list." + (let ((old-marker-sym (make-symbol "old-marker"))) + `(let ((,old-marker-sym (marker-position lui-input-marker)) + (val nil)) + ;; Don't modify the undo list. The undo list is for the user's + ;; input only. + (let ((buffer-undo-list t)) + (setq val (progn ,@body))) + (when (consp buffer-undo-list) + ;; Not t :-) + (setq buffer-undo-list (lui-adjust-undo-list buffer-undo-list + ,old-marker-sym + (- lui-input-marker + ,old-marker-sym)))) + val))) + + +;;;;;;;;;;;;;;;;;; +;;; Major Mode ;;; +;;;;;;;;;;;;;;;;;; + +(define-derived-mode lui-mode nil "LUI" + "The Linewise User Interface mode. +This can be used as a user interface for various applications. +Those should define derived modes of this, so this function +should never be called directly. + +It can be customized for an application by specifying a +`lui-input-function'." + (setq lui-input-marker (make-marker) + lui-output-marker (make-marker) + lui-input-ring (make-ring lui-input-ring-size) + lui-input-ring-index nil + flyspell-generic-check-word-p 'lui-flyspell-check-word-p) + (set-marker lui-input-marker (point-max)) + (set-marker lui-output-marker (point-max)) + (add-hook 'window-scroll-functions 'lui-scroll-window nil t) + (add-hook 'post-command-hook 'lui-scroll-post-command) + (add-hook 'change-major-mode-hook 'lui-change-major-mode nil t) + (lui-paren-highlighting) + (lui-time-stamp-enable-filtering) + (tracking-mode 1) + (auto-fill-mode 0) + (when (fboundp 'cursor-intangible-mode) + (cursor-intangible-mode 1)) + (when lui-flyspell-p + (require 'flyspell) + (lui-flyspell-change-dictionary))) + +(defun lui-change-major-mode () + "Assure that the user really wants to change the major mode. +This is a good value for a buffer-local `change-major-mode-hook'." + (when (not (y-or-n-p "Really change major mode in a Lui buffer? ")) + (error "User disallowed mode change"))) + +(defun lui-scroll-window (window _display-start) + "Scroll the input line to the bottom of the WINDOW. + +DISPLAY-START is passed by the hook `window-scroll-functions' and +is ignored. + +See `lui-scroll-behavior' for how to customize this." + (when (and (eq lui-scroll-behavior 'post-scroll) + window + (window-live-p window)) + (with-selected-window window + (when (or (>= (point) lui-input-marker) + (equal (point-max) + (window-end nil t))) + (let ((resize-mini-windows nil)) + (save-excursion + (goto-char (point-max)) + (recenter -1))))))) + +(defun lui-scroll-post-command () + "Scroll the input line to the bottom of the window. + +This is called from `post-command-hook'. + +See `lui-scroll-behavior' for how to customize this." + (condition-case err + (dolist (w (window-list)) + (with-current-buffer (window-buffer w) + (when (and lui-input-marker + (memq lui-scroll-behavior '(t post-command))) + ;; Code from ERC's erc-goodies.el. I think this was originally + ;; mine anyhow, not sure though. + (save-restriction + (widen) + (when (>= (point) lui-input-marker) + (save-excursion + (goto-char (point-max)) + (with-selected-window w + (recenter -1)))))))) + (error + (message "Error in lui-scroll-post-command: %S" err) + ))) + +(defun lui-scroll-post-output () + "Scroll the input line to the bottom of the window. + +This is called when lui output happens. + +See `lui-scroll-behavior' for how to customize this." + (when (memq lui-scroll-behavior '(t post-output)) + (let ((resize-mini-windows nil)) + (dolist (window (get-buffer-window-list (current-buffer) nil t)) + (when (or (>= (point) lui-input-marker) + (equal (point-max) + (window-end window))) + (with-selected-window window + (save-excursion + (goto-char (point-max)) + (recenter -1)))))))) + + +;;;;;;;;;;;;; +;;; Input ;;; +;;;;;;;;;;;;; + +(defun lui-send-input () + "Send the current input to the Lui application. +If point is not in the input area, insert a newline." + (interactive) + (if (< (point) lui-input-marker) + (newline) + (save-restriction + (narrow-to-region lui-input-marker (point-max)) + (run-hooks 'lui-pre-input-hook)) + (let ((input (buffer-substring lui-input-marker (point-max)))) + (delete-region lui-input-marker (point-max)) + (lui-add-input input) + (if lui-input-function + (funcall lui-input-function input) + (error "No input function specified"))))) + +(defun lui-add-input (input) + "Add INPUT as if entered by the user." + (ring-insert lui-input-ring input) + (setq lui-input-ring-index nil)) + + +;;;;;;;;;;;;;;; +;;; Buttons ;;; +;;;;;;;;;;;;;;; + +(define-button-type 'lui-button + 'supertype 'button + 'follow-link t + 'face 'lui-button-face) + +(defun lui-buttonize () + "Buttonize the current message." + (lui-buttonize-urls) + (lui-buttonize-custom) + (lui-buttonize-issues)) + +(defun lui-buttonize-custom () + "Add custom buttons to the current message. + +This uses `lui-buttons-list'." + (dolist (entry lui-buttons-list) + (let ((regex (nth 0 entry)) + (submatch (nth 1 entry)) + (function-or-url (nth 2 entry)) + (arg-matches (nthcdr 3 entry))) + (goto-char (point-min)) + (while (re-search-forward regex nil t) + ;; Ensure we're not inserting a button inside a URL button + (when (not (button-at (match-beginning 0))) + (let* ((function (if (functionp function-or-url) + function-or-url + 'browse-url)) + (matches (mapcar (lambda (n) + (match-string-no-properties n)) + arg-matches)) + (arguments (if (functionp function-or-url) + matches + (list (apply #'format function-or-url + matches))))) + (make-button (match-beginning submatch) + (match-end submatch) + 'type 'lui-button + 'action 'lui-button-activate + 'lui-button-function function + 'lui-button-arguments arguments))))))) + +(defun lui-buttonize-issues () + "Buttonize issue references in the current message, if configured." + (when lui-button-issue-tracker + (goto-char (point-min)) + (while (re-search-forward "\\(?:^\\|\\W\\)\\(#\\([0-9]+\\)\\)" nil t) + ;; Ensure we're not inserting a button inside a URL button + (when (not (button-at (point))) + (make-button (match-beginning 1) + (match-end 1) + 'type 'lui-button + 'action 'lui-button-activate + 'lui-button-function 'browse-url + 'lui-button-arguments + (list (format lui-button-issue-tracker + (match-string 2)))))))) + +(defun lui-buttonize-urls () + "Buttonize URLs in the current message." + (let ((regex (regexp-opt thing-at-point-uri-schemes))) + (goto-char (point-min)) + (while (re-search-forward regex nil t) + (let ((bounds (bounds-of-thing-at-point 'url))) + (when bounds + (make-button (car bounds) + (cdr bounds) + 'type 'lui-button + 'action 'lui-button-activate + 'lui-button-function 'browse-url + 'lui-button-arguments + (list (buffer-substring-no-properties + (car bounds) + (cdr bounds))))))))) + +(defun lui-button-activate (button) + "Activate BUTTON. +This calls the function stored in the `lui-button-function' +property with the argument stored in `lui-button-arguments'." + (apply (button-get button 'lui-button-function) + (button-get button 'lui-button-arguments))) + +(defun lui-next-button-or-complete () + "Go to the next button, or complete at point. +When point is in the input line, call `lui-completion-function'. +Otherwise, we move to the next button." + (interactive) + (if (>= (point) + lui-input-marker) + (funcall lui-completion-function) + (forward-button 1))) + +(defun lui-previous-button () + "Go to the previous button." + (interactive) + (backward-button 1)) + +(defun lui-button-elisp-symbol (name) + "Show the documentation for the symbol named NAME." + (let ((sym (intern-soft name))) + (cond + ((not sym) + (message "No such symbol %s" name) + (ding)) + (t + (help-xref-interned sym))))) + +(defun lui-button-pep (number) + "Browse the PEP NUMBER." + (browse-url (format "https://www.python.org/dev/peps/pep-%04i" + (string-to-number number)))) + +(defun lui-button-issue (issue) + "Browse the issue tracker number ISSUE, if configured." + (if lui-button-issue-tracker + (browse-url (format lui-button-issue-tracker issue)) + (error "No issue tracker configured, see `lui-button-issue-tracker'"))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Input Line Killing ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun lui-kill-to-beginning-of-line () + "Kill the input from point to the beginning of the input." + (interactive) + (let* ((beg (point-at-bol)) + (end (point)) + (str (buffer-substring beg end))) + (delete-region beg end) + (kill-new str))) + + +;;;;;;;;;;;;;;;;;;;;; +;;; Input History ;;; +;;;;;;;;;;;;;;;;;;;;; + +;; FIXME! +;; These need some better algorithm. They clobber input when it is not +;; in the ring! +(defun lui-previous-input () + "Cycle through the input history to the last input." + (interactive) + (when (> (ring-length lui-input-ring) 0) + (if (and lui-input-ring-index + (= (1- (ring-length lui-input-ring)) + lui-input-ring-index)) + ;; last item - insert a single empty line + (progn + (lui-replace-input "") + (setq lui-input-ring-index nil)) + ;; If any input is left, store it in the input ring + (when (and (null lui-input-ring-index) + (> (point-max) lui-input-marker)) + (ring-insert lui-input-ring + (buffer-substring lui-input-marker (point-max))) + (setq lui-input-ring-index 0)) + ;; Increment the index + (setq lui-input-ring-index + (if lui-input-ring-index + (ring-plus1 lui-input-ring-index (ring-length lui-input-ring)) + 0)) + ;; And insert the last input + (lui-replace-input (ring-ref lui-input-ring lui-input-ring-index)) + (goto-char (point-max))))) + +(defun lui-next-input () + "Cycle through the input history to the next input." + (interactive) + (when (> (ring-length lui-input-ring) 0) + (if (and lui-input-ring-index + (= 0 lui-input-ring-index)) + ;; first item - insert a single empty line + (progn + (lui-replace-input "") + (setq lui-input-ring-index nil)) + ;; If any input is left, store it in the input ring + (when (and (null lui-input-ring-index) + (> (point-max) lui-input-marker)) + (ring-insert lui-input-ring + (buffer-substring lui-input-marker (point-max))) + (setq lui-input-ring-index 0)) + ;; Decrement the index + (setq lui-input-ring-index (ring-minus1 (or lui-input-ring-index 0) + (ring-length lui-input-ring))) + ;; And insert the next input + (lui-replace-input (ring-ref lui-input-ring lui-input-ring-index)) + (goto-char (point-max))))) + +(defun lui-replace-input (str) + "Replace input with STR." + (save-excursion + (goto-char lui-input-marker) + (delete-region lui-input-marker (point-max)) + (insert str))) + + +;;;;;;;;;;;;; +;;; Fools ;;; +;;;;;;;;;;;;; + +(defun lui-fools () + "Propertize the current narrowing according to foolhardiness. +That is, if any part of it has the text property 'lui-fool set, +make the whole thing invisible." + (when (text-property-any (point-min) + (point-max) + 'lui-fool t) + (add-text-properties (point-min) + (point-max) + '(invisible lui-fool)))) + +(defun lui-fools-hidden-p () + "Return whether fools are currently hidden." + (if (or (eq t buffer-invisibility-spec) + (memq 'lui-fool buffer-invisibility-spec)) + t + nil)) + +(defun lui-fool-toggle-display () + "Display what fools have said." + (interactive) + (when (eq buffer-invisibility-spec t) + (add-to-invisibility-spec 'lui-fool)) + (cond + ((lui-fools-hidden-p) + (message "Now showing the gibberish of fools") + (remove-from-invisibility-spec 'lui-fool)) + (t + (message "Now hiding fools again *phew*") + (add-to-invisibility-spec 'lui-fool))) + ;; For some reason, after this, the display does not always update + ;; (issue #31). Force an update just in case. + (force-mode-line-update t)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Blink Paren and Show Paren Mode ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun lui-paren-highlighting () + "Enable sane parenthesis highlighting in this buffer." + (set (make-local-variable 'blink-paren-function) + 'lui-blink-paren-function) + (when (boundp 'show-paren-data-function) + (set (make-local-variable 'show-paren-data-function) + 'lui-show-paren-data-function))) + +(defun lui-blink-paren-function () + "Do not blink opening parens outside of the lui input area. + +When point is within the lui input area, inserting a closing +parenthesis should only blink parens within the input area, not +outside of it. + +This is a suitable value for `blink-paren-function', which see." + (if (> (point) lui-input-marker) + (let ((blink-matching-paren-distance (- (point) + lui-input-marker))) + (blink-matching-open)) + (blink-matching-open))) + +(defun lui-show-paren-data-function () + "Show parens only within the input area. + +When `show-paren-mode' is enabled, and point is in the input +area, parenthesis highlighting should only happen within the +input area, not include the rest of the buffer. + +This is a suitable value for `show-paren-data-function', which see." + (when (fboundp 'show-paren--default) + (let ((range (show-paren--default))) + (if (or (< (point) lui-input-marker) + (not (elt range 2)) + (>= (elt range 2) lui-input-marker)) + range + nil)))) + + +;;;;;;;;;;;;;;;; +;;; Flyspell ;;; +;;;;;;;;;;;;;;;; + +(defun lui-flyspell-change-dictionary (&optional dictionary) + "*Change flyspell to DICTIONARY. +If DICTIONARY is nil, set a default dictionary according to +`lui-flyspell-alist'. +If it is \"\", disable flyspell." + (interactive (list (completing-read + "Use new dictionary (RET for none, SPC to complete): " + (and (fboundp 'ispell-valid-dictionary-list) + (mapcar 'list (ispell-valid-dictionary-list))) + nil t))) + (let ((dictionary (or dictionary + (lui-find-dictionary (buffer-name))))) + (when flyspell-mode + (flyspell-mode 0)) + (when (and dictionary + (not (equal dictionary ""))) + (ispell-change-dictionary dictionary)) + (flyspell-mode 1))) + + +(defun lui-find-dictionary (buffer-name) + "Return a dictionary appropriate for BUFFER-NAME." + (let ((lis lui-flyspell-alist) + (result nil)) + (while lis + (if (string-match (caar lis) buffer-name) + (setq result (cadr (car lis)) + lis nil) + (setq lis (cdr lis)))) + result)) + +(defun lui-flyspell-check-word-p () + "Return non-nil when flyspell should verify at this position. +This is the value of Lui for `flyspell-generic-check-word-p'." + (>= (point) + lui-input-marker)) + + +;;;;;;;;;;;;;; +;;; Output ;;; +;;;;;;;;;;;;;; + +(defun lui-insert (str &optional not-tracked-p) + "Insert STR into the current Lui buffer. + +If NOT-TRACKED-P is given, this insertion won't trigger tracking +of the buffer." + (lui-save-undo-list + (save-excursion + (save-restriction + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (widen) + (goto-char lui-output-marker) + (let ((beg (point)) + (end nil)) + (insert str "\n") + (setq end (point)) + (set-marker lui-output-marker (point)) + (narrow-to-region beg end)) + (goto-char (point-min)) + (add-text-properties (point-min) + (point-max) + `(lui-raw-text ,str)) + (run-hooks 'lui-pre-output-hook) + (lui-apply-formatting) + (lui-highlight-keywords) + (lui-buttonize) + (lui-fill) + (lui-time-stamp) + (goto-char (point-min)) + (run-hooks 'lui-post-output-hook) + (lui-fools) + (goto-char (point-min)) + (let ((faces (lui-faces-in-region (point-min) + (point-max))) + (foolish (text-property-any (point-min) + (point-max) + 'lui-fool t)) + (not-tracked-p + (or not-tracked-p + (text-property-any (point-min) + (point-max) + 'lui-do-not-track t)))) + (widen) + (lui-truncate) + (lui-read-only) + (when (and (not not-tracked-p) + (not foolish)) + (tracking-add-buffer (current-buffer) + faces))) + (lui-scroll-post-output)))))) + +(defun lui-adjust-undo-list (list old-begin shift) + "Adjust undo positions in list. +LIST is in the format of `buffer-undo-list'. +Only positions after OLD-BEGIN are affected. +The positions are adjusted by SHIFT positions." + ;; This is necessary because the undo-list keeps exact buffer + ;; positions. + ;; Thanks to ERC for the idea of the code. + ;; ERC's code doesn't take care of an OLD-BEGIN value, which is + ;; necessary if you allow modification of the buffer. + (let* ((gc-cons-threshold most-positive-fixnum) ;; See debbugs#22120#47 + (adjust-position (lambda (pos) + (if (and (numberp pos) + ;; After the boundary: Adjust + (>= (abs pos) + old-begin)) + (* (if (< pos 0) + -1 + 1) + (+ (abs pos) + shift)) + pos))) + (adjust (lambda (entry) + (cond + ;; POSITION + ((numberp entry) + (funcall adjust-position entry)) + ((not (consp entry)) + entry) + ;; (BEG . END) + ((numberp (car entry)) + (cons (funcall adjust-position (car entry)) + (funcall adjust-position (cdr entry)))) + ;; (TEXT . POSITION) + ((stringp (car entry)) + (cons (car entry) + (funcall adjust-position (cdr entry)))) + ;; (nil PROPERTY VALUE BEG . END) + ((not (car entry)) + `(nil ,(nth 1 entry) + ,(nth 2 entry) + ,(funcall adjust-position (nth 3 entry)) + . + ,(funcall adjust-position (nthcdr 4 entry)))) + ;; (apply DELTA BEG END FUN-NAME . ARGS) + ((and (eq 'apply (car entry)) + (numberp (cadr entry))) + `(apply ,(nth 1 entry) + ,(funcall adjust-position (nth 2 entry)) + ,(funcall adjust-position (nth 3 entry)) + ,(nth 4 entry) + . + ,(nthcdr 5 entry))) + (t + entry))))) + (mapcar adjust list))) + +(defvar lui-prompt-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") 'lui-prompt-end-of-line) + (define-key map (kbd "C-e") 'lui-prompt-end-of-line) + map) + "Keymap for Lui prompts. +Since \\[end-of-line] can't move out of fields, this DTRT for an +unexpecting user.") + +(defun lui-set-prompt (prompt) + "Set PROMPT as the current Lui prompt." + (let ((inhibit-read-only t)) + (lui-save-undo-list + (save-excursion + (goto-char lui-output-marker) + (insert prompt) + (if (> lui-input-marker (point)) + (delete-region (point) lui-input-marker) + (set-marker lui-input-marker (point))) + (add-text-properties lui-output-marker lui-input-marker + `(read-only t + rear-nonsticky t + field lui-prompt + keymap ,lui-prompt-map + front-sticky t + )))))) + +(defun lui-prompt-end-of-line (&optional _N) + "Move past the prompt, and then to the end of the line. +This uses `end-of-line'. + +The argument N is ignored." + (interactive "p") + (goto-char lui-input-marker) + (call-interactively 'end-of-line)) + +(defun lui-faces-in-region (beg end) + "Return a face that describes the region between BEG and END." + (goto-char beg) + (let ((faces nil)) + (while (not (= (point) end)) + (let ((face (get-text-property (point) 'face))) + (dolist (face (if (consp face) + face + (list face))) + (when (and face + (facep face) + (face-differs-from-default-p face)) + (push face faces))) + (goto-char (next-single-property-change (point) 'face + nil end)))) + faces)) + + + +;;;;;;;;;;;;;;;;;;;; +;;; Highlighting ;;; +;;;;;;;;;;;;;;;;;;;; + +(defun lui-highlight-keywords () + "Highlight the entries in the variable `lui-highlight-keywords'. + +This is called automatically when new text is inserted." + (let ((regex (lambda (entry) + (if (stringp entry) + entry + (car entry)))) + (submatch (lambda (entry) + (if (and (consp entry) + (numberp (cadr entry))) + (cadr entry) + 0))) + (properties (lambda (entry) + (let ((face (cond + ;; REGEXP + ((stringp entry) + 'lui-highlight-face) + ;; (REGEXP SUBMATCH) + ((and (numberp (cadr entry)) + (null (cddr entry))) + 'lui-highlight-face) + ;; (REGEXP FACE) + ((null (cddr entry)) + (cadr entry)) + ;; (REGEXP SUBMATCH FACE) + (t + (nth 2 entry))))) + (if (facep face) + `(face ,face) + face))))) + (dolist (entry lui-highlight-keywords) + (goto-char (point-min)) + (while (re-search-forward (funcall regex entry) nil t) + (let* ((exp (funcall submatch entry)) + (beg (match-beginning exp)) + (end (match-end exp))) + (when (not (text-property-any beg end 'lui-highlight-fontified-p t)) + (add-text-properties beg end + (append (funcall properties entry) + '(lui-highlight-fontified-p t))))))))) + +(defun lui-apply-formatting () + "Highlight the entries in `lui-formatting-list'." + (dolist (entry lui-formatting-list) + (goto-char (point-min)) + (let ((re (car entry)) + (subgroup (cadr entry)) + (face (nth 2 entry))) + (while (re-search-forward re nil t) + (when face + (add-face-text-property (match-beginning subgroup) (match-end subgroup) + face nil (current-buffer))))))) + + +;;;;;;;;;;;;;;; +;;; Filling ;;; +;;;;;;;;;;;;;;; + +(defun lui-fill () + "Fill the text in the buffer. +This is called automatically when new text is inserted. See +`lui-fill-type' and `lui-fill-column' on how to customize this +function." + (cond + ((stringp lui-fill-type) + (let ((fill-prefix lui-fill-type) + (fill-column (or lui-fill-column + fill-column))) + (fill-region (point-min) (point-max) + nil t))) + ((eq lui-fill-type 'variable) + (let ((fill-prefix (save-excursion + (goto-char (point-min)) + (let ((beg (point))) + (re-search-forward "\\s-" nil t) + (make-string (- (point) beg) ? )))) + (fill-column (or lui-fill-column + fill-column))) + (fill-region (point-min) (point-max) + nil t))) + ((numberp lui-fill-type) + (let ((right-end (save-excursion + (goto-char (point-min)) + (re-search-forward "\\s-" nil t) + (- (point) + (point-at-bol))))) + (goto-char (point-min)) + (when (< right-end lui-fill-type) + (insert (make-string (- lui-fill-type + right-end) + ? ))) + (let ((fill-prefix (make-string lui-fill-type ? )) + (fill-column (or lui-fill-column + fill-column))) + (fill-region (point-min) (point-max) + nil t))))) + (when lui-fill-remove-face-from-newline + (goto-char (point-min)) + (while (re-search-forward "\n" nil t) + (put-text-property (match-beginning 0) + (match-end 0) + 'face + nil)))) + + +;;;;;;;;;;;;;;;;;;; +;;; Time Stamps ;;; +;;;;;;;;;;;;;;;;;;; + +(defvar lui-time-stamp-last nil + "The last time stamp.") +(make-variable-buffer-local 'lui-time-stamp-last) + +(defvar lui-time-stamp-time nil + "A custom time to use as the time stamp for `lui-insert'. + +This variable should be let-bound when you wish to provide a +custom time to be printed by `lui-time-stamp'. If this variable +is nil the current time is used. See the TIME argument to +`format-time-string' for more information.") + +(defvar lui-time-stamp-zone nil + "A custom timezone to use for the time stamp for `lui-insert'. + +This variable should be let-bound when you wish to provide a +custom time zone when printing the time stamp with +`lui-time-stamp'. If this variable is nil local time is used. +See the ZONE argument to `format-time-string' for more +information.") + +(defun lui-time-stamp () + "Add a time stamp to the current buffer." + (let ((ts (format-time-string lui-time-stamp-format + lui-time-stamp-time + lui-time-stamp-zone))) + (cond + ;; Time stamps right + ((or (numberp lui-time-stamp-position) + (eq lui-time-stamp-position 'right)) + (when (or (not lui-time-stamp-only-when-changed-p) + (not lui-time-stamp-last) + (not (string= ts lui-time-stamp-last))) + (goto-char (point-min)) + (goto-char (point-at-eol)) + (let* ((curcol (current-column)) + (col (if (numberp lui-time-stamp-position) + lui-time-stamp-position + (+ 2 (or lui-fill-column + fill-column + (point))))) + (indent (if (> col curcol) + (- col curcol) + 1)) + (ts-string (propertize + (concat (make-string indent ?\s) + (propertize + ts + 'face 'lui-time-stamp-face)) + 'lui-time-stamp t)) + (start (point))) + (insert ts-string) + (add-text-properties start (1+ (point)) '(intangible t)) + (add-text-properties (1+ start) (point) '(cursor-intangible t))))) + ;; Time stamps left + ((eq lui-time-stamp-position 'left) + (let ((indent-string (propertize (make-string (length ts) ?\s) + 'lui-time-stamp t))) + (goto-char (point-min)) + (cond + ;; Time stamp + ((or (not lui-time-stamp-only-when-changed-p) + (not lui-time-stamp-last) + (not (string= ts lui-time-stamp-last))) + (insert (propertize ts + 'face 'lui-time-stamp-face + 'lui-time-stamp t))) + ;; Just indentation + (t + (insert indent-string))) + (forward-line 1) + (while (< (point) (point-max)) + (insert indent-string) + (forward-line 1)))) + ;; Time stamps in margin + ((or (eq lui-time-stamp-position 'right-margin) + (eq lui-time-stamp-position 'left-margin)) + (when (or (not lui-time-stamp-only-when-changed-p) + (not lui-time-stamp-last) + (not (string= ts lui-time-stamp-last))) + (goto-char (point-min)) + (goto-char (point-at-eol)) + (let* ((ts (propertize ts 'face 'lui-time-stamp-face)) + (ts-margin (propertize + " " + 'display `((margin ,lui-time-stamp-position) + ,ts) + 'lui-time-stamp t))) + (insert ts-margin))))) + (setq lui-time-stamp-last ts))) + +(defun lui-time-stamp-enable-filtering () + "Enable filtering of timestamps from copied text." + (set (make-local-variable 'filter-buffer-substring-functions) + '(lui-filter-buffer-time-stamps))) + +(defun lui-filter-buffer-time-stamps (fun beg end delete) + "Filter text from copied strings. + +This is meant for the variable `filter-buffer-substring-functions', +which see for an explanation of the argument FUN, BEG, END and +DELETE." + (let ((string (funcall fun beg end delete)) + (inhibit-point-motion-hooks t) + (inhibit-read-only t) + ;; Emacs 24.4, 24.5 + deactivate-mark) + (with-temp-buffer + (insert string) + (let ((start (text-property-any (point-min) + (point-max) + 'lui-time-stamp t))) + (while start + (let ((end (next-single-property-change start 'lui-time-stamp + nil (point-max)))) + (delete-region start end) + (setq start (text-property-any (point-min) (point-max) + 'lui-time-stamp t)))) + (buffer-string))))) + +(defun lui-time-stamp-buffer-substring (buffer-string) + "Filter text from copied strings. + +This is meant for the variable `buffer-substring-filters', +which see for an explanation of the argument BUFFER-STRING." + (lui-filter-buffer-time-stamps (lambda (_beg _end _delete) + buffer-string) + nil nil nil)) + + +;;;;;;;;;;;;;;;;;; +;;; Truncating ;;; +;;;;;;;;;;;;;;;;;; + +(defun lui-truncate () + "Truncate the current buffer if it exceeds `lui-max-buffer-size'." + (when (and lui-max-buffer-size + (> (point-max) + lui-max-buffer-size)) + (goto-char (- (point-max) + lui-max-buffer-size)) + (forward-line 0) + (let ((inhibit-read-only t)) + (delete-region (point-min) (point))))) + + +;;;;;;;;;;;;;;;;; +;;; Read-Only ;;; +;;;;;;;;;;;;;;;;; + +(defun lui-read-only () + "Make the current output read-only if `lui-read-only-output-p' is non-nil." + (when lui-read-only-output-p + (add-text-properties (point-min) lui-output-marker + '(read-only t + front-sticky t)))) + + +(provide 'lui) +;;; lui.el ends here diff --git a/elpa/circe-20161102.1405/make-tls-process.el b/elpa/circe-20161102.1405/make-tls-process.el new file mode 100644 index 00000000..71a26186 --- /dev/null +++ b/elpa/circe-20161102.1405/make-tls-process.el @@ -0,0 +1,194 @@ +;;; make-tls-process.el --- A non-blocking TLS connection function + +;; Copyright (C) 2015 Jorgen Schaefer + +;; Author: Jorgen Schaefer +;; URL: https://github.com/jorgenschaefer/circe + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General 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: + +;; A `make-tls-process' function like `make-network-process', in +;; particular supporting non-blocking connects. + +;;; Code: + +(require 'tls) + +(defcustom tls-connection-command + (if (executable-find "gnutls-cli") + "gnutls-cli --insecure -p %p %h" + "openssl s_client -connect %h:%p -no_ssl2 -ign_eof") + "The command to use to create a TLS connection. + +%h is replaced with server hostname, %p with port to connect to. +The program should read input on stdin and write output to +stdout. + +Also see `tls-success' for what the program should output after +successful negotiation." + :group 'tls + :type 'string) + +(defvar tls-debug-output nil + "Non-nil if you want to see lots of debug messages.") + +(defun tls--debug (format-string &rest args) + "Display a message if debug output is enabled. + +If `tls-debug-output' is non-nil, this acts like `message'. +Otherwise, it's a no-op." + (when tls-debug-output + (apply #'message format-string args))) + +(defun make-tls-process (&rest args) + "Create a TLS client process. + +A TLS network process is a command process that runs a command +line program like gnutls or openssl, not a full network process. +Network communication should work as usual, but the sentinel +might receive process-specific events. + +Different from a process sentinel, but like a network sentinel, +the sentinel is called with an event \"open\\n\" when the +connection is established. + +This function uses `tls-connection-command' to connect to a +server. + +Do NOT use `set-process-filter' or `set-process-sentinel' on the +return value of this function. The connection setup uses special +sentinels and filters to be deal with the program output used +here. Use the :sentinel and :filter keyword arguments to set them +once the connection is fully established. + +Arguments are specified as keyword/argument pairs, similar to +`make-network-process'. The following arguments are defined: + +:name NAME -- NAME is name for process. It is modified if necessary +to make it unique. + +:buffer BUFFER -- BUFFER is the buffer (or buffer-name) to associate +with the process. Process output goes at end of that buffer, unless +you specify an output stream or filter function to handle the output. +BUFFER may be also nil, meaning that this process is not associated +with any buffer. + +:host HOST -- HOST is name of the host to connect to, or its IP +address. The symbol `local' specifies the local host. If specified +for a server process, it must be a valid name or address for the local +host, and only clients connecting to that address will be accepted. + +:service SERVICE -- SERVICE is name of the service desired, or an +integer specifying a port number to connect to. If SERVICE is t, +a random port number is selected for the server. (If Emacs was +compiled with getaddrinfo, a port number can also be specified as +a string, e.g. \"80\", as well as an integer. This is not +portable.) + +:coding CODING -- If CODING is a symbol, it specifies the coding +system used for both reading and writing for this process. If CODING +is a cons (DECODING . ENCODING), DECODING is used for reading, and +ENCODING is used for writing. + +:noquery BOOL -- Query the user unless BOOL is non-nil, and process is +running when Emacs is exited. + +:filter FILTER -- Install FILTER as the process filter. + +:sentinel SENTINEL -- Install SENTINEL as the process sentinel. + +:plist PLIST -- Install PLIST as the new process's initial plist." + (let* ((name (plist-get args :name)) + (host (plist-get args :host)) + (service (plist-get args :service)) + (proc (tls--start-process name tls-connection-command host service))) + (process-put proc :tls-args args) + (set-process-sentinel proc #'tls--sentinel) + (set-process-filter proc #'tls--filter) + proc)) + +(defun tls--sentinel (proc event) + "The default sentinel for TLS connections. + +Try the next command in the list, or fail if there are none +left." + (tls--debug "tls--sentinel %S %S" + (process-status proc) + event) + (tls--debug "Failed TLS output: %s" + (process-get proc :tls-data)) + (if (eq (process-status proc) + 'exit) + (let ((sentinel (plist-get (process-get proc :tls-args) + :sentinel))) + (when sentinel + (funcall sentinel proc (format "failed with %s\n" event)))) + (error "Unexpected event in tls sentinel: %S" event))) + +(defun tls--filter (proc data) + "The default filter for TLS connections. + +We wait until both `tls-success' and `tls-end-of-info' have been +received. Once that happens, we are done and we can switch over +to the real connection." + (let ((data (concat (or (process-get proc :tls-data) + "") + data))) + (if (and (string-match tls-success data) + (string-match tls-end-of-info data)) + (let* ((remaining-data (substring data (match-end 0))) + (args (process-get proc :tls-args)) + (buffer (plist-get args :buffer)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (plist (plist-get args :plist))) + (set-process-plist proc plist) + (set-process-sentinel proc sentinel) + (set-process-filter proc filter) + (set-process-buffer proc buffer) + (if (consp coding) + (set-process-coding-system proc (car coding) (cdr coding)) + (set-process-coding-system proc coding coding)) + (set-process-query-on-exit-flag proc (not noquery)) + (when sentinel + (funcall sentinel proc "open\n")) + (when (and (not (equal remaining-data "")) + filter) + (funcall filter proc remaining-data))) + (process-put proc :tls-data data)))) + +(defun tls--start-process (name cmd host port) + "Start a single process for network communication. + +This code is mostly taken from tls.el." + (let ((process-connection-type tls-process-connection-type) + (formatted-cmd + (format-spec + cmd + (format-spec-make + ?h host + ?p (if (integerp port) + (int-to-string port) + port))))) + (tls--debug "TLS starting process: %s" formatted-cmd) + (start-process name nil + shell-file-name shell-command-switch + formatted-cmd))) + +(provide 'make-tls-process) +;;; make-tls-process.el ends here diff --git a/elpa/circe-20161102.1405/shorten.el b/elpa/circe-20161102.1405/shorten.el new file mode 100644 index 00000000..1ba6085b --- /dev/null +++ b/elpa/circe-20161102.1405/shorten.el @@ -0,0 +1,223 @@ +;;; shorten.el --- component-wise string shortener + +;; Copyright (C) 2013 John J Foerch + +;; Keywords: extensions +;; Author: John J Foerch +;; URL: https://github.com/jorgenschaefer/circe/blob/master/shorten.el + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General 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 component-wise string shortener, meaning that, given a list +;; of strings, it breaks each string into parts, then computes shortest +;; prefix of each part with respect to others of the same 'depth', such +;; that when joined back together, the shortened form of the whole string +;; remains unique within the resulting list. Many styles of shortening +;; are made possible via three functions that the caller may provide: the +;; split function, the join function, and the validate-component function. +;; +;; Strings are broken with the value of `shorten-split-function' (a +;; procedure string->list), and shortened components are rejoined with the +;; value of `shorten-join-function' (a procedure list->string[*]). The +;; default split and join functions break the string on word boundaries, +;; and rejoin on the empty string. Potential shortened forms of +;; components are tested with `shorten-validate-component-function'; its +;; default value passes only if its argument contains at least one +;; word-constituent character (regexp \w), meaning that by default, +;; components consisting entirely of non-word characters will not be +;; shortened, and components that start with non-word characters will only +;; be shortened so much that they have at least one word-constituent +;; character in them. +;; +;; The main entry point is `shorten-strings', which takes a list of strings +;; as its argument and returns an alist ((STRING . SHORTENED-STRING) ...). +;; +;; [*] Also takes a second argument; see docstring of +;; `shorten-join-function'. + +;;; History: + +;; - Version 0.1 (March 7, 2013): initial release + +;;; Code: + +;; Tree utils +;; +(defsubst shorten-make-tree-root () + (cons nil nil)) + +(defsubst shorten-tree-make-entry (token short full) + (list token short full nil)) + +(defsubst shorten-tree-token (entry) + (car entry)) + +(defsubst shorten-tree-fullname (entry) + (nth 2 entry)) + +(defsubst shorten-tree-descendants (entry) + (nthcdr 3 entry)) + +(defsubst shorten-tree-set-shortened (entry short) + (setcar (cdr entry) short)) + +(defsubst shorten-tree-set-fullname (entry full) + (setcar (nthcdr 2 entry) full)) + +(defsubst shorten-tree-insert (node item) + (when (car node) + (setcdr node (cons (car node) (cdr node)))) + (setcar node item)) + + +;; Caller configuration +;; +(defun shorten-split (s) + (split-string s "\\b" t)) + +(defun shorten-join (lst &optional tail-count) + (mapconcat #'identity lst "")) + +(defun shorten-join-sans-tail (lst tail-count) + "A shorten-join that drops unnecessary tail components." + (shorten-join (butlast lst tail-count))) + +(defun shorten-validate-component (str) + (string-match-p "\\w" str)) + +(defvar shorten-split-function #'shorten-split + "Value should be a function of string->list that breaks a +string into components. The default breaks on word-boundaries. +To get simple prefix shortening, bind this to `list'. + +Users should not generally change the global value of this +variable; instead, bind it dynamically around calls to +`shorten-strings'.") + +(defvar shorten-join-function #'shorten-join + "A function that takes a list of components and a tail-count, +and returns a joined string. Tail-count is the number of +components on the end of the list that are not needed to uniquify +the result, and so may be safely dropped if aggressive shortening +is desired. The default preserves tail components, and joins the +list on the empty string. + +Users should not generally change the global value of this +variable; instead, bind it dynamically around calls to +`shorten-strings'.") + +(defvar shorten-validate-component-function #'shorten-validate-component + "Predicate that returns t if a proposed shortened form of a +single component is acceptable, nil if a longer one should be +tried. The default validates only when the candidate contains at +least one word-constituent character, thus strings consisting of +punctuation will not be shortened. For aggressive shortening, +bind to a procedure that always returns t. + +Users should not generally change the global value of this +variable; instead, bind it dynamically around calls to +`shorten-strings'.") + + +;; Main procedures +;; +(defun shorten-one (str others) + "Return shortest unique prefix of STR among OTHERS, or STR if +it cannot be shortened. If STR is a member of OTHERS (tested +with `eq') that entry is ignored. The value of +`shorten-validate-component-function' will be used to validate +any prefix." + (let ((max (length str)) + (len 1)) + (or (catch 'return + (while (< len max) + (let ((prefix (substring str 0 len))) + (when (funcall shorten-validate-component-function prefix) + (when (catch 'return + (dolist (other others t) + (when (and (>= (length other) len) + (string= (substring other 0 len) prefix) + (not (eq other str))) + (throw 'return nil)))) + (throw 'return prefix))) + (setq len (1+ len))))) + str))) + +(defun shorten-walk-internal (node path tail-count result-out) + (let ((others (mapcar #'car node))) + (setq tail-count (if (cdr node) 0 (1+ tail-count))) + (dolist (entry node) + (let* ((token (shorten-tree-token entry)) + (shortened (shorten-one token others)) + (path (cons shortened path)) + (fullname (shorten-tree-fullname entry)) + (descendants (shorten-tree-descendants entry)) + (have-descendants (not (equal '(nil) descendants)))) + (shorten-tree-set-shortened entry shortened) + ;; if this entry has a fullname, add to result-out + (when fullname + (let ((joined (funcall shorten-join-function + (reverse path) + (if have-descendants 0 tail-count)))) + (shorten-tree-insert result-out (cons fullname joined)))) + ;; if this entry has descendants, recurse + (when have-descendants + (shorten-walk-internal descendants path + (if fullname -1 tail-count) + result-out)))))) + +(defun shorten-walk (tree) + "Takes a tree of the type made by `shorten-make-tree' and +returns an alist ((STRING . SHORTENED-STRING) ...). Uses +`shorten-join-function' to join shortened components back +together into SHORTENED-STRING. See also +`shorten-validate-component-function'." + (let ((result-out (shorten-make-tree-root))) + (shorten-walk-internal tree '() -1 result-out) + (if (equal '(nil) result-out) nil result-out))) + +(defun shorten-make-tree (strings) + "Takes a list of strings and returns a tree of the type used by +`shorten-walk' to generate shortened strings. Uses +`shorten-split-function' to split the strings." + (let ((tree (shorten-make-tree-root))) + (dolist (s strings) + (let ((node tree) + (tokens (funcall shorten-split-function s)) + (entry nil)) + ;; create a path in tree for tokens + (dolist (token tokens) + (setq entry (assoc token node)) + (when (not entry) + (setq entry (shorten-tree-make-entry token nil nil)) + (shorten-tree-insert node entry)) + (setq node (shorten-tree-descendants entry))) + ;; for the last token, set 'fullname' + (shorten-tree-set-fullname entry s))) + (if (equal tree '(nil)) nil tree))) + +;;;###autoload +(defun shorten-strings (strings) + "Takes a list of strings and returns an alist ((STRING +. SHORTENED-STRING) ...). Uses `shorten-split-function' to split +the strings, and `shorten-join-function' to join shortened +components back together into SHORTENED-STRING. See also +`shorten-validate-component-function'." + (shorten-walk (shorten-make-tree strings))) + + +(provide 'shorten) +;;; shorten.el ends here diff --git a/elpa/circe-20161102.1405/tracking.el b/elpa/circe-20161102.1405/tracking.el new file mode 100644 index 00000000..028090d8 --- /dev/null +++ b/elpa/circe-20161102.1405/tracking.el @@ -0,0 +1,391 @@ +;;; tracking.el --- Buffer modification tracking + +;; Copyright (C) 2006, 2012 - 2015 Jorgen Schaefer + +;; Author: Jorgen Schaefer +;; URL: https://github.com/jorgenschaefer/circe/wiki/Tracking + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General 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: + +;; tracking.el is a library for other Emacs Lisp programs not useful +;; by itself. + +;; The library provides a way to globally register buffers as being +;; modified and scheduled for user review. The user can cycle through +;; the buffers using C-c C-SPC. This is especially useful for buffers +;; that interact with external sources, such as chat clients and +;; similar programs. + +;;; Code: + +(require 'easy-mmode) +(require 'shorten) +(require 'cl-lib) + +;;; User customization +(defgroup tracking nil + "Tracking of buffer activities." + :prefix "tracking-" + :group 'applications) + +(defcustom tracking-shorten-buffer-names-p t + "Whether to shorten buffer names in the mode line. +A non-nil value will cause tracked buffer names to be shortened +as much as possible to stay unambiguous when displaying them in +the mode line." + :type 'boolean + :group 'tracking) + +(defcustom tracking-frame-behavior 'visible + "How to deal with frams to determine visibility of buffers. +This is passed as the second argument to `get-buffer-window', +see there for further explanation." + :type '(choice (const :tag "All visible frames" visible) + (const :tag "Visible and iconified frames" 0) + (const :tag "All frames" t) + (const :tag "Selected frame only" nil)) + :group 'tracking) + +(defcustom tracking-position 'before-modes + "Where tracked buffers should appear in the mode line. + + 'before-modes + Before the mode indicators + 'after-modes + After the mode indicators + 'end + At the end of the mode line" + :type '(choice (const :tag "Before the Mode Indicators" before-modes) + (const :tag "Afterthe Mode Indicators" after-modes) + (const :tag "At the End of the Mode Line" end)) + :group 'tracking) + +(defcustom tracking-faces-priorities nil + "A list of faces which should be shown by tracking in the mode line. +The first face found in this list is used." + :type '(repeat face) + :group 'tracking) + +(defcustom tracking-ignored-buffers nil + "A list of buffers that are never tracked. +Each element of this list has one of the following forms: + + regexp - Any buffer matching won't be tracked. + function - Any buffer matching won't be tracked. + (regexp faces ...) - Any buffer matching won't be tracked, + unless it has a face in FACES ... associated with it. + If no faces are given, `tracking-faces-priorities' is + used. + (function faces ...) - As per above, but with a function + as predicate instead of a regexp." + :type '(repeat (choice regexp + function + (list (choice regexp function) + (repeat face)))) + :group 'tracking) + +(defcustom tracking-most-recent-first nil + "When non-nil, newly tracked buffers will go to the front of the +list, rather than to the end." + :type 'boolean + :group 'tracking) + +(defcustom tracking-buffer-added-hook nil + "Hook run when a buffer has some activity. + +The functions are run in the context of the buffer. + +This can also happen when the buffer is already tracked. Check if the +buffer name is in `tracking-buffers' if you want to see if it was +added before." + :type 'hook + :group 'tracking) + +(defcustom tracking-buffer-removed-hook nil + "Hook run when a buffer becomes active and is removed. + +The functions are run in the context of the buffer." + :type 'hook + :group 'tracking) + +;;; Internal variables +(defvar tracking-buffers nil + "The list of currently tracked buffers.") + +(defvar tracking-mode-line-buffers "" + "The entry to the mode line.") +(put 'tracking-mode-line-buffers 'risky-local-variable t) + +(defvar tracking-start-buffer nil + "The buffer we started from when cycling through the active buffers.") + +(defvar tracking-last-buffer nil + "The buffer we last switched to with `tracking-next-buffer'. +When this is not the current buffer when we continue switching, a +new `tracking-start-buffer' is created.") + +(defvar tracking-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-SPC") 'tracking-next-buffer) + (define-key map (kbd "C-c C-@") 'tracking-next-buffer) + map) + "The keymap used for tracking mode.") + +;;;###autoload +(define-minor-mode tracking-mode + "Allow cycling through modified buffers. +This mode in itself does not track buffer modification, but +provides an API for programs to add buffers as modified (using +`tracking-add-buffer'). + +Once this mode is active, modified buffers are shown in the mode +line. The user can cycle through them using +\\[tracking-next-buffer]." + :group 'tracking + :global t + (cond + (tracking-mode + (cond + ((eq tracking-position 'before-modes) + (let ((head nil) + (tail (default-value 'mode-line-format))) + (when (not (memq 'tracking-mode-line-buffers tail)) + (catch 'return + (while tail + (if (not (eq (car tail) + 'mode-line-modes)) + (setq head (cons (car tail) + head) + tail (cdr tail)) + (setq-default mode-line-format + (append (reverse head) + '(tracking-mode-line-buffers) + tail)) + (throw 'return t))))))) + ((eq tracking-position 'after-modes) + (add-to-list 'mode-line-misc-info + 'tracking-mode-line-buffers)) + ((eq tracking-position 'end) + (add-to-list 'mode-line-misc-info + 'tracking-mode-line-buffers + t)) + (t + (error "Invalid value for `tracking-position' (%s)" tracking-position))) + (add-hook 'window-configuration-change-hook + 'tracking-remove-visible-buffers)) + (t + (setq mode-line-misc-info (delq 'tracking-mode-line-buffers + mode-line-misc-info)) + (setq-default mode-line-format (delq 'tracking-mode-line-buffers + (default-value 'mode-line-format))) + (remove-hook 'window-configuration-change-hook + 'tracking-remove-visible-buffers)))) + +;;;###autoload +(defun tracking-add-buffer (buffer &optional faces) + "Add BUFFER as being modified with FACES. +This does check whether BUFFER is currently visible. + +If FACES is given, it lists the faces that might be appropriate +for BUFFER in the mode line. The highest-priority face of these +and the current face of the buffer, if any, is used. Priority is +decided according to `tracking-faces-priorities'." + (when (and (not (get-buffer-window buffer tracking-frame-behavior)) + (not (tracking-ignored-p buffer faces))) + (with-current-buffer buffer + (run-hooks 'tracking-buffer-added-hook)) + (let* ((entry (member (buffer-name buffer) + tracking-buffers))) + (if entry + (setcar entry (tracking-faces-merge (car entry) + faces)) + (setq tracking-buffers + (if tracking-most-recent-first + (cons (tracking-faces-merge (buffer-name buffer) + faces) + tracking-buffers) + (nconc tracking-buffers + (list (tracking-faces-merge (buffer-name buffer) + faces))))))) + (setq tracking-mode-line-buffers (tracking-status)) + (force-mode-line-update t) + )) + +;;;###autoload +(defun tracking-remove-buffer (buffer) + "Remove BUFFER from being tracked." + (when (member (buffer-name buffer) + tracking-buffers) + (with-current-buffer buffer + (run-hooks 'tracking-buffer-removed-hook))) + (setq tracking-buffers (delete (buffer-name buffer) + tracking-buffers)) + (setq tracking-mode-line-buffers (tracking-status)) + (sit-for 0) ;; Update mode line + ) + +;;;###autoload +(defun tracking-next-buffer () + "Switch to the next active buffer." + (interactive) + (cond + ((and (not tracking-buffers) + tracking-start-buffer) + (let ((buf tracking-start-buffer)) + (setq tracking-start-buffer nil) + (if (buffer-live-p buf) + (switch-to-buffer buf) + (message "Original buffer does not exist anymore") + (ding)))) + ((not tracking-buffers) + nil) + (t + (when (not (eq tracking-last-buffer + (current-buffer))) + (setq tracking-start-buffer (current-buffer))) + (let ((new (car tracking-buffers))) + (when (buffer-live-p (get-buffer new)) + (with-current-buffer new + (run-hooks 'tracking-buffer-removed-hook))) + (setq tracking-buffers (cdr tracking-buffers) + tracking-mode-line-buffers (tracking-status)) + (if (buffer-live-p (get-buffer new)) + (switch-to-buffer new) + (message "Buffer %s does not exist anymore" new) + (ding) + (setq tracking-mode-line-buffers (tracking-status)))) + (setq tracking-last-buffer (current-buffer)) + ;; Update mode line. See `force-mode-line-update' for the idea for + ;; this code. Using `sit-for' can be quite inefficient for larger + ;; buffers. + (dolist (w (window-list)) + (with-current-buffer (window-buffer w))) + ))) + +;;;###autoload +(defun tracking-previous-buffer () + "Switch to the last active buffer." + (interactive) + (when tracking-buffers + (switch-to-buffer (car (last tracking-buffers))))) + +(defun tracking-ignored-p (buffer faces) + "Return non-nil when BUFFER with FACES shouldn't be tracked. +This uses `tracking-ignored-buffers'. Actual returned value is +the entry from tracking-ignored-buffers that causes this buffer +to be ignored." + (catch 'return + (let ((buffer-name (buffer-name buffer))) + (dolist (entry tracking-ignored-buffers) + (cond + ((stringp entry) + (and (string-match entry buffer-name) + (throw 'return entry))) + ((functionp entry) + (and (funcall entry buffer-name) + (throw 'return entry))) + ((or (and (stringp (car entry)) + (string-match (car entry) buffer-name)) + (and (functionp (car entry)) + (funcall (car entry) buffer-name))) + (when (not (tracking-any-in (or (cdr entry) + tracking-faces-priorities) + faces)) + (throw 'return entry)))))) + nil)) + +(defun tracking-status () + "Return the current track status. + +This returns a list suitable for `mode-line-format'." + (if (not tracking-buffers) + "" + (let* ((buffer-names (cl-remove-if-not #'get-buffer tracking-buffers)) + (shortened-names (tracking-shorten tracking-buffers)) + (result (list " ["))) + (while buffer-names + (push `(:propertize + ,(car shortened-names) + face ,(get-text-property 0 'face (car buffer-names)) + keymap ,(let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] + `(lambda () + (interactive) + (pop-to-buffer ,(car buffer-names)))) + map) + mouse-face mode-line-highlight + help-echo ,(format (concat "New activity in %s\n" + "mouse-1: pop to the buffer") + (car buffer-names))) + result) + (setq buffer-names (cdr buffer-names) + shortened-names (cdr shortened-names)) + (when buffer-names + (push "," result))) + (push "] " result) + (nreverse result)))) + +(defun tracking-remove-visible-buffers () + "Remove visible buffers from the tracked buffers. +This is usually called via `window-configuration-changed-hook'." + (interactive) + (dolist (buffer-name tracking-buffers) + (let ((buffer (get-buffer buffer-name))) + (cond + ((not buffer) + (setq tracking-buffers (delete buffer-name tracking-buffers)) + (setq tracking-mode-line-buffers (tracking-status)) + (sit-for 0)) + ((get-buffer-window buffer tracking-frame-behavior) + (tracking-remove-buffer buffer)))))) + +;;; Helper functions +(defun tracking-shorten (buffers) + "Shorten BUFFERS according to `tracking-shorten-buffer-names-p'." + (if tracking-shorten-buffer-names-p + (let ((all (shorten-strings (mapcar #'buffer-name (buffer-list))))) + (mapcar (lambda (buffer) + (let ((short (cdr (assoc buffer all)))) + (set-text-properties + 0 (length short) + (text-properties-at 0 buffer) + short) + short)) + buffers)) + buffers)) + +(defun tracking-any-in (lista listb) + "Return non-nil when any element in LISTA is in LISTB" + (catch 'return + (dolist (entry lista) + (when (memq entry listb) + (throw 'return t))) + nil)) + +(defun tracking-faces-merge (string faces) + "Merge faces into string, adhering to `tracking-faces-priorities'. +This returns STRING with the new face." + (let ((faces (cons (get-text-property 0 'face string) + faces))) + (catch 'return + (dolist (candidate tracking-faces-priorities) + (when (memq candidate faces) + (throw 'return + (propertize string 'face candidate)))) + string))) + +(provide 'tracking) +;;; tracking.el ends here diff --git a/elpa/command-log-mode-20160412.2147/command-log-mode-autoloads.el b/elpa/command-log-mode-20160412.2147/command-log-mode-autoloads.el new file mode 100644 index 00000000..1d0e3375 --- /dev/null +++ b/elpa/command-log-mode-20160412.2147/command-log-mode-autoloads.el @@ -0,0 +1,27 @@ +;;; command-log-mode-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path)))) + +;;;### (autoloads nil "command-log-mode" "command-log-mode.el" (22527 +;;;;;; 20560 0 0)) +;;; Generated autoloads from command-log-mode.el + +(autoload 'command-log-mode "command-log-mode" "\ +Toggle keyboard command logging. + +\(fn &optional ARG)" t nil) + +(autoload 'clm/toggle-command-log-buffer "command-log-mode" "\ +Toggle the command log showing or not. + +\(fn &optional ARG)" t nil) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; command-log-mode-autoloads.el ends here diff --git a/elpa/command-log-mode-20160412.2147/command-log-mode-pkg.el b/elpa/command-log-mode-20160412.2147/command-log-mode-pkg.el new file mode 100644 index 00000000..d72a9fd1 --- /dev/null +++ b/elpa/command-log-mode-20160412.2147/command-log-mode-pkg.el @@ -0,0 +1,2 @@ +;;; -*- no-byte-compile: t -*- +(define-package "command-log-mode" "20160412.2147" "log keyboard commands to buffer" 'nil :url "https://github.com/lewang/command-log-mode" :keywords '("help")) diff --git a/elpa/command-log-mode-20160412.2147/command-log-mode.el b/elpa/command-log-mode-20160412.2147/command-log-mode.el new file mode 100644 index 00000000..37e6d651 --- /dev/null +++ b/elpa/command-log-mode-20160412.2147/command-log-mode.el @@ -0,0 +1,323 @@ +;;; command-log-mode.el --- log keyboard commands to buffer + +;; homepage: https://github.com/lewang/command-log-mode + +;; Copyright (C) 2013 Nic Ferrier +;; Copyright (C) 2012 Le Wang +;; Copyright (C) 2004 Free Software Foundation, Inc. + +;; Author: Michael Weber +;; Keywords: help +;; Package-Version: 20160412.2147 +;; Initial-version: <2004-10-07 11:41:28 michaelw> +;; Time-stamp: <2004-11-06 17:08:11 michaelw> + +;; This file is free software; you can 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, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This add-on can be used to demo Emacs to an audience. When +;; activated, keystrokes get logged into a designated buffer, along +;; with the command bound to them. + +;; To enable, use e.g.: +;; +;; (require 'command-log-mode) +;; (add-hook 'LaTeX-mode-hook 'command-log-mode) +;; +;; To see the log buffer, call M-x clm/open-command-log-buffer. + +;; The key strokes in the log are decorated with ISO9601 timestamps on +;; the property `:time' so if you want to convert the log for +;; screencasting purposes you could use the time stamp as a key into +;; the video beginning. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defvar clm/log-text t + "A non-nil setting means text will be saved to the command log.") + +(defvar clm/log-repeat nil + "A nil setting means repetitions of the same command are merged into the single log line.") + +(defvar clm/recent-history-string "" + "This string will hold recently typed text.") + +(defun clm/recent-history () + (setq clm/recent-history-string + (concat clm/recent-history-string + (buffer-substring-no-properties (- (point) 1) (point))))) + +(add-hook 'post-self-insert-hook 'clm/recent-history) + +(defun clm/zap-recent-history () + (unless (or (member this-original-command + clm/log-command-exceptions*) + (eq this-original-command #'self-insert-command)) + (setq clm/recent-history-string ""))) + +(add-hook 'post-command-hook 'clm/zap-recent-history) + +(defvar clm/time-string "%Y-%m-%dT%H:%M:%S" + "The string sent to `format-time-string' when command time is logged.") + +(defvar clm/logging-dir "~/log/" + "Directory in which to store files containing logged commands.") + +(defvar clm/log-command-exceptions* + '(nil self-insert-command backward-char forward-char + delete-char delete-backward-char backward-delete-char + backward-delete-char-untabify + universal-argument universal-argument-other-key + universal-argument-minus universal-argument-more + beginning-of-line end-of-line recenter + move-end-of-line move-beginning-of-line + handle-switch-frame + newline previous-line next-line) + "A list commands which should not be logged, despite logging being enabled. +Frequently used non-interesting commands (like cursor movements) should be put here.") + +(defvar clm/command-log-buffer nil + "Reference of the currenly used buffer to display logged commands.") +(defvar clm/command-repetitions 0 + "Count of how often the last keyboard commands has been repeated.") +(defvar clm/last-keyboard-command nil + "Last logged keyboard command.") + + +(defvar clm/log-command-indentation 11 + "*Indentation of commands in command log buffer.") + +(defgroup command-log nil + "Customization for the command log.") + +(defcustom command-log-mode-auto-show nil + "Show the command-log window or frame automatically." + :group 'command-log + :type 'boolean) + +(defcustom command-log-mode-window-size 40 + "The size of the command-log window." + :group 'command-log + :type 'integer) + +(defcustom command-log-mode-window-font-size 2 + "The font-size of the command-log window." + :group 'command-log + :type 'integer) + +(defcustom command-log-mode-key-binding-open-log "C-c o" + "The key binding used to toggle the log window." + :group 'command-log + :type '(radio + (const :tag "No key" nil) + (key-sequence "C-c o"))) ;; this is not right though it works for kbd + +(defcustom command-log-mode-open-log-turns-on-mode nil + "Does opening the command log turn on the mode?" + :group 'command-log + :type 'boolean) + +(defcustom command-log-mode-is-global nil + "Does turning on command-log-mode happen globally?" + :group 'command-log + :type 'boolean) + +;;;###autoload +(define-minor-mode command-log-mode + "Toggle keyboard command logging." + :init-value nil + :lighter " command-log" + :keymap nil + (if command-log-mode + (when (and + command-log-mode-auto-show + (not (get-buffer-window clm/command-log-buffer))) + (clm/open-command-log-buffer)) + ;; We can close the window though + (clm/close-command-log-buffer))) + +(define-global-minor-mode global-command-log-mode command-log-mode + command-log-mode) + +(defun clm/buffer-log-command-p (cmd &optional buffer) + "Determines whether keyboard command CMD should be logged. +If non-nil, BUFFER specifies the buffer used to determine whether CMD should be logged. +If BUFFER is nil, the current buffer is assumed." + (let ((val (if buffer + (buffer-local-value command-log-mode buffer) + command-log-mode))) + (and (not (null val)) + (null (member cmd clm/log-command-exceptions*))))) + +(defmacro clm/save-command-environment (&rest body) + (declare (indent 0)) + `(let ((deactivate-mark nil) ; do not deactivate mark in transient + ; mark mode + ;; do not let random commands scribble over + ;; {THIS,LAST}-COMMAND + (this-command this-command) + (last-command last-command)) + ,@body)) + +(defun clm/open-command-log-buffer (&optional arg) + "Opens (and creates, if non-existant) a buffer used for logging keyboard commands. +If ARG is Non-nil, the existing command log buffer is cleared." + (interactive "P") + (with-current-buffer + (setq clm/command-log-buffer + (get-buffer-create " *command-log*")) + (text-scale-set 1)) + (when arg + (with-current-buffer clm/command-log-buffer + (erase-buffer))) + (let ((new-win (split-window-horizontally + (- 0 command-log-mode-window-size)))) + (set-window-buffer new-win clm/command-log-buffer) + (set-window-dedicated-p new-win t))) + +(defun clm/close-command-log-buffer () + "Close the command log window." + (interactive) + (with-current-buffer + (setq clm/command-log-buffer + (get-buffer-create " *command-log*")) + (let ((win (get-buffer-window (current-buffer)))) + (when (windowp win) + (delete-window win))))) + +;;;###autoload +(defun clm/toggle-command-log-buffer (&optional arg) + "Toggle the command log showing or not." + (interactive "P") + (when (and command-log-mode-open-log-turns-on-mode + (not command-log-mode)) + (if command-log-mode-is-global + (global-command-log-mode) + (command-log-mode))) + (with-current-buffer + (setq clm/command-log-buffer + (get-buffer-create " *command-log*")) + (let ((win (get-buffer-window (current-buffer)))) + (if (windowp win) + (clm/close-command-log-buffer) + ;; Else open the window + (clm/open-command-log-buffer arg))))) + +(defun clm/scroll-buffer-window (buffer &optional move-fn) + "Updates `point' of windows containing BUFFER according to MOVE-FN. +If non-nil, MOVE-FN is called on every window which displays BUFFER. +If nil, MOVE-FN defaults to scrolling to the bottom, making the last line visible. + +Scrolling up can be accomplished with: +\(clm/scroll-buffer-window buf (lambda () (goto-char (point-min)))) +" + (let ((selected (selected-window)) + (point-mover (or move-fn + (function (lambda () (goto-char (point-max))))))) + (walk-windows (function (lambda (window) + (when (eq (window-buffer window) buffer) + (select-window window) + (funcall point-mover) + (select-window selected)))) + nil t))) + +(defmacro clm/with-command-log-buffer (&rest body) + (declare (indent 0)) + `(when (and (not (null clm/command-log-buffer)) + (buffer-name clm/command-log-buffer)) + (with-current-buffer clm/command-log-buffer + ,@body))) + +(defun clm/log-command (&optional cmd) + "Hook into `pre-command-hook' to intercept command activation." + (clm/save-command-environment + (setq cmd (or cmd this-command)) + (when (clm/buffer-log-command-p cmd) + (clm/with-command-log-buffer + (let ((current (current-buffer))) + (goto-char (point-max)) + (cond ((and (not clm/log-repeat) (eq cmd clm/last-keyboard-command)) + (incf clm/command-repetitions) + (save-match-data + (when (and (> clm/command-repetitions 1) + (search-backward "[" (line-beginning-position -1) t)) + (delete-region (point) (line-end-position)))) + (backward-char) ; skip over either ?\newline or ?\space before ?\[ + (insert " [") + (princ (1+ clm/command-repetitions) current) + (insert " times]")) + (t ;; (message "last cmd: %s cur: %s" last-command cmd) + ;; showing accumulated text with interleaved key presses isn't very useful + (when (and clm/log-text (not clm/log-repeat)) + (if (eq clm/last-keyboard-command 'self-insert-command) + (insert "[text: " clm/recent-history-string "]\n"))) + (setq clm/command-repetitions 0) + (insert + (propertize + (key-description (this-command-keys)) + :time (format-time-string clm/time-string (current-time)))) + (when (>= (current-column) clm/log-command-indentation) + (newline)) + (move-to-column clm/log-command-indentation t) + (princ (if (byte-code-function-p cmd) "" cmd) current) + (newline) + (setq clm/last-keyboard-command cmd))) + (clm/scroll-buffer-window current)))))) + +(defun clm/command-log-clear () + "Clear the command log buffer." + (interactive) + (with-current-buffer clm/command-log-buffer + (erase-buffer))) + +(defun clm/save-log-line (start end) + "Helper function for `clm/save-command-log' to export text properties." + (save-excursion + (goto-char start) + (let ((time (get-text-property (point) :time))) + (if time + (list (cons start (if time + (concat "[" (get-text-property (point) :time) "] ") + ""))))))) + +(defun clm/save-command-log () + "Save commands to today's log. +Clears the command log buffer after saving." + (interactive) + (save-window-excursion + (set-buffer (get-buffer " *command-log*")) + (goto-char (point-min)) + (let ((now (format-time-string "%Y-%m-%d")) + (write-region-annotate-functions '(clm/save-log-line))) + (while (and (re-search-forward "^.*" nil t) + (not (eobp))) + (append-to-file (line-beginning-position) (1+ (line-end-position)) (concat clm/logging-dir now)))) + (clm/command-log-clear))) + +(add-hook 'pre-command-hook 'clm/log-command) + +(eval-after-load 'command-log-mode + '(when command-log-mode-key-binding-open-log + (global-set-key + (kbd command-log-mode-key-binding-open-log) + 'clm/toggle-command-log-buffer))) + +(provide 'command-log-mode) + +;;; command-log-mode.el ends here diff --git a/elpa/command-log-mode-readme.txt b/elpa/command-log-mode-readme.txt new file mode 100644 index 00000000..0fc454eb --- /dev/null +++ b/elpa/command-log-mode-readme.txt @@ -0,0 +1,15 @@ +This add-on can be used to demo Emacs to an audience. When +activated, keystrokes get logged into a designated buffer, along +with the command bound to them. + +To enable, use e.g.: + +(require 'command-log-mode) +(add-hook 'LaTeX-mode-hook 'command-log-mode) + +To see the log buffer, call M-x clm/open-command-log-buffer. + +The key strokes in the log are decorated with ISO9601 timestamps on +the property `:time' so if you want to convert the log for +screencasting purposes you could use the time stamp as a key into +the video beginning. diff --git a/elpa/dash-20161116.920/dash-pkg.el b/elpa/dash-20161116.920/dash-pkg.el deleted file mode 100644 index 350fa90f..00000000 --- a/elpa/dash-20161116.920/dash-pkg.el +++ /dev/null @@ -1,2 +0,0 @@ -;;; -*- no-byte-compile: t -*- -(define-package "dash" "20161116.920" "A modern list library for Emacs" 'nil :keywords '("lists")) diff --git a/elpa/dash-20161116.920/dash-autoloads.el b/elpa/dash-20170810.137/dash-autoloads.el similarity index 84% rename from elpa/dash-20161116.920/dash-autoloads.el rename to elpa/dash-20170810.137/dash-autoloads.el index c323bb5d..5606d1f8 100644 --- a/elpa/dash-20161116.920/dash-autoloads.el +++ b/elpa/dash-20170810.137/dash-autoloads.el @@ -3,7 +3,7 @@ ;;; Code: (add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path)))) -;;;### (autoloads nil nil ("dash.el") (22576 8238 0 0)) +;;;### (autoloads nil nil ("dash.el") (22975 34387 0 0)) ;;;*** diff --git a/elpa/dash-20170810.137/dash-pkg.el b/elpa/dash-20170810.137/dash-pkg.el new file mode 100644 index 00000000..a25f7a5b --- /dev/null +++ b/elpa/dash-20170810.137/dash-pkg.el @@ -0,0 +1,2 @@ +;;; -*- no-byte-compile: t -*- +(define-package "dash" "20170810.137" "A modern list library for Emacs" 'nil :commit "0df0ff1a65d54377381e50c08d88b247db44c3dd" :keywords '("lists")) diff --git a/elpa/dash-20161116.920/dash.el b/elpa/dash-20170810.137/dash.el similarity index 96% rename from elpa/dash-20161116.920/dash.el rename to elpa/dash-20170810.137/dash.el index ccff2dd0..02b04b70 100644 --- a/elpa/dash-20161116.920/dash.el +++ b/elpa/dash-20170810.137/dash.el @@ -4,7 +4,7 @@ ;; Author: Magnar Sveen ;; Version: 2.13.0 -;; Package-Version: 20161116.920 +;; Package-Version: 20170810.137 ;; Keywords: lists ;; This program is free software; you can redistribute it and/or modify @@ -98,7 +98,7 @@ the target form." (defun -each-indexed (list fn) "Call (FN index item) for each item in LIST. -In the anaphoric form `--each-indexed', the index is exposed as `it-index`. +In the anaphoric form `--each-indexed', the index is exposed as symbol `it-index'. See also: `-map-indexed'." (--each list (funcall fn it-index it))) @@ -127,7 +127,7 @@ Return nil, used for side-effects only." (put '-each-while 'lisp-indent-function 2) (defmacro --dotimes (num &rest body) - "Repeatedly executes BODY (presumably for side-effects) with `it` bound to integers from 0 through NUM-1." + "Repeatedly executes BODY (presumably for side-effects) with symbol `it' bound to integers from 0 through NUM-1." (declare (debug (form body)) (indent 1)) (let ((n (make-symbol "num"))) @@ -166,7 +166,7 @@ item, etc. If LIST contains no items, return INITIAL-VALUE and FN is not called. In the anaphoric form `--reduce-from', the accumulated value is -exposed as `acc`. +exposed as symbol `acc'. See also: `-reduce', `-reduce-r'" (--reduce-from (funcall fn acc it) initial-value list)) @@ -188,7 +188,7 @@ reduce return the result of calling FN with no arguments. If LIST has only 1 item, it is returned and FN is not called. In the anaphoric form `--reduce', the accumulated value is -exposed as `acc`. +exposed as symbol `acc'. See also: `-reduce-from', `-reduce-r'" (if list @@ -346,7 +346,7 @@ If you want to select the original items satisfying a predicate use `-filter'." (defun -map-indexed (fn list) "Return a new list consisting of the result of (FN index item) for each item in LIST. -In the anaphoric form `--map-indexed', the index is exposed as `it-index`. +In the anaphoric form `--map-indexed', the index is exposed as symbol `it-index'. See also: `-each-indexed'." (--map-indexed (funcall fn it-index it) list)) @@ -389,7 +389,7 @@ See also: `-map-when', `-replace-first'" `(-map-first (lambda (it) ,pred) (lambda (it) (ignore it) ,rep) ,list)) (defun -map-last (pred rep list) - "Replace first item in LIST satisfying PRED with result of REP called on this item. + "Replace last item in LIST satisfying PRED with result of REP called on this item. See also: `-map-when', `-replace-last'" (nreverse (-map-first pred rep (reverse list)))) @@ -579,14 +579,31 @@ Alias: `-any'" \(fn LIST)") -(gv-define-simple-setter -first-item setcar) +;; Ensure that calls to `-first-item' are compiled to a single opcode, +;; just like `car'. +(put '-first-item 'byte-opcode 'byte-car) +(put '-first-item 'byte-compile 'byte-compile-one-arg) + +;; TODO: emacs23 support, when dropped remove the condition +(eval-when-compile + (require 'cl) + (if (fboundp 'gv-define-simple-setter) + (gv-define-simple-setter -first-item setcar) + (require 'cl) + (with-no-warnings + (defsetf -first-item (x) (val) `(setcar ,x ,val))))) (defun -last-item (list) "Return the last item of LIST, or nil on an empty list." (declare (pure t) (side-effect-free t)) (car (last list))) -(gv-define-setter -last-item (val x) `(setcar (last ,x) ,val)) +;; TODO: emacs23 support, when dropped remove the condition +(eval-when-compile + (if (fboundp 'gv-define-setter) + (gv-define-setter -last-item (val x) `(setcar (last ,x) ,val)) + (with-no-warnings + (defsetf -last-item (x) (val) `(setcar (last ,x) ,val))))) (defun -butlast (list) "Return a list of all items in list except for the last." @@ -1016,6 +1033,36 @@ returns the header value, but only after seeing at least one other value (the body)." (--partition-by-header (funcall fn it) list)) +(defun -partition-after-pred (pred list) + "Partition directly after each time PRED is true on an element of LIST." + (when list + (let ((rest (-partition-after-pred pred + (cdr list)))) + (if (funcall pred (car list)) + ;;split after (car list) + (cons (list (car list)) + rest) + + ;;don't split after (car list) + (cons (cons (car list) + (car rest)) + (cdr rest)))))) + +(defun -partition-before-pred (pred list) + "Partition directly before each time PRED is true on an element of LIST." + (nreverse (-map #'reverse + (-partition-after-pred pred (reverse list))))) + +(defun -partition-after-item (item list) + "Partition directly after each time ITEM appears in LIST." + (-partition-after-pred (lambda (ele) (equal ele item)) + list)) + +(defun -partition-before-item (item list) + "Partition directly before each time ITEM appears in LIST." + (-partition-before-pred (lambda (ele) (equal ele item)) + list)) + (defmacro --group-by (form list) "Anaphoric form of `-group-by'." (declare (debug t)) @@ -1067,7 +1114,7 @@ elements of LIST. Keys are compared by `equal'." (defmacro --zip-with (form list1 list2) "Anaphoric form of `-zip-with'. -The elements in list1 is bound as `it`, the elements in list2 as `other`." +The elements in list1 are bound as symbol `it', the elements in list2 as symbol `other'." (declare (debug (form form form))) (let ((r (make-symbol "result")) (l1 (make-symbol "list1")) @@ -1089,8 +1136,8 @@ function is applied pairwise taking as first argument element of LIST1 and as second argument element of LIST2 at corresponding position. -The anaphoric form `--zip-with' binds the elements from LIST1 as `it`, -and the elements from LIST2 as `other`." +The anaphoric form `--zip-with' binds the elements from LIST1 as symbol `it', +and the elements from LIST2 as symbol `other'." (--zip-with (funcall fn it other) list1 list2)) (defun -zip (&rest lists) @@ -1338,17 +1385,29 @@ last item in second form, etc." (list form x))) (:else `(->> (->> ,x ,form) ,@more)))) -(defmacro --> (x form &rest more) - "Thread the expr through the forms. Insert X at the position -signified by the token `it' in the first form. If there are more -forms, insert the first form at the position signified by `it' in -in second form, etc." - (declare (debug ->)) - (if (null more) - (if (listp form) - (--map-when (eq it 'it) x form) - (list form x)) - `(--> (--> ,x ,form) ,@more))) +(defmacro --> (x &rest forms) + "Starting with the value of X, thread each expression through FORMS. + +Insert X at the position signified by the symbol `it' in the first +form. If there are more forms, insert the first form at the position +signified by `it' in in second form, etc." + (declare (debug (form body))) + `(-as-> ,x it ,@forms)) + +(defmacro -as-> (value variable &rest forms) + "Starting with VALUE, thread VARIABLE through FORMS. + +In the first form, bind VARIABLE to VALUE. In the second form, bind +VARIABLE to the result of the first form, and so forth." + (declare (debug (form symbolp body))) + (if (null forms) + `,value + `(let ((,variable ,value)) + (-as-> ,(if (symbolp (car forms)) + (list (car forms) variable) + (car forms)) + ,variable + ,@(cdr forms))))) (defmacro -some-> (x &optional form &rest more) "When expr is non-nil, thread it through the first form (via `->'), @@ -1869,15 +1928,17 @@ encountered." (defmacro -if-let (var-val then &rest else) "If VAL evaluates to non-nil, bind it to VAR and do THEN, -otherwise do ELSE. VAR-VAL should be a (VAR VAL) pair. +otherwise do ELSE. + +Note: binding is done according to `-let'. -Note: binding is done according to `-let'." +\(fn (VAR VAL) THEN &rest ELSE)" (declare (debug ((sexp form) form body)) (indent 2)) `(-if-let* (,var-val) ,then ,@else)) (defmacro --if-let (val then &rest else) - "If VAL evaluates to non-nil, bind it to `it' and do THEN, + "If VAL evaluates to non-nil, bind it to symbol `it' and do THEN, otherwise do ELSE." (declare (debug (form form body)) (indent 2)) @@ -1897,16 +1958,17 @@ encountered." (defmacro -when-let (var-val &rest body) "If VAL evaluates to non-nil, bind it to VAR and execute body. -VAR-VAL should be a (VAR VAL) pair. -Note: binding is done according to `-let'." +Note: binding is done according to `-let'. + +\(fn (VAR VAL) &rest BODY)" (declare (debug ((sexp form) body)) (indent 1)) `(-if-let ,var-val (progn ,@body))) (defmacro --when-let (val &rest body) - "If VAL evaluates to non-nil, bind it to `it' and execute -body." + "If VAL evaluates to non-nil, bind it to symbol `it' and +execute body." (declare (debug (form body)) (indent 1)) `(--if-let ,val (progn ,@body))) @@ -2342,7 +2404,7 @@ structure such as plist or alist." (defun dash-enable-font-lock () "Add syntax highlighting to dash functions, macros and magic values." - (eval-after-load "lisp-mode" + (eval-after-load 'lisp-mode '(progn (let ((new-keywords '( "-each" diff --git a/elpa/gnuplot-20141231.1337/gnuplot-autoloads.el b/elpa/gnuplot-20141231.1337/gnuplot-autoloads.el new file mode 100644 index 00000000..fc4666dc --- /dev/null +++ b/elpa/gnuplot-20141231.1337/gnuplot-autoloads.el @@ -0,0 +1,95 @@ +;;; gnuplot-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path)))) + +;;;### (autoloads nil "gnuplot" "gnuplot.el" (22842 31129 0 0)) +;;; Generated autoloads from gnuplot.el + +(autoload 'gnuplot-mode "gnuplot" "\ +Major mode for editing and executing GNUPLOT scripts. +This was written with version 4.6 of gnuplot in mind, but should +work with newer and older versions. + +Report bugs in `gnuplot-mode' using \\[gnuplot-bug-report]. + + ------O------ + +Gnuplot-mode includes two different systems for keyword +completion and documentation lookup: a newer one, +`gnuplot-context-sensitive-mode' (enabled by default), and a +older one which extracts keywords from gnuplot's Info file. Both +systems allow looking up documentation in the Info file. The +older system also depends having the info file properly installed +to make a list of keywords. + +The info file should be installed by default with the Gnuplot +distribution, or is available at the `gnuplot-mode' web page: +http://github.com/bruceravel/gnuplot-mode/ + +With the new context-sensitive mode active, gnuplot-mode can also +provide `eldoc-mode' syntax hints as you type. This requires a +separate file of strings, `gnuplot-eldoc.el', which is also +provided by recent Gnuplot distributions. + + ------O------ + +There are several known shortcomings of `gnuplot-mode', version 0.5g +and up. Many of the shortcomings involve the graphical interface +\(refered to as the GUI) to setting arguments to plot options. Here is +a list: + + 1. Currently there is no way for `gnuplot-mode' to know if information + sent to gnuplot was correctly plotted. + 2. \"plot\", \"splot\", and \"fit\" are handled in the GUI, but are + a bit flaky. Their arguments may not be read correctly from + existing text, and continuation lines (common for plot and splot) + are not supported. + 3. The GUI does not know how to read from continuation lines. + 4. Comma separated position arguments to plot options are + unsupported in the GUI. Colon separated datafile modifiers (used + for plot, splot, and fit) are not supported either. Arguments + not yet supported by the GUI generate messages printed in grey + text. + 5. The GUI handling of \"hidden3d\" is flaky and \"cntrparam\" is + unsupported. + + ------O------ + + Key bindings: + \\{gnuplot-mode-map} + +\(fn)" t nil) + +(autoload 'gnuplot-make-buffer "gnuplot" "\ +Open a new buffer in `gnuplot-mode'. +When invoked, it switches to a new, empty buffer visiting no file +and then starts `gnuplot-mode'. + +It is convenient to bind this function to a global key sequence. For +example, to make the F10 key open a gnuplot script buffer, put the +following in your .emacs file: + (autoload 'gnuplot-make-buffer \"gnuplot\" + \"open a buffer in gnuplot mode\" t) + (global-set-key [(f10)] 'gnuplot-make-buffer) + +\(fn)" t nil) + +(autoload 'run-gnuplot "gnuplot" "\ +Run an inferior Gnuplot process. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil nil ("gnuplot-context.el" "gnuplot-gui.el" +;;;;;; "gnuplot-pkg.el") (22842 31129 0 0)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; gnuplot-autoloads.el ends here diff --git a/elpa/gnuplot-20141231.1337/gnuplot-context.el b/elpa/gnuplot-20141231.1337/gnuplot-context.el new file mode 100644 index 00000000..7b777843 --- /dev/null +++ b/elpa/gnuplot-20141231.1337/gnuplot-context.el @@ -0,0 +1,2225 @@ +;;; gnuplot-context.el -- context-sensitive help and completion for gnuplot + +;; Copyright (C) 2012-2013 Jon Oddie + +;; Author: Jon Oddie +;; Maintainer: Jon Oddie +;; Created: Wednesday, 08 February 2012 +;; Updated: Friday, 07 February 2013 +;; Version: 0.7.0 +;; Keywords: gnuplot, plotting + +;; 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 2, or (at your option) +;; any later version. +;; +;; This lisp script is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +;; +;; Permission is granted to distribute copies of this lisp script +;; provided the copyright notice and this permission are preserved in +;; all copies. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, you can either send email to this +;; program's maintainer or write to: The Free Software Foundation, +;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; send bug reports to the author (jonxfield@gmail.com) or report via +;; github (https://github.com/bruceravel/gnuplot-mode) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Commentary: + +;; +;; This file enhances gnuplot-mode with context-sensitive completion, +;; ElDoc support, and info page lookup for gnuplot script and shell +;; buffers. +;; +;; Usage +;; ===== +;; +;; Make sure to byte-compile this file, or things will be noticeably +;; slow. +;; +;; Summary of key bindings: +;; C-c C-d read info page for construction at point +;; C-u C-c C-d prompt for info page to read +;; C-c M-h, C-c C-/ pop up multi-line ElDoc string for construction +;; at point +;; +;; Gnuplot's context sensitive mode is best controlled using Customize +;; (M-x customize-group gnuplot): simply enable the +;; `gnuplot-context-sensitive-mode' setting. On recent Emacs (>= 23), +;; you may also want to turn on `gnuplot-tab-completion' so that the +;; TAB key does auto-completion on lines which are already +;; indented. (This just sets the Emacs variable `tab-always-indent' to +;; `complete' in Gnuplot buffers). +;; +;; If you need to turn context sensitivity on or off from Lisp code +;; for some reason, call the function +;; `gnuplot-context-sensitive-mode', which behaves like a minor mode. +;; +;; With `eldoc-mode' support, gnuplot-mode will show one-line syntax +;; hints automatically in the echo area. Whether eldoc-mode is active +;; or not, you can always pop up a longer description of syntax using +;; `gnuplot-help-function' (C-c C-/ or C-c M-h). ElDoc support also +;; requires an additional file of help strings, `gnuplot-eldoc.el', +;; which should be included in recent Gnuplot releases. If it didn't +;; come with your Gnuplot installation, you'll need to grab a recent +;; source distribution of Gnuplot from http://gnuplot.info, and use +;; the `doc2texi.el' program in the docs/ directory to create it. So +;; long as the file is on your Emacs load path somewhere it will be +;; loaded automatically when needed. +;; +;; You can customize gnuplot-mode to turn on eldoc mode automatically +;; using variable `gnuplot-eldoc-mode'. Simply calling `eldoc-mode' +;; will also work. +;; +;; Internal details +;; ================ +;; +;; Gnuplot's command language has a fair amount of syntactic +;; complexity, and the only way I could think of to support these +;; features was to do a complete parse of the command line. So that's +;; what this package does. Instead of building a parse tree, it +;; matches up until the token at point, and then either makes a list +;; of possible completions, or sets the variables `gnuplot-eldoc' and +;; `gnuplot-info-at-point' based on where it is in the grammar at that +;; point. +;; +;; The parsing/matching process happens in two phases: tokenizing +;; (`gnuplot-tokenize') and matching (`gnuplot-match-pattern'). In +;; order to be able to construct a full list of possible completions +;; via backtracking, the matching algorithm simulates a simple stack +;; machine with continuations. At byte-compile time, the PEG-like +;; grammar in S-expression notation (`gnuplot-grammar') is compiled +;; down into a vector of "machine code" for the parsing machine (see +;; `gnuplot-compile-pattern', `gnuplot-compile-grammar' and +;; `gnuplot-compiled-grammar'). This is complicated, but it seems to +;; work well enough, and it saves on the Emacs call stack. +;; +;; Compiling the grammar does require increasing `max-lisp-eval-depth' +;; modestly. This shouldn't cause any problems on modern machines, and +;; it only needs to be done once, at byte-compilation time. +;; +;; The parsing machine and compiler are partially based on the +;; description in Medeiros and Ierusalimschy 2008, "A Parsing Machine +;; for PEGs" (http://dl.acm.org/citation.cfm?doid=1408681.1408683). +;; +;; The pattern-matching language +;; ============================= +;; +;; The gnuplot-mode grammar (see `gnuplot-compiled-grammar') is a list +;; of rules (RULE PATTERN), with each pattern written in S-expression +;; notation as follows: +;; +;; any +;; Match any token +;; +;; name, number, string, separator +;; Match a token of the given type. "Separator" is semicolon, the +;; statement separator. +;; +;; Any other symbol +;; Match another named rule in the grammar. May be recursive. +;; +;; "STRING" +;; Match literally: a token with exactly the text "STRING". +;; +;; (kw KEYWORD ALIASES ...) +;; Match abbreviated Gnuplot keywords. KEYWORD can be a string or +;; a cons (PREFIX . SUFFIX). In the latter case, this pattern +;; will match PREFIX plus any number of characters from the +;; beginning of SUFFIX. Any literal string from ALIASES will +;; also match. The token-id of the matching token is mutated to +;; the canonical value of KEYWORD. +;; Example: +;; (kw ("linew" ."idth") "lw") matches "linew", "linewi", +;; ... "linewidth" as well as "lw". Any of these tokens will +;; appear as "linewidth" in subsequent processing. (This is +;; important for the "info-keyword" form, see below). +;; +;; The other pattern forms combine simpler patterns, much like regular +;; expressions or PEGs (parsing expression grammars): +;; +;; (sequence { (:eldoc "eldoc string") } +;; { (:info "info page") } +;; { (:no-info) } +;; PATTERN PATTERN... ) +;; Match all the PATTERNs in sequence or fail. Sequences can also +;; have optional ElDoc strings and info pages associated with +;; them; the innermost ElDoc or info page around point is the one +;; shown to the user. Alternatively, either property may be a +;; symbol, which should be a function to be called to get the +;; real value. Finally, if no ElDoc string is specified but the +;; variable `gnuplot-eldoc-hash' contains a value for the name of +;; the info page at point, that value is used as the ElDoc string +;; instead. +;; +;; For better readability, sequence forms can also be written as +;; a vector, omitting the `sequence': [PATTERN PATTERN ...] +;; +;; (either PATTERN PATTERN...) +;; Match the first PATTERN to succeed, or fail if none +;; matches. Like regexp `|'. +;; +;; (many PATTERN) +;; Match PATTERN zero or more times, greedily; like regexp +;; `*'. Unlike a regular expression matcher, the parsing machine +;; will not backtrack and try to match fewer times if a later +;; part of the pattern fails. This applies equally to the other +;; non-deterministic forms "either" and "maybe". +;; +;; (maybe PATTERN) +;; Match PATTERN zero or one times, like regexp `?'. +;; +;; (capture NAME PATTERN) +;; Match PATTERN, capturing the tokens in a capture group named +;; NAME. Capture groups are stored in `gnuplot-captures' +;; and can be retrieved using `gnuplot-capture-group'. This is +;; used to store the plotting style, which we need in order to +;; give the correct ElDoc string for "using" clauses, and for +;; info keywords (see below) +;; +;; (info-keyword PATTERN) +;; Match PATTERN, and use whatever the value of the first token +;; it matches is to look up info pages for this pattern. Most +;; Gnuplot info pages have the same name as the keyword they +;; document, so by using this we only have to put :info +;; properties on the few that don't, such as "set". +;; +;; For convenience, "many", "maybe", "capture" and "info-keyword" +;; wrap the rest of their arguments in an implicit "sequence" form, +;; so we can write (maybe "," expression) instead of +;; (maybe (sequence "," expression)) +;; +;; (delimited-list PATTERN SEPARATOR) +;; Match a list of PATTERNs separated by SEPARATOR. Sugar for: +;; (sequence PATTERN (many (sequence SEPARATOR PATTERN))) +;; +;; (assert LISP-FORM) +;; Evaluate LISP-FORM and fail if it returns NIL. We need this in +;; the patterns for "plot" and "splot" to check whether the +;; command at point should be parsed in parametric mode or +;; not. See `gnuplot-guess-parametric-p'. +;; +;; +;; Bugs, TODOs, etc. +;; ======================= +;; +;; It would be useful to complete on user-defined functions and +;; variables as well as built-ins. +;; +;; Completion probably will not work in continuation lines entered +;; into the gnuplot interaction buffer. +;; +;; It would be better to pop up longer syntax descriptions in a +;; temporary window, rather than making the echo area grow to fit +;; many lines. +;; +;; In ElDoc mode, we parse the whole line every time the user stops +;; typing. This is wasteful; should cache things in text properties +;; instead. +;; +;; The pattern matching engine uses backtracking, which can take +;; exponential time. So far it seems "fast enough" in actual use. +;; +;; The patterns don't really distinguish between "plot" and "splot" +;; for things like plot styles, binary arguments, etc. +;; +;; Some other the patterns are probably not quite right, especially for +;; things like abbreviated keywords, and features that I don't use +;; myself like "fit". Hopefully anyone bothered by this will submit +;; patches ;-) +;; +;; It would be possible to provide more helpful ElDoc strings for +;; sub-parts of complicated options like "cntrparam". This is a time +;; and maintenance issue rather than a technical one. + +;;; Code: + + +;; Library dependencies +(eval-when-compile + (require 'cl) + + ;; Prevent compiler warnings about undefined functions + (require 'gnuplot)) + +;; We need ElDoc support +(require 'eldoc) + +;; Compatibility for Emacs version < 23 +(eval-when-compile + (when (not (fboundp 'string-match-p)) + (defmacro string-match-p (&rest args) + `(save-match-data (string-match ,@args))))) + + +;;;; The tokenizer. + +(defstruct gnuplot-token + start ; Buffer start position + end ; Buffer end position + id ; Text + type) ; a symbol: name, number, string, operator, separator + +(defvar gnuplot-operator-regexp + (eval-when-compile + (regexp-opt + '("(" ")" "(" ")" "{" "," "}" "[" ":" "]" "!" "**" "-" "+" "~" "!" "*" "/" + "%" "+" "-" "." "<" "<=" ">" ">=" "==" "!=" "eq" "ne" "&" "^" "|" "&&" "||" + "?" ":" "=" "$"))) + "Regexp to match Gnuplot operators for tokenizing.") + +(eval-when-compile + (defmacro gnuplot-tokenize-by-regexps (&rest rules) + `(cond ,@(mapcar + (lambda (rule) + (let ((regexp (car rule)) + (token-type (cadr rule))) + `((looking-at ,regexp) + (let ((str (match-string-no-properties 0))) + (forward-char (length str)) + (make-gnuplot-token :id str + :type ',token-type + :start (match-beginning 0) + :end (match-end 0)))))) + rules)))) + +(defun gnuplot-tokenize (&optional completing-p) + "Tokenize the Gnuplot command at point. Returns a list of `gnuplot-token' objects. + +If COMPLETING-P is non-nil, omits the token at point if it is a +name; otherwise continues tokenizing up to the token at point. FIXME" + (let ((tokens '()) + (stop-point (min (point) + (gnuplot-point-at-end-of-command)))) + (save-excursion + (if (save-excursion ; HACK FIXME + (gnuplot-beginning-of-continuation) + (looking-at "\\s-*if\\s-*(")) + (gnuplot-beginning-of-continuation) + (gnuplot-beginning-of-command)) + (while + ;; Skip whitespace and continuation lines + (progn + (skip-syntax-forward "-" stop-point) + (while (looking-at "\\\\\n") + (forward-line) + (skip-syntax-forward "-" stop-point)) + ;; Don't tokenize anything starting after point + (and (not (looking-at "#")) + (< (point) stop-point))) + (let* ((from (point)) + (token + (cond + ((gnuplot-tokenize-by-regexps + ("[A-Za-z_][A-Za-z0-9_]*" name) + ("[0-9]+\\(\\.[0-9]*\\)?\\([eE][+-]?[0-9]+\\)?\\|\\.[0-9]+\\([eE][+-]?[0-9]+\\)?" number) + (gnuplot-operator-regexp operator) + (";" separator))) + + ((looking-at "['\"]") + (let* ((bounds (bounds-of-thing-at-point 'sexp)) + (to (or (cdr bounds) stop-point))) + (goto-char to) + (make-gnuplot-token + :id (buffer-substring-no-properties from to) + :type 'string + :start from :end to))) + + (t (error + "gnuplot-tokenize: bad token beginning %s" + (buffer-substring-no-properties (point) stop-point)))))) + + (push token tokens)))) + + ;; If we are looking for completions, AND if the last token + ;; read is a name, AND if point is within the bounds of the + ;; last token, then discard it. The matching function + ;; generates a list of all possible tokens that could appear + ;; in that position for completion. + (if (and completing-p + tokens + (eq (gnuplot-token-type (car tokens)) 'name) + (<= (point) (gnuplot-token-end (car tokens)))) + (pop tokens)) + + (nreverse tokens))) + + + +;;;; The pattern and grammar compiler +;; +;; These functions compile the source S-expression grammar into a +;; vector of instructions for the parsing machine, +;; `gnuplot-match-pattern'. Its state consists of a program counter +;; (PC), a position in the list of tokens, a call stack, and a second +;; stack of backtracking entries (continuations). Its "machine +;; instructions" are the following: +;; +;; (any) +;; Match any token (fails only at end of command). +;; +;; (literal LITERAL NO-COMPLETE) +;; Match token with `gnuplot-token-id' LITERAL or fail. If we +;; have reached the token before point, include LITERAL in the +;; completion list unless NO-COMPLETE is non-`nil'. +;; +;; (token-type TYPE) +;; Match a token with `gnuplot-token-type' TYPE, or fail. +;; +;; (keyword REGEXP NAME) +;; Match any token whose `gnuplot-token-id' matches REGEXP. Use +;; NAME for the completion list. +;; +;; (jump OFFSET FIXED) +;; Jump to (set PC to) OFFSET if FIXED is non-nil, otherwise to +;; PC + OFFSET +;; +;; (call OFFSET FIXED) +;; Like "jump", but push a return address onto the stack for +;; (return). (The compiler adds the name of the rule being called +;; as a fourth element on the end of the list, but this is just a +;; comment for debugging purposes). +;; +;; (return) +;; Return to the PC address on top of the stack, or finish +;; matching if stack is empty. (Usually this doesn't happen, +;; because the machine stops as soon as it gets to the token at +;; point). +;; +;; (choice OFFSET) +;; Push a backtracking entry for location PC + OFFSET onto the +;; backtracking stack. Backtracking entries save the contents of +;; the call stack, position in the token list, the values of +;; capture groups, and the record of loop progress (see below). +;; +;; (check-progress) +;; Break out of infinite loops, like (many (many ...)). Checks +;; an alist of conses (pc . tokens) for the position in the token +;; stream the last time this instruction was reached, and breaks +;; out of the loop if stuck in the same place; otherwise pushes a +;; new entry onto the list. +;; +;; (fail) +;; Pop the most recent backtracking entry and continue from +;; there, or fail the whole match if out of backtrack +;; points. Failing to match returns the remainder of the token +;; list, although we don't currently use this for anything. +;; +;; (commit OFFSET) +;; Discard one backtracking point and jump to PC + OFFSET. This +;; is used to make the (either) form non-deterministic. +;; +;; (push TYPE VALUE) +;; Push an entry for an eldoc or info string (specified by TYPE) +;; onto the stack. +;; +;; (pop TYPE) +;; Pop something off the stack; checks that it has the expected +;; TYPE, for safety. +;; +;; (save-start NAME) +;; Open a capture group named NAME. Pushes an entry onto +;; `gnuplot-captures' with current position in token list as the +;; start of the group. +;; +;; (save-end NAME) +;; Close the capture group named NAME. Finds the topmost entry in +;; `gnuplot-captures' with this name and sets its endpoint to the +;; current position in token list. Error if no group with that +;; name is found. +;; +;; (label NAME) +;; This should never be reached and will cause an error. The +;; compiler inserts it at the beginning of compiled rules only +;; for debugging purposes. +;; + + +(eval-and-compile + ;; Compile a single pattern into a list of instructions. Leaves + ;; calls to other rules as symbolic instructions (call SYMBOL) and + ;; jumps, commits etc. as relative offsets; these are resolved into + ;; absolute locations by `gnuplot-compile-grammar', below. + (defun gnuplot-compile-pattern (pat) + (cond + ;; Strings match a single token literally + ((stringp pat) + ;; Don't add non-words to completion lists + (let ((wordp (string-match-p "^\\sw\\(\\sw\\|\\s_\\)*$" pat))) + `((literal ,pat ,(not wordp))))) + + ;; Symbols match token types or calls to other patterns + ((symbolp pat) + (case pat + ((any) `((any))) + ((name number string separator) `((token-type ,pat))) + (t `((call ,pat))))) + + ;; Syntactic sugar: write sequences (sequence ...) as vectors [...] + ((vectorp pat) + (gnuplot-compile-pattern + (append '(sequence) pat '()))) + + ;; Other forms combine simpler patterns + (t + (let ((type (car pat))) + (case type + ;; (sequence...): concatenate patterns, with optional eldoc + ;; and info strings + ((sequence) + (destructuring-bind + (subpats eldoc info) + (gnuplot-filter-arg-list (cdr pat)) + (let ((eldoc-push '()) (eldoc-pop '()) + (info-push '()) (info-pop '()) + (compiled + (mapcar 'gnuplot-compile-pattern subpats))) + (if eldoc + (setq eldoc-push `((push eldoc ,eldoc)) + eldoc-pop `((pop eldoc)))) + (if info + (if (eq info :no-info) + (setq info-push '((push no-scan t)) + info-pop '((pop no-scan))) + (setq info-push `((push info ,info)) + info-pop `((pop info))))) + (apply 'append + `(,info-push + ,eldoc-push + ,@compiled + ,eldoc-pop + ,info-pop))))) + + ;; (either...): choose between patterns + ((either) + (cond + ((= (length pat) 2) ; trivial case + (gnuplot-compile-pattern (cadr pat))) + + ((> (length pat) 3) ; could be more efficient... + (gnuplot-compile-pattern (gnuplot-either-helper pat))) + + (t ; two patterns + (let* ((pat1 (cadr pat)) + (pat2 (caddr pat)) + (pat1-c (gnuplot-compile-pattern pat1)) + (pat2-c (gnuplot-compile-pattern pat2)) + (pat1-l (length pat1-c)) + (pat2-l (length pat2-c))) + `((choice ,(+ pat1-l 2)) + ,@pat1-c + (commit ,(+ pat2-l 1)) + ,@pat2-c))))) + + ;; Repetition (*) + ((many) + (let* ((pat1 (cons 'sequence (cdr pat))) + (pat1-c (gnuplot-compile-pattern pat1)) + (pat1-l (length pat1-c))) + `((choice ,(+ pat1-l 3)) + (check-progress) ; bail out of infinite loops + ,@pat1-c + (commit ,(- (+ pat1-l 2)))))) + + ;; Repetition (+) + ((many1) + (let* ((pat1 (cdr pat))) + (gnuplot-compile-pattern + `(sequence ,@pat1 (many ,@pat1))))) + + + ;; Optional (?) + ((maybe) + (let* ((pat1 (cons 'sequence (cdr pat))) + (pat1-c (gnuplot-compile-pattern pat1)) + (pat1-l (length pat1-c))) + `((choice ,(+ pat1-l 1)) + ,@pat1-c))) + + ;; Syntactic sugar for delimited lists + ((delimited-list) + (let* ((item (cadr pat)) + (sep (caddr pat))) + (gnuplot-compile-pattern + `(sequence ,item (many (sequence ,sep ,item)))))) + + ;; keywords + ((kw) + (destructuring-bind (regex name) + (gnuplot-keyword-helper (cdr pat)) + `((keyword ,regex ,name)))) + + ;; Capturing groups + ((capture) + (let* ((name (cadr pat)) + (pat1 (cons 'sequence (cddr pat))) + (pat1-c (gnuplot-compile-pattern pat1))) + `((save-start ,name) + ,@pat1-c + (save-end ,name)))) + + ;; Use the first token as an info keyword + ((info-keyword) + (let* ((pat1 (cons 'sequence (cdr pat))) + (pat1-c (gnuplot-compile-pattern pat1))) + `((push info first-token) + ,@pat1-c + (pop info)))) + + ;; Assertions + ((assert) + (let* ((form (cadr pat))) + `((assert ,form)))) + + (t + (error "gnuplot-compile-pattern: bad pattern form %s" pat))))))) + + ;; Helper function for destructuring (sequence ...) forms in patterns + ;; Takes the cdr of the sequence form, returns a list (PATTERNS ELDOC + ;; INFO). + (defun gnuplot-filter-arg-list (args) + (let ((accum '()) + (eldoc nil) (info nil)) + (dolist (item args) + (let ((type (car-safe item))) + (case type + ((:eldoc) (setq eldoc (cadr item))) + ((:no-info) (setq info :no-info)) ; inhibit stack scanning + ((:info) (setq info (cadr item))) + (t (push item accum))))) + (list (reverse accum) eldoc info))) + + ;; Helper function for compiling (kw...) patterns + ;; Takes the cdr of the kw form, returns a list (REGEXP KEYWORD) + (defun gnuplot-keyword-helper (args) + (let ((keyword (car args)) (aliases (cdr args))) + (when (consp keyword) + (let ((pre (car keyword)) (suf (cdr keyword))) + (setq keyword (concat pre suf)) + (while (progn + (push pre aliases) + (not (zerop (length suf)))) + (setq pre (concat pre (substring suf 0 1)) + suf (substring suf 1))))) + (let ((regex + (concat "^" + (regexp-opt (cons keyword aliases)) + "$"))) + (list regex keyword)))) + + ;; Helper function for compiling (either ...) patterns. Rewrites + ;; alternates (either A B C) into (either A (either B (either C D))) + (defun gnuplot-either-helper (pat) + (if (= (length pat) 3) + pat + `(either ,(cadr pat) + ,(gnuplot-either-helper + (cons 'either (cddr pat)))))) + + ;; Compile the grammar (a list of rule-pattern pairs (RULE PATTERN)) + ;; into a single vector of matching-machine instructions. Compiles + ;; each pattern individually, then "links" them into one vector, + ;; converting symbolic (call ...) instructions into numeric offsets + (defun gnuplot-compile-grammar (grammar start-symbol) + (let ((compiled-pats '()) ; Alist of (name . instructions) + ;; Reserve space for a jump to the start symbol + (code-length 1)) + + ;; Compile each rule and find the total number of instructions + (dolist (item grammar) + (let* ((name (car item)) + (pat (cadr item)) + (code (gnuplot-compile-pattern pat))) + (push (cons name code) compiled-pats) + ;; Reserve space for a label at the beginning and (return) at + ;; the end + (setq code-length (+ code-length 2 (length code))))) + + ;; Copy instructions into a single vector + (let ((object-code (make-vector code-length nil)) + (name->offset (make-hash-table)) + (i 1)) + (setf (aref object-code 0) `(jump ,start-symbol)) + (dolist (chunk compiled-pats) + (let ((name (car chunk)) + (code (cdr chunk))) + (setf (aref object-code i) `(label ,name)) + (incf i) + (puthash name i name->offset) + (while code + (setf (aref object-code i) (car code) + code (cdr code) + i (1+ i))) + (setf (aref object-code i) '(return) + i (1+ i)))) + + ;; Resolve symbolic and relative jumps + (let ((pattern-name nil)) + (dotimes (i (length object-code)) + (let ((inst (aref object-code i))) + (case (car inst) + ((label) + (setq pattern-name (cadr inst))) + + ((jump call choice commit) + (cond + ((symbolp (cadr inst)) + (let* ((name (cadr inst)) + (location (gethash name name->offset))) + (if (not location) + (error + (concat "gnuplot-compile-grammar: " + "No rule found for symbol `%s' in pattern `%s'") + name pattern-name)) + (setcdr inst `(,location ,name)))) + + ((numberp (cadr inst)) + (let* ((offset (cadr inst)) + (location (+ offset i))) + (setcdr inst `(,location)))) + + (t + (error "gnuplot-compile-grammar: bad instruction %s" inst)))))))) + object-code)))) + +;;; The grammar. +(defvar gnuplot-compiled-grammar + (eval-when-compile + (let ((max-lisp-eval-depth 600)) + (gnuplot-compile-grammar + '((expression + [infix-expression (maybe "?" expression ":" expression)]) + + (prefix-operator + (either "!" "~" "-" "+")) + + (infix-operator + (either "**" "*" "/" "%" "+" "-" "." "<" "<=" ">" ">=" "==" "!=" "eq" "ne" + "&" "^" "|" "&&" "||")) + + (infix-expression + [(many prefix-operator) + primary-expression + (many infix-operator expression)]) + + (primary-expression + [(either number string parenthesized-expression + column-ref complex-number function-call name) + (many "!") + (maybe "**" infix-expression) + (maybe substring-range)]) + + (function-call + (either + (info-keyword + [(either "abs" "acos" "acosh" "arg" "asin" "asinh" "atan" "atan2" "atanh" + "besj0" "besj1" "besy0" "besy1" "ceil" "column" "columnhead" + "cos" "cosh" "defined" "erf" "erfc" "exists" "exp" "floor" + "gamma" "gprintf" "ibeta" "igamma" "imag" "int" "inverf" + "invnorm" "lambertw" "lgamma" "log" "log10" "norm" "real" + "sgn" "sin" "sinh" "sprintf" "sqrt" "strftime" "stringcolumn" + "strlen" "strptime" "strstrt" "substr" "tan" "tanh" "timecolumn" + "tm_hour" "tm_mday" "tm_min" "tm_mon" "tm_sec" "tm_wday" + "tm_yday" "tm_year" "valid" "value" "word" "words" "rand") + parenthesized-expression]) + [(:info "elliptic_integrals") + (either "EllipticK" "EllipticE" "EllipticPi") + parenthesized-expression] + [name + parenthesized-expression])) + + (parenthesized-expression + ["(" comma-list ")"]) + + (complex-number + ["{" (maybe "-") number "," (maybe "-") number "}"]) + + (column-ref + ["$" number]) + + (substring-range-component + (maybe (either "*" expression))) + + (substring-range + ["[" (delimited-list substring-range-component ":" 2 2) "]"]) + +;;; Assignments + (lhs + [name (maybe "(" (delimited-list name "," 1) ")")]) + + (assignment + [lhs "=" (either assignment expression)]) + +;;; Lists of expressions + (comma-list + (delimited-list (either assignment expression) ",")) + + (colon-list + (delimited-list expression ":")) + + (tuple + ["(" (delimited-list expression "," 2 3) ")"]) + +;;; Commands + (command + (info-keyword + (either plot-command splot-command replot-command fit-command print-command + set-command cd-command call-command simple-command + eval-command load-command lower-raise-command pause-command + save-command system-command test-command undefine-command + update-command assignment if-command new-if-command do-command))) + + (command-list + (delimited-list command separator)) + + (block ["{" command-list (maybe separator) "}"]) + +;;; old-style one-line if(..) command + (if-command + (info-keyword + "if" parenthesized-expression command-list + (maybe separator "else" command-list))) + +;;; new-style block-structured if + (new-if-command + (info-keyword + "if" parenthesized-expression block + (maybe "else" block))) + +;;; block-structured "do" + (do-command + (info-keyword "do" iteration-spec block)) + +;;; PLOT, SPLOT commands + (plot-command + [(kw ("pl" . "ot")) + + (either + ;; Parametric ranges + [(assert (gnuplot-guess-parametric-p)) + (maybe t-axis-range) (maybe x-axis-range) (maybe y-axis-range)] + + ;; Non-parametric ranges + [(maybe x-axis-range) (maybe y-axis-range)]) + + plot-body]) + + (splot-command + [ ;; This capturing group lets `gnuplot-find-using-eldoc' know + ;; that this is an splot command + (capture :splot-command (kw ("spl" . "ot"))) + + (either + ;; Parametric ranges + [(assert (gnuplot-guess-parametric-p)) + (maybe u-axis-range) (maybe v-axis-range) + (maybe x-axis-range) (maybe y-axis-range) (maybe z-axis-range)] + + ;; Non-parametric ranges + [(maybe x-axis-range) (maybe y-axis-range) (maybe z-axis-range)]) + + plot-body]) + + (replot-command [(kw "replot") plot-body]) + + ;; Axis ranges + (axis-range-component + (maybe (either "*" expression))) + + (axis-range-body + (delimited-list axis-range-component ":" 2 3)) + + (axis-range + [(:info "ranges") + "[" (maybe (maybe name "=") axis-range-body) "]"]) + + (x-axis-range [(:eldoc "X RANGE: [{=}:]") axis-range]) + (y-axis-range [(:eldoc "Y RANGE: [{=}:]") axis-range]) + (z-axis-range [(:eldoc "Z RANGE: [{=}:]") axis-range]) + (t-axis-range [(:eldoc "T RANGE: [{=}:]") axis-range]) + (u-axis-range [(:eldoc "U RANGE: [{=}:]") axis-range]) + (v-axis-range [(:eldoc "V RANGE: [{=}:]") axis-range]) + + ;; Body of a plot/splot command. Should really be different for + ;; parametric vs non-parametric, but that's too hard. + (plot-body + (delimited-list + [(maybe iteration-spec) plot-expression plot-modifiers] + ",")) + + ;; Iteration: for [... ] + (iteration-spec + [(:info "iteration") + (many1 + "for" "[" name + (either ["=" (delimited-list expression ":")] + ["in" expression]) + "]")]) + + ;; Expressions to plot can be preceded by any number of + ;; assignments, with or without commas + (plot-expression + [(many [(:no-info) assignment (maybe ",")]) + expression]) + +;;; Plot/splot modifiers + ;; These should probably be more different for plot and splot ... + (plot-modifiers (many (either plot-modifier datafile-modifier))) + + (plot-modifier + (info-keyword + (either + ;; simple one-word modifiers + (kw "nohidden3d") (kw "nocontours") (kw "nosurface") + + ;; word followed by expression + [(either + (kw ("lines" . "tyle") "ls") + (kw ("linet" . "ype") "lt") + (kw ("linew" . "idth") "lw") + (kw ("pointt" . "ype") "pt") + (kw ("points" . "ize") "ps") + (kw ("pointi" . "nterval") "pi")) + expression] + + ;; others defined below + title-modifier notitle-modifier axes-modifier with-modifier + linecolor-modifier fillstyle-modifier))) + + (title-modifier + [(kw ("t" . "itle")) expression]) + + (notitle-modifier + [(:info "title") + (kw ("not" . "itle")) + (maybe string)]) + + (axes-modifier + [(kw ("ax" . "es")) (either "x1y1" "x1y2" "x2y1" "x2y2")]) + + (linecolor-modifier + [(kw ("linec" . "olor") "lc") color-spec]) + + (fillstyle-modifier + [(kw "fillstyle" "fs") + ;; fill-style also used by "set style fill" + fill-style]) + + (fill-style + [(either + "empty" + [(maybe "transparent") + (either "pattern" "solid") + (maybe (either fill-style-border-clause expression))]) + (maybe fill-style-border-clause)]) + + (fill-style-border-clause + (either "noborder" [(kw ("bo" . "rder")) expression])) + + (color-spec + [(:info "colorspec") + (either + (kw ("var" . "iable")) + + [(kw ("pal" . "ette")) + (either "z" + [(either "frac" "cb") expression])] + + [(kw ("rgb" . "color")) + (either (kw ("var" . "iable")) string)])]) + + (with-modifier + [(:info "plotting_styles") + (kw ("w" . "ith")) + + ;; plotting-style also used for "set style data" + (capture :with-style plotting-style)]) + + (plotting-style + (info-keyword + (either + ;; Simple styles that take no arguments + (kw ("l" . "ines")) (kw ("i" . "mpulses")) (kw ("p" . "oints")) + (kw ("linesp" . "oints") "lp") (kw ("d" . "ots")) (kw ("yerrorl" . "ines")) + (kw ("errorl" . "ines")) (kw ("xerrorl" . "ines")) (kw ("xyerrorl" . "ines")) + (kw ("ye" . "rrorbars")) (kw ("e" . "rrorbars")) (kw ("xe" . "rrorbars")) + (kw ("xye" . "rrorbars")) (kw "boxes") (kw ("hist" . "ograms")) + (kw ("boxer" . "rorbars")) (kw ("boxx" . "yerrorbars")) (kw ("st" . "eps")) + (kw ("fs" . "teps")) (kw ("his" . "teps")) (kw ("fin" . "ancebars")) + (kw ("can" . "dlesticks")) (kw ("pm" . "3d")) + (kw ("cir" . "cles")) + + ;; Image styles all use the same info page + [(:info "image") + (either (kw ("ima" . "ge")) + (kw ("rgbima" . "ge")) + (kw ("rgba" . "lpha")))] + + ;; More complicated styles defined below + labels-style-clause + filledcurves-style-clause + vectors-style-clause))) + + (labels-style-clause + [(kw "labels") + (maybe textcolor-spec)]) + + (filledcurves-style-clause + [(kw ("filledc" . "urves")) + (maybe + (either + "closed" + + ["xy" "=" expression "," expression] + + [(maybe (either "above" "below")) + (maybe [(either "x1" "x2" "y1" "y2") + (maybe "=" expression)])]))]) + + (vectors-style-clause + [(kw ("vec" . "tors")) + (many + (either + "nohead" "head" "heads" "filled" "empty" "nofilled" "front" "back" + [(kw "arrowstyle" "as") expression] + ["size" (delimited-list expression ",")] + linestyle-spec))]) + +;;; Various style specifiers, used in different places + (linestyle-spec + (many1 + (either + [(kw ("lines" . "tyle") "ls") expression] + [(kw ("linet" . "ype") "lt") expression] + [(kw ("linew" . "idth") "lw") expression]))) + + (textcolor-spec + [(kw "textcolor" "tc") + (either "default" + ["lt" expression] + color-spec)]) + + (pointsize-spec [(kw "pointsize" "ps") expression]) + +;;; Datafile modifiers + (datafile-modifier + (info-keyword + (either binary-modifier + [(maybe "nonuniform") (kw ("mat" . "rix"))] + index-modifier every-modifier + thru-modifier using-modifier + smooth-modifier + "volatile" "noautoscale"))) + + (index-modifier + [(kw ("i" . "ndex")) + (either string (delimited-list expression ":" 0 2))]) + + (every-modifier + [(kw ("ev" . "ery")) (delimited-list (maybe expression) ":")]) + + (thru-modifier + [(kw "thru") expression]) + + (using-modifier + [(:eldoc gnuplot-find-using-eldoc) + (kw ("u" . "sing")) + (either + string + [colon-list (maybe string)])]) + + (smooth-modifier + [(kw ("s" . "mooth")) + (either (kw ("a" . "csplines")) (kw ("b" . "ezier")) (kw ("c" . "splines")) + (kw ("s" . "bezier")) (kw ("u" . "nique")) (kw ("f" . "requency")) + (kw ("cum" . "ulative")) (kw ("k" . "density")))]) + +;;; Binary datafile modifiers + (binary-modifier + ["binary" (many binary-keyword)]) + + (binary-keyword + (either + ;; All of these binary keywords are described on the same + ;; info page + [(:info "keywords") + (either + "transpose" "flipx" "flipy" "flipz" + ["flip" "=" (either "x" "y" "z")] + ["scan" "=" name] + [(either "dx" "dy" "dz") "=" number] + [(either "origin" "center" "perpendicular") "=" + (delimited-list tuple ":")] + [(kw ("rot" . "ate") "rotation") "=" + (sequence expression (maybe (kw ("d" . "eg")) (kw ("p" . "i"))))])] + + ;; remaining binary keywords have their own info pages + (info-keyword + (either + [(either "array" "record") + "=" + (delimited-list expression ":")] + + [(either "skip") + "=" + (delimited-list expression ":")] + + [(either "format" "endian" "filetype") + "=" + expression])))) + +;;; "fit" command + (fit-command + [(:info "fit") + (kw "fit") + (many axis-range) + expression + string + (many plot-modifier) + (kw "via") + (either string (delimited-list name ","))]) + +;;; print command + (print-command + [(kw ("pr" . "int")) (delimited-list expression ",")]) + +;;; set commands + (set-command + [(:eldoc "set ...") + (:info "set-show") + (either (kw "set") (kw "unset") (kw "show")) + (maybe iteration-spec) + (info-keyword + (either set-angles-clause set-arrow-clause + set-autoscale-clause set-bars-clause + set-border-clause set-boxwidth-clause + set-clabel-clause set-clip-clause + set-cntrparam-clause set-colorbox-clause + set-contour-clause set-datafile-clause + set-decimalsign-clause set-dgrid3d-clause + set-dummy-clause set-encoding-clause + set-fit-clause set-fontpath-clause + set-format-clause set-grid-clause + set-hidden3d-clause set-historysize-clause + set-isosamples-clause set-key-clause + set-label-clause set-loadpath-clause + set-locale-clause set-logscale-clause + set-mapping-clause set-margin-clause + set-multiplot-clause set-mxtics-clause + set-object-clause set-offsets-clause + set-origin-clause set-output-clause + set-parametric-clause set-pm3d-clause + set-palette-clause set-pointsize-clause + set-polar-clause set-print-clause + set-samples-clause set-size-clause + set-style-clause + set-surface-clause set-table-clause + set-terminal-clause set-termoption-clause + set-tics-clause set-tics-clause-2 + set-xtics-clause + set-timestamp-clause set-timefmt-clause + set-title-clause set-view-clause + set-data-clause set-dtics-clause + set-xlabel-clause + set-mtics-clause set-range-clause + set-xyplane-clause set-zero-clause + set-zeroaxis-clause))]) + +;;; positions and coordinate systems for set options + (position-system + (either "first" "second" "graph" "screen" "character")) + + (dimension [(maybe position-system) expression]) + + (position + [dimension "," dimension (maybe "," dimension)]) + + (to (either "to" "rto")) + +;;; all the different "set ... " options + (set-angles-clause + ["angles" (either "degrees" "radians")]) + + (set-arrow-clause + ["arrow" (maybe number) + (many + (either ["from" position] [to position] + [(kw "arrowstyle" "as") expression] + "nohead" "head" "backhead" "heads" + ["size" dimension "," expression (maybe "," expression)] + "filled" "empty" "nofilled" "front" "back" + linecolor-modifier linestyle-spec))]) + + (set-autoscale-clause + ["autoscale" + (either "fix" + "keepfix" + "x" "y" "z" "cb" "x2" "y2" "xy" + "xmin" "ymin" "zmin" "cbmin" "x2min" "y2min" + "xmax" "ymax" "zmax" "cbmax" "x2max" "y2max" + "xfix" "yfix" "zfix" "cbfix" "x2fix" "y2fix" + "xfixmax" "yfixmax" "zfixmax" "cbfixmax" "x2fixmax" "y2fixmax" + "xfixmin" "yfixmin" "zfixmin" "cbfixmin" "x2fixmin" "y2fixmin")]) + + (set-bars-clause + ["bars" + (either expression "small" "large" "fullwidth") + (either "front" "back")]) + + (set-border-clause + ["border" + (maybe number) + (maybe (either "front" "back")) + (maybe (kw "linewidth" "lw") expression) + (maybe + (either (kw "linestyle" "ls") (kw "linetype" "lt")) + expression)]) + + (set-boxwidth-clause + ["boxwidth" + (maybe expression) + (maybe (either (kw ("abs" . "olute")) "relative"))]) + + (set-clabel-clause + ["clabel" (maybe string)]) + + (set-clip-clause + ["clip" (maybe (either "points" "one" "two"))]) + + (set-cntrparam-clause + [(kw "cntrparam") + (either + "linear" "cubicspline" "bspline" + + [(either "points" "order") number] + + [(kw "levels") + (either + number + (sequence (kw "auto") (maybe number)) + (sequence + (kw "discrete") comma-list) + (sequence + (kw "incremental") (delimited-list expression "," 2 3)))])]) + + (set-colorbox-clause + [(:info "color_box") + (kw ("colorb" . "ox")) + (many + (either + (kw ("vert" . "ical")) (kw ("horiz" . "ontal")) + "default" "user" + ["origin" expression "," expression] + ["size" expression "," expression] + "front" "back" + "noborder" "bdefault" + ["border" expression]))]) + + (set-contour-clause + ["contour" (either "base" "surface" "both")]) + + (set-datafile-clause + ["datafile" + (either [(:info "set_datafile_fortran") + "fortran"] + [(:info "set_datafile_nofpe_trap") + "nofpe_trap"] + [(:info "set_datafile_missing") + "missing" (maybe string)] + [(:info "set_datafile_separator") + "separator" (either "whitespace" string)] + [(:info "set_datafile_commentschars") + "commentschars" (maybe string)] + [(:info "set_datafile_binary") + "binary" (many binary-keyword)])]) + + (set-decimalsign-clause + ["decimalsign" + (either string ["locale" (maybe string)])]) + + (set-dgrid3d-clause + ["dgrid3d" + (maybe expression) ; fixme + (maybe "," expression) + (either + "splines" + ["qnorm" expression] + [(either "gauss" "cauchy" "exp" "box" "hann") + (maybe expression) + (maybe "," expression)])]) + + (set-dummy-clause + ["dummy" + name (maybe "," name)]) + + (set-encoding-clause + ["encoding" + (either "default" "iso_8859_1" "iso_8859_15" "iso_8859_2" "iso_8859_9" + "koi8r" "koi8u" "cp437" "cp850" "cp852" "cp1250" "cp1251" "cp1254" + "utf8" "locale")]) + + (set-fit-clause + [(:info "fit_") + "fit" + (either + ["logfile" string] + "errorvariables" "noerrorvariables")]) + + (set-fontpath-clause + ["fontpath" (many string)]) + + (set-format-clause + [(:info "format_") + "format" + (maybe (either "x" "y" "xy" "x2" "y2" "z" "cb")) + string]) + + (set-grid-clause + ["grid" + (either "nomxtics" "mxtics" "noxtics" "xtics" "nomytics" "mytics" + "noytics" "ytics" "nomztics" "mztics" "noztics" "ztics" + "nomx2tics" "mx2tics" "nox2tics" "x2tics" "nomy2tics" + "my2tics" "noy2tics" "y2tics" "nomcbtics" "mcbtics" + "nocbtics" "cbtics" "layerdefault" "front" "back" + [linestyle-spec (maybe "," linestyle-spec)])]) + + (set-hidden3d-clause + [(kw ("hidden" . "3d")) + (many + (either + "defaults" "front" "back" + ["offset" expression] "nooffset" + ["trianglepattern" + (either "0" "1" "2" "3" "4" "5" "6" "7")] + ["undefined" (either "1" "2" "3")] + ["noundefined"] + "altdiagonal" "noaltdiagonal" + "bentover" "nobentover"))]) + + (set-historysize-clause + ["historysize" number]) + + (set-isosamples-clause + [(kw ("isosam" . "ples")) number (maybe "," number)]) + + (set-key-clause + ["key" + (many + (either "on" "off" "default" + [(either "inside" "outside") + (either "lmargin" "rmargin" "tmargin" "bmargin")] + ["at" expression "," expression] + "left" "right" "center" "top" "bottom" "vertical" + "horizontal" "Left" "Right" "reverse" "noreverse" "invert" + "noinvert" "above" "over" "below" "under" + ["samplen" number] + ["spacing" number] + ["width" number] + [(either "autotitle" "noautotitle") (maybe "columnheader")] + ["title" expression] "enhanced" "noenhanced" ["font" string] + textcolor-spec + [(either "box" "nobox") linestyle-spec] + ["maxcols" (either expression "auto")] + ["maxrows" (either expression "auto")]))]) + + (set-label-clause + ["label" + (maybe expression) + (either label-clause-component expression) + (many label-clause-component)]) + + (label-clause-component + (either + ["at" position] + "left" "center" "right" + (either "norotate" ["rotate" "by" expression]) + ["font" string] + "noenhanced" + "front" "back" + textcolor-spec + "nopoint" ["point" (many (either pointsize-spec linestyle-spec))] + ["offset" position])) + + (set-loadpath-clause + ["loadpath" (many string)]) + + (set-locale-clause + ["locale" (maybe string)]) + + (set-logscale-clause + ["logscale" + (either "x" "y" "xy" "x2" "y2" "z" "cb" name)]) + + (set-mapping-clause + ["mapping" (either "cartesian" "spherical" "cylindrical")]) + + (set-margin-clause + [(either "bmargin" "lmargin" "rmargin" "tmargin") + (maybe "at" "screen") expression]) + + ;; TODO: set-mouse-clause + + (set-multiplot-clause + ["multiplot" + (maybe + ["layout" number "," number + (maybe (either "rowsfirst" "columnsfirst")) + (maybe (either "downwards" "upwards")) + (maybe "title" string) + (maybe "scale" number (maybe "," number)) + (maybe "offset" number (maybe "," number))])]) + + (set-mxtics-clause + [(:info "mxtics") + (either "mxtics" "mytics" "mztics" "mx2tics" "my2tics" "mcbtics") + (either "default" number)]) + + ;; "set object", objects, dimensions, positions + (set-object-clause + ["object" + (maybe number) + (info-keyword + (either rectangle-object ellipse-object circle-object polygon-object)) + (maybe (either "front" "back" "behind")) + (maybe (kw "fillcolor" "fc") color-spec) + (maybe "fs" expression) + (maybe "default") + (maybe (kw "linewidth" "lw") expression)]) + + (rectangle-object + [(kw ("rect" . "angle")) + (maybe + (either + ["from" position (either "to" "rto") position] + ["center" position "size" dimension "," dimension] + ["at" position "size" dimension "," dimension]))]) + + (ellipse-object + ["ellipse" + (either "at" "center") position + "size" dimension "," dimension + (maybe "angle" number)]) + + (circle-object + ["circle" + (either "at" "center") position + "size" dimension + (maybe "arc" "[" number ":" number "]")]) + + (polygon-object + ["polygon" + "from" position (many (either "to" "rto") position)]) + + ;; "set offsets" + (set-offsets-clause + ["offsets" + (delimited-list [(maybe "graph") expression] "," 4 4)]) + + (set-origin-clause + ["origin" expression "," expression]) + + (set-output-clause + ["output" (maybe string)]) + + (set-parametric-clause + [(:info "parametric_") + (kw ("param" . "etric"))]) + + (set-pm3d-clause + ["pm3d" + (many + (either + ["at" name] + ["interpolate" number "," number] + (either "scansautomatic" "scansforward" "scansbackward" "depthorder") + ["flush" (either "begin" "center" "end")] + (either "ftriangles" "noftriangles") + (either "clip1in" "clip4in") + ["corners2color" + (either "mean" "geomean" "median" "min" "max" "c1" "c2" "c3" "c4")] + ["hidden3d" number] + "nohidden3d" + "implicit" "explicit" "map"))]) + + (set-palette-clause + ["palette" + (many + (either + "gray" "color" + ["gamma" number] + ["rgbformulae" number "," number "," number] + "defined" ; not complete + ["functions" expression "," expression "," expression] + ["file" string (many datafile-modifier)] + "RGB" "HSV" "CMY" "YIQ" "XYZ" + "positive" "negative" + "nops_allcF" "ps_allcF" + ["maxcolors" number]))]) + + (set-pointsize-clause pointsize-spec) + + (set-polar-clause "polar") + + (set-print-clause + [(:info "print_") + "print" + (maybe string)]) + + (set-samples-clause + ["samples" expression (maybe "," expression)]) + + (set-size-clause + ["size" + (either + "square" "nosquare" + ["ratio" expression] + "noratio" + [expression "," expression])]) + + (set-style-clause + ["style" + (either style-arrow-clause style-data-clause style-fill-clause + style-function-clause style-increment-clause + style-line-clause style-circle-clause style-rectangle-clause)]) + + ;; begin subclauses of "set style ..." + (style-arrow-clause + [(:info "set_style_arrow") + "arrow" + number + (either + "default" + (many + (either "nohead" "head" "heads" + "filled" "empty" "nofilled" + "front" "back" + ["size" dimension "," number (maybe "," number)] + linestyle-spec)))]) + + (style-data-clause + [(:info "set_style_data") + "data" plotting-style]) + + (style-fill-clause + [(:info "set_style_fill") + "fill" fill-style]) + + (style-function-clause + [(:info "set_style_function") + "function" plotting-style]) + + (style-increment-clause + [(:info "set_style_increment") + "increment" + (either (kw ("d" . "efault")) (kw ("u" . "serstyles")))]) + + (style-line-clause + [(:info "set_style_line") + "line" + expression + (either + "default" + (many + (either + "palette" + [(kw ("linet" . "ype") "lt") + (either expression color-spec)] + [(kw ("linec" . "olor") "lc") color-spec] + [(either (kw ("linew" . "idth") "lw") + (kw ("pointt" . "ype") "pt") + (kw ("points" . "ize") "ps") + (kw ("pointi" . "nterval") "pi")) + expression])))]) + + (style-circle-clause + [(:info "set_style_circle") + "circle" "radius" dimension]) + + (style-rectangle-clause + [(:info "set_style_rectangle") + "rectangle" + (many + (either + "front" "back" + [(kw ("linew" . "idth") "lw") expression] + [(kw "fillcolor" "fc") color-spec] + ["fs" expression]))]) + ;; end of "set style ..." clauses + + (set-surface-clause "surface") + + (set-table-clause ["table" (maybe string)]) + + (set-terminal-clause ; not sure how to do this... + ["terminal" (maybe (either "push" "pop"))]) + + (set-termoption-clause + ["termoption" + (either + "enhanced" "noenhanced" + ["font" string] + "solid" "dashed" + [(kw "linewidth" "lw") expression])]) + + (set-tics-clause + ["tics" + (many + (either + "axis" "border" "mirror" "nomirror" "in" "out" + ["scale" (either "default" [expression (maybe "," expression)])] + [(either "rotate" "norotate") (maybe "by" expression)] + ["offset" expression] "nooffset" + ["format" string] + ["font" string] + textcolor-spec))]) + + (set-tics-clause-2 + ["tics" (either "front" "back")]) + + (set-xtics-clause + [(:info "xtics") + (either "xtics" "ytics" "ztics" "x2tics" "y2tics" "cbtics") + (many + (either + "axis" "border" "mirror" "nomirror" "in" "out" + ["scale" (either "default" [expression (maybe "," expression)])] + [(either "rotate" "norotate") (maybe "by" expression)] + ["offset" position] "nooffset" + "add" "autofreq" + ["(" (delimited-list [(maybe string) expression (maybe number)] ",") ")"] + ["format" string] + ["font" string] + "rangelimited" + textcolor-spec + (delimited-list expression ",")))]) + + (set-timestamp-clause + ["timestamp" + (maybe string) + (maybe (either "top" "bottom")) + (maybe (either "rotate" "norotate")) + (maybe "offset" position) + (maybe "font" string)]) + + (set-timefmt-clause + ["timefmt" string]) + + (set-title-clause + [(:info "title_") + "title" + (maybe expression) + (many + (either + ["offset" position] + ["font" string] + textcolor-spec + "enhanced" "noenhanced"))]) + + (set-view-clause + ["view" + (either + "map" + [(either "equal" "noequal") (maybe (either "xy" "xyz"))] + (delimited-list (maybe expression) ","))]) + + (set-data-clause + [(:info "xdata") + (either "xdata" "ydata" "zdata" "x2data" "y2data" "cbdata") + (maybe (either "time" "geographic"))]) + + (set-dtics-clause + [(:info "xdtics") + (either "xdtics" "ydtics" "zdtics" "x2dtics" "y2dtics" "cbdtics")]) + + (set-xlabel-clause + [(:info "xlabel") + (either (kw ("xlab" . "el")) (kw ("ylab" . "el")) + (kw ("zlab" . "el")) (kw ("x2lab" . "el")) + (kw ("y2lab" . "el")) (kw ("cblab" . "el"))) + (maybe expression) + (many + (either + ["offset" position] + ["font" string] + textcolor-spec + "enhanced" "noenhanced"))]) + + (set-mtics-clause + [(:info "xmtics") + (either "xmtics" "ymtics" "zmtics" "x2mtics" "y2mtics" "cbmtics")]) + + (set-range-clause + [(:info "xrange") + (either (kw ("xr" . "ange")) (kw ("yr" . "ange")) + (kw ("x2r" . "ange")) (kw ("y2r" . "ange")) + (kw ("zr" . "ange")) (kw ("tr" . "ange")) + (kw ("ur" . "ange")) (kw ("vr" . "ange")) + (kw ("rr" . "ange")) (kw ("cbr" . "ange"))) + (either + "restore" + ["[" (maybe + [(maybe axis-range-component) ":" + (maybe axis-range-component)]) + "]" + (many (either "reverse" "noreverse" "writeback" "nowriteback"))])]) + + (set-xyplane-clause + ["xyplane" (either "at" "relative") expression]) + + (set-zero-clause + ["zero" expression]) + + (set-zeroaxis-clause + [(:info "zeroaxis") + (either "zeroaxis" "xzeroaxis" "x2zeroaxis" "yzeroaxis" "y2zeroaxis" + "zzeroaxis") + (maybe linestyle-spec)]) + + +;;; Other commands + (cd-command + ["cd" string]) + + (call-command + ["call" string (many expression)]) + + (simple-command + (either "clear" "exit" "quit" "pwd" "refresh" "reread" "reset" + "shell")) + + (eval-command + ["eval" expression]) + + (load-command + ["load" string]) + + (lower-raise-command [(either "lower" "raise") number]) + + (pause-command + ["pause" + (either + expression + ["mouse" (maybe endcondition (maybe "," endcondition))]) + string]) + + (endcondition (either "keypress" "button1" "button2" "button3" "close" "any")) + + (save-command + ["save" + (either "functions" "variables" "terminal" "set") + string]) + + (system-command + ["system" string]) + + (test-command + ["test" + (either + "terminal" + ["palette" + (maybe + (either "rgb" "rbg" "grb" "gbr" "brg" "bgr"))])]) + + (undefine-command + ["undefine" (many name)]) + + (update-command + ["update" string (maybe string)])) + + ;; This is the start symbol + 'command)))) + + +;; The following macros are used for debugging; load +;; gnuplot-debug-context.el and then re-load this file to enable +;; them. For normal use, they compile to no-ops. +(eval-when-compile + (when (not (featurep 'gnuplot-debug-context)) + (defmacro with-gnuplot-trace-buffer (&rest args) "No-op." '(progn nil)) + (defmacro gnuplot-trace (&rest args) "No-op." '(progn nil)) + (defmacro gnuplot-debug (&rest args) "No-op." '(progn nil)))) + + + +;;;; Variables to be set via pattern matching +(defvar gnuplot-completions nil + "List of possible gnuplot-mode completions at point. +This is filled in by `gnuplot-match-pattern' when it reaches the +token before point.") + +(defvar gnuplot-info-at-point nil + "Relevant page of the Gnuplot info manual for the construction at point. + +Set by `gnuplot-match-pattern' using information from +`gnuplot-compiled-grammar'. `gnuplot-match-pattern' pushes ElDoc +and info strings onto the stack as it runs, and scans the stack +for the topmost entry when it reaches the token at point.") + +(defvar gnuplot-eldoc nil + "ElDoc documentation string for the Gnuplot construction at point. + +Set by `gnuplot-match-pattern'. See also `gnuplot-info-at-point'.") + +(defvar gnuplot-captures nil + "Alist of named capture groups for gnuplot-mode completion code. + +Each entry is of the form (NAME BEGIN END), where NAME is the +name specified in the (capture NAME PATTERN) form in the +`gnuplot-compiled-grammar' source, BEGIN is the tail of the token +list beginning the capture group, and END is the tail of the +token list just after the end of the capture group.") + + +;;;; The pattern matching machine +(defun gnuplot-match-pattern (instructions tokens completing-p + &optional start-symbol) + "Parse TOKENS, setting completions, info and ElDoc information. + +This function parses TOKENS by simulating a stack machine with +unlimited backtracking. If COMPLETING-P is non-nil, it stops +before the token at point and collects a list of the next tokens +that it would accept in `gnuplot-completions'. If COMPLETING-P is +nil, it parses up to the token at point and sets `gnuplot-eldoc' +and `gnuplot-info-at-point' based on the contents of the stack +there." + (catch 'return + (let ((pc 0) ; Program counter + ;; Stack of return addresses (return PC), eldoc strings + ;; (eldoc STRING) and info pages (info STRING) + (stack '()) + ;; Stack of backtracking records: + ;; ((STACK TOKENS RESUME-PC CAPTURES PROGRESS) ...) + (backtrack '()) + ;; Match failure flag, set to `t' to cause backtracking + (fail nil) + ;; Flag set by JUMP and CALL instructions to stop PC advance + (jump nil) + ;; Record of progress made within (many ...) loops, an alist + ;; of conses (pc . tokens) + (progress '())) + + (with-gnuplot-trace-buffer (erase-buffer)) + + (when start-symbol ; HACK FIXME + (let ((look-for `(label ,start-symbol))) + (while (not (equal (aref instructions pc) look-for)) + (incf pc)) + (incf pc))) + + (setq gnuplot-completions nil + gnuplot-eldoc nil + gnuplot-info-at-point nil + gnuplot-captures nil) + + (flet ((advance + () + (pop tokens) + (if (and (null tokens) (not completing-p)) + (gnuplot-scan-stack stack tokens))) + (fail () (setq fail t))) + + ;; Main loop + (while t + (let* ((inst (aref instructions pc)) + (opcode (car inst)) + (token (car tokens)) + (end-of-tokens (null tokens))) + (gnuplot-trace "%s\t%s\t%s\n" pc inst (and token (gnuplot-token-id token))) + + (case opcode + ;; (literal LITERAL NO-COMPLETE) + ((literal) + (let ((expect (cadr inst)) + (no-complete (caddr inst))) + (cond (end-of-tokens + (unless no-complete + (gnuplot-trace "\tpushing \"%s\" to completions\n" expect) + (push expect gnuplot-completions)) + (fail)) + + ((not (equal (gnuplot-token-id token) expect)) + (fail)) + + ;; otherwise succeed + (t (advance))))) + + ;; (token-type TYPE) + ((token-type) + (let ((expect (cadr inst))) + (if (or end-of-tokens + (not (eq (gnuplot-token-type token) expect))) + (fail) + (advance)))) + + ;; (keyword REGEXP NAME): match any token whose ID + ;; regexp-matches REGEXP, use NAME for completions + ((keyword) + (let ((regexp (cadr inst)) + (name (caddr inst))) + (cond (end-of-tokens + (gnuplot-trace "\tpushing \"%s\" to completions\n" name) + (push name gnuplot-completions) + (fail)) + + ((not (string-match-p regexp (gnuplot-token-id token))) + (fail)) + + ;; otherwise succeed + (t + (setf (gnuplot-token-id token) name) + (advance))))) + + ;; (any): match any token + ((any) + (if end-of-tokens + (fail) + (advance))) + + ;; (jump LOCATION): jump to instruction at LOCATION + ((jump) + (let ((location (cadr inst))) + (setq jump location))) + + ;; (call LOCATION): push the next instruction as a + ;; return location and jump + ((call) + (let ((location (cadr inst))) + (push `(return ,(+ pc 1)) stack) + (setq jump location))) + + ;; (return): return to address at topmost RETURN record on + ;; stack, or stop matching and return if stack is empty + ((return) + (while (and stack + (not (eq (caar stack) 'return))) + (pop stack)) + (if (not stack) + ;; Successful match + (throw 'return (list tokens)) + ;; Otherwise, return to caller + (let* ((r (pop stack)) + (r-pc (cadr r))) + (setq jump r-pc)))) + + ;; (choice LOCATION): push LOCATION onto the stack of + ;; backtracking points and continue at next instruction + ((choice) + (let ((location (cadr inst))) + (push `(,stack ,tokens ,location ,gnuplot-captures + ,progress) + backtrack))) + + ;; (commit LOCATION): discard most recent backtrack point + ;; and jump to LOCATION + ((commit) + (let ((location (cadr inst))) + (if (not backtrack) + (error "no more backtrack points in commit")) + (pop backtrack) + (setq jump location))) + + ;; (fail): force this match to fail, going back to most + ;; recent backtrack point + ((fail) + (fail)) + + ;; (assert): run Lisp code and fail if it returns NIL + ((assert) + (let ((form (cadr inst))) + (if (not (eval form)) (fail)))) + + ;; (push TYPE VALUE): push an info page or eldoc string + ;; onto the stack + ((push) + (let* ((type (cadr inst)) + (value (caddr inst))) + (push `(,type ,value ,tokens) stack))) + + ;; (pop TYPE): pop something off the stack + ((pop) + (let ((type (cadr inst))) + (if (not (and stack + (eq (caar stack) type))) + (error "Expected a %s on the stack but found %s" type stack)) + (pop stack))) + + ;; (save-start NAME): save current token pointer as + ;; beginning of capture group NAME + ((save-start) + (let ((name (cadr inst))) + (push `(,name ,tokens nil) gnuplot-captures))) + + ;; (save-end NAME): save current token pointer as end of + ;; capture group NAME + ((save-end) + (let* ((name (cadr inst)) + (record (assoc name gnuplot-captures))) + (if (not record) + (error "gnuplot-match-tokens: no open capture group named %s" name) + (setf (caddr record) tokens) + (gnuplot-debug (gnuplot-dump-captures))))) + + ;; (check-progress): make sure not stuck in an infinite loop + ((check-progress) + (let ((prev-progress (cdr (assoc pc progress)))) + (if (and prev-progress (eq prev-progress tokens)) + (fail) + (push (cons pc tokens) progress)))) + + (t + (error "bad instruction: %s" inst))) + + ;; Increment PC or jump + (setq pc (or jump (1+ pc)) + jump nil) + + ;; Backtrack on failure + (when fail + (if (not backtrack) ; Out of backtracking stack: failed match + (throw 'return nil) + (gnuplot-trace "\t*fail*\t%s\n" (length backtrack)) + (gnuplot-debug (gnuplot-dump-backtrack backtrack)) + ;; If we got as far as token-at-point before failing, + ;; scan the stack for eldoc and info strings + (when (and end-of-tokens (not completing-p)) + (gnuplot-scan-stack stack tokens)) + + (destructuring-bind + (bt-stack bt-tokens bt-pc bt-captures bt-progress) + (pop backtrack) + (setq stack bt-stack + tokens bt-tokens + pc bt-pc + gnuplot-captures bt-captures + progress bt-progress + fail nil) + (gnuplot-debug (gnuplot-dump-progress progress))))))))))) + +(defun gnuplot-scan-stack (stack tokens) + "Scan STACK for the most recently pushed eldoc and info strings" + (gnuplot-trace "\t* scanning stack *\n") + (gnuplot-debug (gnuplot-backtrace)) + (gnuplot-debug (gnuplot-dump-captures)) + + (catch 'no-scan + (while (and stack + (not (and gnuplot-info-at-point gnuplot-eldoc))) + (let* ((item (car stack)) + (type (car item)) + (position (caddr item))) ; must progress by at least one token + (if (and (memq type '(info eldoc no-scan)) + (not (eq position tokens))) + (case type + ((no-scan) + (throw 'no-scan nil)) + + ((info) + (when (not gnuplot-info-at-point) + (let ((info (cadr item))) + (setq gnuplot-info-at-point + (cond + ((eq info 'first-token) + (gnuplot-token-id (car position))) + ((functionp info) (funcall info)) + (t info))) + (when gnuplot-info-at-point + (gnuplot-trace "\tset info to \"%s\"\n" gnuplot-info-at-point) + (when (and (not gnuplot-eldoc) gnuplot-eldoc-hash) + (let ((eldoc + (car (gethash gnuplot-info-at-point gnuplot-eldoc-hash)))) + (when eldoc + (setq gnuplot-eldoc eldoc) + (gnuplot-trace "\tand set eldoc to \"%s\"\n" eldoc)))))))) + + ((eldoc) + (when (not gnuplot-eldoc) + (let ((eldoc (cadr item))) + (setq gnuplot-eldoc + (if (functionp eldoc) (funcall eldoc) eldoc)) + (gnuplot-trace "\tset eldoc to \"%s\"\n" gnuplot-eldoc))))))) + (pop stack)))) + +(defun gnuplot-capture-group (name) + "Return capture group NAME from the most recent parse, as a list of tokens." + (let ((record (assoc name gnuplot-captures))) + (if (not record) nil + (let ((begin (cadr record)) + (end (caddr record)) + (accum '())) + (while (and begin (not (eq begin end))) + (push (pop begin) accum)) + (nreverse accum))))) + +(defun gnuplot-capture-group->string (name) + (let ((tokens (gnuplot-capture-group name))) + (and tokens + (mapconcat 'gnuplot-token-id tokens " ")))) + + +;;; Interface to the matching machine +(defun gnuplot-parse-at-point (completing-p) + (let ((tokens (gnuplot-tokenize completing-p))) + (gnuplot-match-pattern gnuplot-compiled-grammar tokens completing-p))) + +;; Completions +(defun gnuplot-completions () + (gnuplot-parse-at-point t) + (if (featurep 'xemacs) ; Need an alist + (mapcar (lambda (s) (cons s nil)) gnuplot-completions) + gnuplot-completions)) + +(defun gnuplot-context-completion-at-point () + "Return completions of keyword preceding point, using context." + (let* ((end (point)) + (beg + (save-excursion + (skip-syntax-backward "w_" (gnuplot-point-at-beginning-of-command)) + (point))) + (word nil) + (completions (gnuplot-completions))) + + (setq word (buffer-substring beg end) + completions (all-completions word completions)) + + (if completions + (list beg end completions) + (if (not (equal "" word)) + (message "No gnuplot keywords complete '%s'" word) + (message "No completions at point")) + nil))) + +;; Eldoc help +(defun gnuplot-eldoc-function () + "Return the ElDoc string for the Gnuplot construction at point." + (gnuplot-parse-at-point nil) + gnuplot-eldoc) + +(defun gnuplot-help-function () + "Pop up the extended documentation for the construction at point." + (interactive) + (gnuplot-parse-at-point nil) + (if (and gnuplot-info-at-point gnuplot-eldoc-hash) + (let ((eldoc + (cadr (gethash gnuplot-info-at-point gnuplot-eldoc-hash)))) + (if eldoc (message eldoc))))) + +;; Info lookup +(defun gnuplot-info-at-point (&optional query) + "Open the relevant gnuplot info page for the construction at point." + (interactive "P") + (setq gnuplot-info-at-point nil) + (unless query + (gnuplot-parse-at-point nil)) + (if (or query (not gnuplot-info-at-point)) + (let ((info + (info-lookup-interactive-arguments 'symbol))) + (setq gnuplot-info-at-point (car info)))) + (when gnuplot-info-at-point + (gnuplot--find-info-node gnuplot-info-at-point))) + +(defun gnuplot--find-info-node (node) + (save-window-excursion + (if (>= emacs-major-version 23) + (info (format "(gnuplot)%s" node)) + (info) + (Info-find-node "gnuplot" node))) + (gnuplot--adjust-info-display)) + + +;;; Some context-sensitive hacks + +;; ElDoc strings for "using" specs, which depend on other information +;; from the parsed command + +(defvar gnuplot-using-eldoc + '(("boxerrorbars" . "x:y:ydelta{:xdelta} | x:y:ylow:yhigh{:xdelta}") + ("boxes" . "x:y{:x_width}") + ("boxxyerrorbars" . "x:y:xdelta:ydelta | x:y:xlow:xhigh:ylow:yhigh") + ("candlesticks" . "x:box_min:whisker_min:whisker_high:box_high | date:open:low:high:close") + ("circles" . "x:y:radius") + ("dots" . "x{:y{:z}}") + ("filledcurves" . "x:y | x:y1:y2") + ("financebars" . "date:open:low:high:close") + ("fsteps" . "y | x:y") + ("histeps" . "y | x:y") + ("histograms" . "y:yerr | y:ymin:ymax") + ("image" . "x:y:value") + ("rgbimage" . "x:y:r:g:b") + ("rgbalpha" . "x:y:r:g:b:a") + ("impulses" . "x{:y{:z}}") + ("labels" . "x:y:string") + ("lines" . "y | x:y") + ("steps" . "y | x:y") + ("vectors" . "x:y:xdelta:ydelta") + ("xerrorbars" . "x:y:xdelta | x:y:xlow:xhigh") + ("xyerrorbars" . "x:y:xdelta:ydelta | x:y:xlow:xhigh:ylow:yhigh") + ("yerrorbars" . "x:y:ydelta | x:y:ylow:yhigh") + ("yerrorlines" . "x:y:ydelta | x:y:ylow:yhigh") + ("xerrorlines" "x:y:xdelta | x:y:xlow:xhigh") + ("xyerrorlines" . "x:y:xdelta:ydelta | x:y:xlow:xhigh:ylow:yhigh")) + "Alist of ElDoc strings for Gnuplot \"using\" clauses in \"plot\" commands.") + +(defvar gnuplot-using-3d-eldoc + (append + '(("fsteps" . "z | x:y:z") + ("histeps" . "z | x:y:z") + ("histograms" . "y:yerr | y:ymin:ymax") + ("image" . "x:y:z:value") + ("rgbimage" . "x:y:z:r:g:b") + ("rgbalpha" . "x:y:z:r:g:b:a") + ("labels" . "x:y:z:string") + ("lines" . "z | x:y:z") + ("steps" . "z | x:y:z") + ("vectors" . "x:y:z:xdelta:ydelta:zdelta")) + gnuplot-using-eldoc) + "Alist of ElDoc strings for Gnuplot \"using\" clauses in \"splot\" commands.") + +(defun gnuplot-find-using-eldoc () + "Return ElDoc string for a Gnuplot \"using\" clause, based on plotting style. + +This will fail if the \"using\" clause comes before the \"with\" +clause." + (let ((with-style (gnuplot-capture-group :with-style)) + (3d-p (gnuplot-capture-group :splot-command)) + (column-description nil)) + (if with-style + (let ((with-style-string (gnuplot-token-id (car with-style)))) + (setq column-description + (or (and 3d-p + (cdr (assoc with-style-string gnuplot-using-3d-eldoc))) + (cdr (assoc with-style-string gnuplot-using-eldoc)) + "")))) + (format "using %s {'format'}" column-description))) + +;;; Needed for correctly parsing plot commands +(defun gnuplot-guess-parametric-p (&optional start) + "Guess whether the command beginning at START is in parametric mode. + +Searches backward in current buffer for an \"(un)set parametric\" +command." + (save-excursion + (and start (goto-char start)) + (catch 'result + (while + (search-backward-regexp "reset\\|set\\s-+parametric" (point-min) t) + (gnuplot-beginning-of-command) + (cond ((looking-at "reset\\|unset\\s-+parametric") (throw 'result nil)) + ((looking-at "set\\s-+parametric") (throw 'result t)))) + nil))) + + + +;;; All done! +(provide 'gnuplot-context) + +;;; gnuplot-context.el ends here diff --git a/elpa/gnuplot-20141231.1337/gnuplot-gui.el b/elpa/gnuplot-20141231.1337/gnuplot-gui.el new file mode 100644 index 00000000..02960b0f --- /dev/null +++ b/elpa/gnuplot-20141231.1337/gnuplot-gui.el @@ -0,0 +1,1748 @@ +;;;; gnuplot-gui.el -- GUI interface to setting options in gnuplot-mode + +;; Copyright (C) 1998-2000 Bruce Ravel + +;; Author: Bruce Ravel +;; Maintainer: Bruce Ravel +;; Created: 19 December 1998 +;; Updated: 16 November 2000 +;; Version: (same as gnuplot.el) +;; Keywords: gnuplot, plotting, interactive, GUI + +;; 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 2, or (at your option) +;; any later version. +;; +;; This lisp script is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +;; +;; Permission is granted to distribute copies of this lisp script +;; provided the copyright notice and this permission are preserved in +;; all copies. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, you can either send email to this +;; program's maintainer or write to: The Free Software Foundation, +;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; send bug reports to the authors (ravel@phys.washington.edu) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This file provides a graphical user interface to setting arguments +;; to gnuplot commands. Positioning point near a command and invoking +;; `gnuplot-gui-set-options-and-insert' (C-c C-c or shift-mouse-2) +;; will pop open a frame with widgets for setting the various +;; arguments appropriate the the item that was near point. The goal +;; is to provide point-and-click functionality to gnuplot-mode. +;; +;; gnuplot-gui is designed for gnuplot 3.7, but since much of 3.7 is +;; backward compatible to 3.5, it will work well for that version +;; also. +;; +;; gnuplot-gui.el was developed using Emacs 19.34 and is known to work +;; on Emacs 20.x and XEmacs 20.x. I do not know what is the earliest +;; version for which it will work, but I make no guarantees for +;; versions before 19.34. Note that this makes heavy use of the +;; widget package, so this will not work on Emacs 19.34 unless you +;; install the widget package separately. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; To do: +;; +;; Widgets I need: +;; -- 'position: two or three comma separated numbers used to denote a +;; position or a tic start/end/increment (see arrow, +;; need a prefix) +;; -- 'modifier: colon separated fields used for datafile modifiers +;; +;; command types which are currently unsupported or contain mistakes +;; -- unsupported: cntrparam +;; -- plot, splot, fit: rather lame +;; -- label: position information missing +;; -- label: font string handled in overly simple manner +;; -- hidden3d: not really suited to 'list, but all options are exclusive... +;; -- pointstyle argument to "set label" +;; +;; overall: +;; -- continuation lines (ugh!) +;; -- multiple frames end up displaying same window after setting options +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Code: + +(require 'gnuplot) +(eval-and-compile + (condition-case () + (progn + (require 'widget) + (require 'wid-edit)) + (error nil))) +(require 'cl) +(eval-when-compile ; suppress some compiler warnings + (defvar gnuplot-xemacs-p nil) + (defvar gnuplot-quote-character nil) + (defvar gnuplot-info-display nil) + (defvar gnuplot-mode-map nil)) + +;; (eval-when-compile +;; (require 'wid-edit)) + +(eval-and-compile ; I need this! + (if (fboundp 'split-string) + () + (defun split-string (string &optional pattern) + "Return a list of substrings of STRING which are separated by PATTERN. +If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." + (or pattern + (setq pattern "[ \f\t\n\r\v]+")) + ;; The FSF version of this function takes care not to cons in case + ;; of infloop. Maybe we should synch? + (let (parts (start 0)) + (while (string-match pattern string start) + (setq parts (cons (substring string start (match-beginning 0)) parts) + start (match-end 0))) + (nreverse (cons (substring string start) parts)))) )) + + + +;;; customizable variables + +(defgroup gnuplot-gui nil + "Graphical interface to setting arguments in gnuplot scrips." + :prefix "gnuplot-gui-" + :group 'gnuplot) + +(defcustom gnuplot-gui-popup-flag nil + "*Non-nil means to open arguments pop-ups automatically. +This would be done after menu insertion of Gnuplot commands." + :group 'gnuplot-gui + :type 'boolean) + +(defvar gnuplot-gui-frame nil + "Frame used to hold the buffer for setting options.") +(defcustom gnuplot-gui-frame-plist + '(height 18 width 65 border-width 0 + user-position t top 150 left 150 + internal-border-width 0 unsplittable t + default-toolbar-visible-p nil has-modeline-p nil + menubar-visible-p nil) + "Frame plist for the input run-time display frame in XEmacs." + :type '(repeat (group :inline t + (symbol :tag "Property") + (sexp :tag "Value"))) + :group 'gnuplot-gui) +(defcustom gnuplot-gui-frame-parameters + '((height . 18) + (width . 65) + (user-position . t) + (top . 150) + (left . 150) + (border-width . 0) + (menu-bar-lines . 0) + (unsplittable . t)) + "Frame parameters for the input run-time display frame in Emacs." + :group 'gnuplot-gui + :type '(repeat (sexp :tag "Parameter:"))) + +(defcustom gnuplot-gui-fontname-list + '(" " "\"Helvetica\"" "\"Times-Roman\"") + "List of known font names. +These *must* be quoted, like so \"\\\"Helvetica\\\"\". This allows +for fonts with names like \"\\\"Arial Bold Italic\\\"\" to be treated +as single entries in the menu-buttons. And it is really important that +the first entry in the list be a blank string." + :group 'gnuplot-gui + :type '(repeat (string :tag "Font name:"))) + +;; some global variables +(defvar gnuplot-current-frame nil) +(defvar gnuplot-current-buffer nil) +(defvar gnuplot-current-buffer-point nil) +(defvar gnuplot-gui-alist nil) +(defvar gnuplot-gui-current-string nil) + + +;;; various tools for handling data structures and text in the buffer + +;; tools for accessing the elements of the lists in `gnuplot-gui-all-types' +(defsubst gnuplot-gui-type-tag (obj) (elt obj 0)) +(defsubst gnuplot-gui-type-symbol (obj) (elt obj 1)) +(defsubst gnuplot-gui-type-default (obj) (elt obj 2)) +(defsubst gnuplot-gui-type-prefix (obj) (elt obj 3)) ; also 'range seperator +(defsubst gnuplot-gui-type-fourth (obj) (elt obj 4)) +(defsubst gnuplot-gui-type-list (obj) (cddr obj)) + +(defun gnuplot-this-word () + "Return the word under point." + (let ((begin (save-excursion (beginning-of-line) (point-marker))) + (end (save-excursion (end-of-line) (point-marker)))) + (save-excursion + (or (looking-at "\\<") (= (current-column) 0) (forward-word -1)) + (if (> (point) begin) (setq begin (point-marker))) + (forward-word 1) + (if (> (point) end) (goto-char end)) + (buffer-substring-no-properties begin (point))))) + + + +;;; data structures containing regarding options in Gnuplot 3.7 + +;; various constants used for options that take the same sorts of arguments +(defconst gnuplot-gui-mtics-list + '(("FREQUENCY" 'number " ") + ("DEFAULT" 'list " " "default"))) +(defconst gnuplot-gui-data-list + '(("DATA TYPE" 'list " " "time"))) +(defconst gnuplot-gui-label-list + '(("LABEL" 'string " ") + ("POSITION" 'position " " "" 2) + ("FONTNAME" 'list " " gnuplot-gui-fontname-list) + ("FONTSIZE" 'fontsize " "))) +(defconst gnuplot-gui-range-list + '(("RANGE" 'range (" " . " ") ":") + ("REVERSE" 'list " " "reverse" "noreverse") + ("WRITEBACK" 'list " " "writeback" "nowriteback"))) +(defconst gnuplot-gui-tics-list + '(("WHERE" 'list " " "axis" "border") + ("MIRROR" 'list " " "mirror" "nomirror") + ("ROTATE" 'list " " "rotate" "norotate") + ("SERIES" 'position " " "" 3) + ("LABEL ARRAY" 'labels () ))) +(defconst gnuplot-gui-zeroaxis-list + '(("LINETYPE" 'number " "))) + +(defvar gnuplot-gui-terminal-types nil + "Associated list of terminal descriptions. +See the doc-string for `gnuplot-gui-all-types'.") +(setq gnuplot-gui-terminal-types + (list (cons "aifm" + '(("COLOR" 'list " " "monochrome" "gray" "color") + ("FONTNAME" 'list " " gnuplot-gui-fontname-list) + ("FONTSIZE" 'fontsize " "))) + (cons "cgm" + '(("MODE" 'list " " "landscape" "portrait" "default") + ("COLOR" 'list " " "color" "monochrome") + ("ROTATION" 'list " " "rotate" "norotate") + ("WIDTH" 'number " " "width") + ("LINEWIDTH" 'number " " "linewidth") + ("FONTNAME" 'list " " "\"Arial\"" "\"Arial Italic\"" + "\"Arial Bold\"" "\"Arial Bold Italic\"" + "\"Times Roman\"" "\"Times Roman Italic\"" + "\"Times Roman Bold\"" "\"Times Roman Bold Italic\"" + "\"Helvetica\"" "\"Roman\"") + ("FONTSIZE" 'fontsize " "))) + (cons "corel" + '(("COLOR" 'list " " "default" "color" "monochrome") + ("FONTNAME" 'list " " "\"SwitzerlandLight\"" + "\"Helvetica\"" "\"Times-Roman\"") + ("FONTSIZE " 'number " ") + ("X-SIZE " 'number " ") + ("Y-SIZE " 'number " ") + ("LINEWIDTH" 'number " "))) + (cons "dumb" + '(("LINEFEED" 'list " " "feed" "nofeed") + ("X-SIZE" 'number " ") + ("Y-SIZE" 'number " "))) + (cons "emf" + '(("COLOR" 'list " " "color" "monochrome") + ("LINE" 'list " " "solid" "dashed") + ("FONTNAME" 'string " ") + ("FONTSIZE" 'number " "))) + (cons "emtex" + '(("FONTNAME" 'list " " "courier" "roman") + ("FONTSIZE" 'fontsize " "))) + (cons "fig" + '(("COLOR" 'list " " "color" "monochrome") + ("FRAMESIZE" 'list " " "small" "big") + ("POINTSMAX" 'number " " "pointsmax") + ("ORIENTATION" 'list " " "landscape" "portrait") + ("UNITS" 'list " " "metric" "inches") + ("FONT SIZE" 'number " " "fontsize") + ("SIZE" 'pair (" " . " ") "size") + ("LINE THICKNESS" 'number " " "thickness") + ("LAYER DEPTH" 'number " " "depth"))) + (cons "hp500c" + '(("RESOLUTION" 'list " " "75" "100" "150" "300") + ("COMPRESSION" 'list " " "rle" "tiff"))) + (cons "hpgl" + '(("PENS" 'number " ") + ("EJECT" 'list " " "eject"))) + (cons "hpdj" + '(("RESOLUTION" 'list " " "75" "100" "150" "300"))) + (cons "hpljii" + '(("RESOLUTION" 'list " " "75" "100" "150" "300"))) + (cons "hppj" + '(("FONT" 'list " " "FNT9X17" "FNT5X9" "FNT13X25"))) + (cons "imagen" + '(("FONT SIZE" 'number " ") + ("LAYOUT" 'list " " "portrait" "landscape") + ("NUMBER OF GRAPHS" 'range (" " . " ") ","))) + (cons "gpic" + '(("X ORIGIN" 'number " ") + ("Y ORIGIN" 'number " " ","))) + (cons "latex" + '(("FONTNAME" 'list " " "courier" "roman") + ("FONTSIZE" 'fontsize " "))) + (cons "mif" + '(("COLOUR" 'list " " "colour" "monochrome") + ("LINETYPE" 'list " " "polyline" "vectors"))) + (cons "nec-cp6" + '(("MODE" 'list " " "monochrome" "colour" "draft"))) + (cons "pbm" + '(("SIZE" 'list " " "small" "medium" "large") + ("COLOR" 'list " " "monochrome" "gray" "color"))) + (cons "pcl5L" + '(("MODE" 'list " " "landscape" "portrait") + ("FONTNAME" 'list " " "stick" "univers" "cg_times") + ("FONTSIZE" 'fontsize " "))) + (cons "png" + '(("SIZE" 'list " " "small" "medium" "large") + ("COLOR" 'list " " "monochrome" "gray" "color"))) + (cons "postscript" + '(("MODE" 'list " " "landscape" "portrait" "eps" "default") + ("ENHANCED" 'list " " "enhanced" "noenhanced") + ("COLOR" 'list " " "color" "monochrome") + ("SOLID" 'list " " "solid" "dashed") + ("DUPLEXING" 'list " " "defaultplex" "simplex" "duplex") + ("FONTNAME" 'list " " gnuplot-gui-fontname-list) + ("FONTSIZE" 'fontsize " "))) + (cons "pslatex" + '(("COLOR" 'list " " "monochrome" "color") + ("DASHED" 'list " " "dashed") + ("ROTATION" 'list " " "rotate" "norotate") + ("AUXFILE" 'list " " "auxfile"))) + (cons "pstex" + '(("COLOR" 'list " " "monochrome" "color") + ("DASHED" 'list " " "dashed") + ("ROTATION" 'list " " "rotate" "norotate") + ("AUXFILE" 'list " " "auxfile"))) + (cons "pstricks" + '(("HACK TEXT" 'list " " "hacktext" "nohacktext") + ("PLOT SCALING" 'list " " "nounit" "unit"))) + (cons "regis" + '(("COLOR DEPTH" 'list "4" "16"))) + (cons "tgif" + '(("LAYOUT" 'list " " "portrait" "landscape") + ("NUMBER OF GRAPHS" 'range (" " . " ") ",") + ("LINE TYPE" 'list " " "solid" "dashed") + ("FONTNAME" 'list " " gnuplot-gui-fontname-list) + ("FONTSIZE" 'fontsize " "))) + (cons "tpic" + '(("POINTSIZE" 'number " ") + ("LINEWIDTH" 'number " ") + ("INTERVAL " 'number " "))) + (cons "vgagl" ; for pm3d patch (also persist, raise in x11) + '(("BACKGROUND" 'position " " "background" 3) + ("INTERPOLATION" 'list " " "uniform" "interpolate") + ("DUMP" 'file " ") + ("MODE" 'string " " ""))) + (cons "x11" + '(("RESET" 'list " " "reset") + ("TERMINAL NUMBER" 'number " ") + ("PERSIST" 'list " " "persist" "nopersist") + ("RAISE" 'list " " "raise" "noraise"))) )) + +(defvar gnuplot-gui-terminal-list nil) +(setq gnuplot-gui-terminal-list + (append (list " ") (mapcar 'car gnuplot-gui-terminal-types))) + +(defvar gnuplot-gui-set-types nil + "Associated list of set option descriptions. +See the doc-string for `gnuplot-gui-all-types'.") +(setq gnuplot-gui-set-types + (list (cons "angles" + '(("UNITS" 'list " " "degrees" "radians"))) + (cons "arrow" + '(("TAG" 'tag " ") + ("FROM" 'position " " "from" 3) + ("TO" 'position " " "to" 3) + ("HEAD" 'list " " "head" "nohead") + ("LINESTYLE" 'number " " "ls") + ("LINETYPE " 'number " " "lt") + ("LINEWIDTH" 'number " " "lw"))) + (cons "noarrow" + '(("TAG" 'tag " "))) + (cons "autoscale" + '(("AXIS" 'list " " "x" "y" "z" "x2" "y2" "xy" + "xmin" "ymin" "zmin" "x2min" "y2min" "xymin" + "xmax" "ymax" "zmax" "x2max" "y2max" "xymax"))) + (cons "noautoscale" + '(("AXIS" 'list " " "x" "y" "z" "x2" "y2" "xy" + "xmin" "ymin" "zmin" "x2min" "y2min" "xymin" + "xmax" "ymax" "zmax" "x2max" "y2max" "xymax"))) + (cons "bar" + '(("SIZE" 'list " " "small" "large"))) + (cons "border" + '(("BORDER CODE" 'number " ") + ("LINE STYLE" 'list " " "lines" + "dots" "points" "linespoints") + ("LINESTYLE" 'number " " "ls") + ("LINETYPE" 'number " " "lt") + ("LINEWIDTH" 'number " " "lw") + )) + (cons "boxwidth" + '(("WIDTH" 'number " "))) + (cons "clabel" + '(("FORMAT" 'format " "))) + (cons "clip" + '(("CLIP TYPE" 'list " " "points" "one" "two"))) + (cons "noclip" + '(("CLIP TYPE" 'list " " "points" "one" "two"))) + ;;(cons "cntrparam" + ;; '(("INTERPOLATION" 'list " " "linear" "cubicspline" "bspline") + ;; ("POINTS" 'number " " "points") + ;; ("ORDER" 'number " " "order"))) + (cons "contour" + '(("WHERE" 'list " " "base" "surface" "both"))) + (cons "dgrid3d" + '(("ROW,COLUMN,NORM" 'position " " "" 3))) + (cons "encoding" + '(("ENCODING" 'list " " "default" "iso_8859_1" + "cp850" "cp437"))) + (cons "format" + '(("AXIS" 'list " " "x" "y" "z" "xy" "x2" "y2") + ("FORMAT" 'format " "))) + (cons "dummy" + '(("VAR 1" 'string " " "") + ("VAR 2" 'string " " ","))) + (cons "grid" + '(("XTICS" 'list " " "xtics" "mxtics" "noxtics" "nomxtics") + ("YTICS" 'list " " "ytics" "mytics" "noytics" "nomytics") + ("ZTICS" 'list " " "ztics" "mztics" "noztics" "nomztics") + ("X2TICS" 'list " " "x2tics" "mx2tics" "nox2tics" "nomx2tics") + ("Y2TICS" 'list " " "y2tics" "my2tics" "noy2tics" "nomy2tics") + ("POLAR" 'number " " "polar") + ("MAJOR LINETYPE" 'number " ") + ("MINOR LINETYPE" 'number " "))) + (cons "hidden3d" + '(("ALGORITHM" 'list " " "defaults" + "offset" + "nooffset" + ;;"trianglepattern # bitpattern between 0 and 7" + "trianglepattern 0" "trianglepattern 1" + "trianglepattern 2" "trianglepattern 3" + "trianglepattern 4" "trianglepattern 5" + "trianglepattern 6" "trianglepattern 7" + ;;"undefined # level between 0 and 3" + "undefined 0" "undefined 1" "undefined 2" "undefined 3" + "noundefined" "altdiagonal" "noaltdiagonal" + "bentover" "nobentover"))) + (cons "historysize" + '(("SIZE" 'number " "))) + (cons "isosamples" + '(("ISO_U LINES" 'number " ") + ("ISO_V LINES" 'number " " ","))) + (cons "key" + '(("LOCATION" 'list " " "left" "right" "top" "bottom" + "outside" "below") + ("POSITION" 'position " " "" 3) + ("JUSTIFICATION" 'list " " "Left" "Right") + ("REVERSE" 'list " " "reverse" "noreverse") + ("SAMPLE LENGTH" 'number " " "samplen") + ("SPACING" 'number " " "spacing") + ("WIDTH" 'number " " "width") + ("TITLE" 'string " " "title ") + ("BOX LINETYPE" 'number " " "box") ;; linetype data + ("NOBOX" 'list " " "nobox"))) + (cons "label" + '(("TAG" 'tag " ") + ("LABEL TEXT" 'string " ") + ("POSITION" 'position " " "at" 3) + ;; first, second, graph, screen + ("JUSTIFICATION" 'list " " "left" "right" "center") + ("ROTATE" 'list " " "rotate" "norotate") + ("FONT" 'string " " "font"))) ;; font "name,size" + (cons "nolabel" + '(("TAG" 'tag " "))) + (cons "linestyle" + '(("TAG " 'tag " ") + ("LINE STYLE" 'list " " "boxerrorbars" "boxes" + "boxxyerrorbars" "candlesticks" "dots" + "financebars" "fsteps" "histeps" "impulses" + "lines" "linespoints" "points" "steps" "vector" + "xerrorbars" "xyerrorbars" "yerrorbars") + ("LINETYPE " 'number " " "lt") + ("LINEWIDTH" 'number " " "lw") + ("POINTTYPE" 'number " " "pt") + ("POINTSIZE" 'number " " "ps"))) + (cons "locale" + '(("LOCALE" 'string " "))) + (cons "logscale" + '(("AXIS" 'list " " "x" "y" "z" "xy" "xz" "yz" "xyz" + "x2" "y2") + ("BASE" 'number " "))) + (cons "nologscale" + '(("AXIS" 'list " " "x" "y" "z" "xy" "xz" "yz" "xyz" + "x2" "y2"))) + (cons "mapping" + '(("COORDINATE SYSTEM" 'list " " "cartesian" "spherical" + "cylindrical"))) + ; _margin + (cons "bmargin" + '(("BOTTOM MARGIN" 'number " "))) + (cons "lmargin" + '(("LEFT MARGIN" 'number " "))) + (cons "rmargin" + '(("RIGHT MARGIN" 'number " "))) + (cons "tmargin" + '(("TOP MARGIN" 'number " "))) + + (cons "missing" + '(("CHARACTER" 'string " " 1))) + ; m_tics + (cons "mxtics" gnuplot-gui-mtics-list) + (cons "mytics" gnuplot-gui-mtics-list) + (cons "mztics" gnuplot-gui-mtics-list) + (cons "mx2tics" gnuplot-gui-mtics-list) + (cons "my2tics" gnuplot-gui-mtics-list) + + ; pm3d additions + (cons "mouse" + '(("DOUBLECLICK" 'number " " "doubleclick") + ("ZOOM" 'list " " "zoomcoordinates" "nozoomcoordinates") + ("POLAR" 'list " " "polarcoordinates" "nopolarcoordinates") + ("FORMAT" 'string " " "format") + ("CLIPBOARDFORMAT" 'string " " "clipboardformat") + ("MOUSEFORMAT" 'string " " "mouseformat") + ("LABELS" 'list " " "labels" "nolabels") + ("LABELOPTIONS" 'string " " "labeloptions") + ("ZOOMJUMP" 'list " " "zoomjump" "nozoomjump") + ("VERBOSE" 'list " " "verbose" "noverbose"))) + (cons "palette" + '(("COLOR" 'list " " "gray" "color") + ("RGBFORMULAE" 'position " " "rgbformulae" 3) + ("PARITY" 'list " " "positive" "negative") + ("FORMULAE" 'list " " "nops_allcF" "ps_allcF") + ("MAXCOLORS" 'number " ") + ("COLOR_BOX" 'list " " "nocb" "cbdefault" "cbuser") + ("ORIENTATION" 'list " " "cbvertical" "cbhorizontal") + ("ORIGIN" 'position " " "origin" 2) + ("SIZE" 'position " " "size" 2) + ("BORDER" 'number " ") + ("NOBORDER" 'list " " "bdefault" "noborder"))) + (cons "pm3d" + '(("AT" 'list* " " "b" "s" "t" "bs" "bt" "st" "bst") + ("SCANS" 'list " " "scansautomatic" "scansforward" "scansbackward") + ("FLUSH" 'list* " " "begin" "center" "end") + ("CLIP" 'list " " "clip1in" "clip4in") + ("ZRANGE" 'range (" " . " ") ":") + ("HIDDEN3D" 'number " ") + ("NOHIDDEN3D" 'list " " "nohidden3d") + ("FILLING" 'list " " "transparent" "solid") + ("MAP" 'list " " "map"))) + + (cons "offsets" + '(("LEFT " 'number " ") + ("RIGHT " 'number " " ",") + ("TOP " 'number " " ",") + ("BOTTOM" 'number " " ","))) + (cons "origin" + '(("X ORIGIN" 'number " ") + ("Y ORIGIN" 'number " " ","))) + (cons "output" + '(("FILENAME" 'file " "))) + (cons "pointsize" + '(("MULTIPLIER" 'number " "))) + (cons "samples" + '(("2D PLOT" 'number " ") + ("3D PLOT" 'number " " ","))) + (cons "size" + '(("ASPECT" 'list " " "square" "nosquare" + "ratio" "noratio") + ("X-SCALE OR RATIO" 'number " ") + ("Y-SCALE" 'number " " ","))) + (cons "style" + '(("DATA TYPE" 'list " " "data" "function") + ("PLOT STYLE" 'list " " "boxerrorbars" "boxes" + "boxxyerrorbars" "candlesticks" "dots" + "financebars" "fsteps" "histeps" "impulses" + "lines" "linespoints" "points" "steps" "vector" + "xerrorbars" "xyerrorbars" "yerrorbars"))) + (cons "terminal" + '(("TERMINAL TYPE" 'list " " gnuplot-gui-terminal-list))) + (cons "tics" + '(("DIRECTION" 'list " " "in" "out"))) + (cons "ticslevel" + '(("RELATIVE HEIGHT" 'number " "))) + (cons "ticscale" + '(("MAJOR" 'number " ") + ("MINOR" 'number " "))) + (cons "timestamp" + '(("FORMAT STRING" 'format " ") + ("WHERE" 'list " " "top" "bottom") + ("ROTATE" 'list " " "rotate" "norotate") + ("X-OFFSET" 'number " ") + ("Y-OFFSET" 'number " " ",") + ("FONTNAME" 'list " " gnuplot-gui-fontname-list))) + (cons "timefmt" + '(("FORMAT STRING" 'string " "))) + (cons "title" + '(("TITLE" 'string " "))) + (cons "view" + '(("X-ROTATION" 'number " ") + ("Z-ROTATION" 'number " " ",") + ("SCALE" 'number " " ",") + ("Z-SCALE" 'number " " ","))) + ;; ("SCALE" 'position " " "," 4) + ; _data + (cons "xdata" gnuplot-gui-data-list) + (cons "ydata" gnuplot-gui-data-list) + (cons "zdata" gnuplot-gui-data-list) + (cons "x2data" gnuplot-gui-data-list) + (cons "y2data" gnuplot-gui-data-list) + ; _label + (cons "xlabel" gnuplot-gui-label-list) + (cons "ylabel" gnuplot-gui-label-list) + (cons "zlabel" gnuplot-gui-label-list) + (cons "x2label" gnuplot-gui-label-list) + (cons "y2label" gnuplot-gui-label-list) + ; _range, note that the [] syntax for + ; the writeback argument is + ; not properly supported + (cons "xrange" gnuplot-gui-range-list) + (cons "yrange" gnuplot-gui-range-list) + (cons "zrange" gnuplot-gui-range-list) + (cons "x2range" gnuplot-gui-range-list) + (cons "y2range" gnuplot-gui-range-list) + (cons "trange" gnuplot-gui-range-list) + (cons "rrange" gnuplot-gui-range-list) + (cons "urange" gnuplot-gui-range-list) + (cons "vrange" gnuplot-gui-range-list) + ; _tics + (cons "xtics" gnuplot-gui-tics-list) + (cons "ytics" gnuplot-gui-tics-list) + (cons "ztics" gnuplot-gui-tics-list) + (cons "x2tics" gnuplot-gui-tics-list) + (cons "y2tics" gnuplot-gui-tics-list) + ; zeroaxis + (cons "zeroaxis" gnuplot-gui-zeroaxis-list) + (cons "xzeroaxis" gnuplot-gui-zeroaxis-list) + (cons "yzeroaxis" gnuplot-gui-zeroaxis-list) + (cons "y2zeroaxis" gnuplot-gui-zeroaxis-list) + (cons "x2zeroaxis" gnuplot-gui-zeroaxis-list) + + (cons "zero" + '(("THRESHOLD" 'number " "))) + )) + +(defvar gnuplot-gui-command-types nil + "Associated list of command descriptions. +See the doc-string for `gnuplot-gui-all-types'.") +(setq gnuplot-gui-command-types + (list (cons "cd" + '(("FILENAME" 'file " "))) + (cons "call" + '(("INPUT FILE" 'file " ") + ("PARAMETER LIST" 'string " "))) + (cons "load" + '(("INPUT FILE" 'file " "))) + (cons "pause" + '(("TIME" 'number " ") + ("MESSAGE" 'string " "))) + (cons "print" + '(("EXPRESSION" 'string " "))) + (cons "save" + '(("SAVE" 'list " " "functions" "variables" "set") + ("FILE" 'file " "))) + (cons "update" + '(("INITIAL FILE" 'file " " t) + ("UPDATED FILE" 'file " " t))) )) + + +(defcustom gnuplot-gui-plot-splot-fit-style 'simple + "Control the complexity of the GUI display for plot, splot, and fit. +The values are 'simple, which causes a limited set of plot, splot, or +fit options to be displayed, and 'complete, which attempts to display +all options. The 'complete setting is prone to making errors when +parsing values already in the script buffer." + :group 'gnuplot-gui + :type '(radio (const :tag "Simple listing" simple) + (const :tag "Complete listing" complete))) + + +(defconst gnuplot-gui-plot-simple-list + '(("X RANGE" 'range (" " . " ") ":") + ("Y RANGE" 'range (" " . " ") ":") + ("DATA FILE" 'file " ") + ("THRU" 'string* " " "thru") + ("USING" 'modifier " ") + ("TITLE" 'string " ") + ("WITH" 'list* " " "boxerrorbars" "boxes" + "boxxyerrorbars" "candlesticks" "dots" "financebars" + "fsteps" "histeps" "impulses" "lines" "linespoints" + "points" "steps" "vector" "xerrorbars" "xyerrorbars" + "yerrorbars"))) +(defconst gnuplot-gui-plot-full-list + '(;;("T RANGE" 'range (" " . " ") ":") + ("X RANGE" 'range (" " . " ") ":") + ("Y RANGE" 'range (" " . " ") ":") + ("xa" 'text "\t---------------------") + ("FUNCTION" 'string " ") + ("xc" 'text " or") + ("DATA FILE" 'file " ") + ("INDEX" 'modifier " ") + ("EVERY" 'modifier " ") + ("THRU" 'string* " " "thru") + ("USING" 'modifier " ") + ("SMOOTH" 'list* " " "unique" "csplines" "acsplines" + "bezier" "sbezier") + ;; datafile modifiers + ("AXES" 'list* " " "x1y1" "x2y2" "x1y2" "x2y1") + ("TITLE" 'string " ") + ("NOTITLE" 'list " " "notitle") + ("xf" 'text "\t---------------------") + ("xi" 'text "Select a standard plotting style") + ("WITH" 'list* " " "boxerrorbars" "boxes" + "boxxyerrorbars" "candlesticks" "dots" "financebars" + "fsteps" "histeps" "impulses" "lines" "linespoints" + "points" "steps" "vector" "xerrorbars" "xyerrorbars" + "yerrorbars") + ("xo" 'text " or a previously defined style") + ("LINE STYLE " 'number " " "ls") + ("xr" 'text " or specify a style in-line") + ("LINE TYPE " 'number " " "lt") + ("LINE WIDTH " 'number " " "lw") + ("POINT TYPE " 'number " " "pt") + ("POINT STYLE" 'number " " "ps") + )) +(defconst gnuplot-gui-splot-simple-list + '(("DATA FILE" 'file " ") + ("TITLE" 'string " ") + ("WITH" 'list* " " "lines" "linespoints" "points" "dots" "impulses"))) +(defconst gnuplot-gui-splot-full-list + '(;;("U RANGE" 'range (" " . " ") ":") + ;;("V RANGE" 'range (" " . " ") ":") + ("X RANGE" 'range (" " . " ") ":") + ("Y RANGE" 'range (" " . " ") ":") + ("Z RANGE" 'range (" " . " ") ":") + ("xa" 'text "\t---------------------") + ("FUNCTION" 'string " ") + ("xc" 'text " or") + ("DATA FILE" 'file " ") + ("INDEX" 'modifier " ") + ("EVERY" 'modifier " ") + ("THRU" 'string* " " "thru") + ("USING" 'modifier " ") + ("SMOOTH" 'list* " " "unique" "csplines" "acsplines" + "bezier" "sbezier") + ("TITLE" 'string " ") + ("NOTITLE" 'list " " "notitle") + ("WITH" 'list* " " "lines" "linespoints" "points" "dots" "impulses"))) +(defconst gnuplot-gui-fit-simple-list + '(("FUNCTION" 'string* " " "") + ("DATA FILE" 'file " ") + ("VIA (params)" 'string* " " "via") )) +(defconst gnuplot-gui-fit-full-list + '(("X RANGE" 'range (" " . " ") ":") + ("Y RANGE" 'range (" " . " ") ":") + ("xa" 'text "----- fitting functionn and file --------") + ("FUNCTION" 'string* " " "") + ("DATA FILE" 'file " ") + ("xb" 'text "----- datafile modifiers ----------------") + ("INDEX" 'modifier " ") + ("EVERY" 'modifier " ") + ("THRU" 'string* " " "thru") + ("USING" 'modifier " ") + ("SMOOTH" 'list* " " "unique" "csplines" "acsplines" + "bezier" "sbezier") + ("xc" 'text "----- parameters (file or parameters) ---") + ("VIA (file)" 'string " " "via") + ("VIA (params)" 'string* " " "via") )) + +(defvar gnuplot-gui-plot-splot-fit nil + "Associated list of plot, splot, and fit descriptions. +See the doc-string for `gnuplot-gui-all-types'.") +(setq gnuplot-gui-plot-splot-fit + (list (cons "plot" (if (equal gnuplot-gui-plot-splot-fit-style 'complete) + gnuplot-gui-plot-full-list + gnuplot-gui-plot-simple-list)) + (cons "splot" (if (equal gnuplot-gui-plot-splot-fit-style 'complete) + gnuplot-gui-splot-full-list + gnuplot-gui-splot-simple-list)) + (cons "fit" (if (equal gnuplot-gui-plot-splot-fit-style 'complete) + gnuplot-gui-fit-full-list + gnuplot-gui-fit-simple-list))) ) + + +(defvar gnuplot-gui-test-type nil) +(setq gnuplot-gui-test-type + (list (cons "test" + '(("TAG" 'tag " ") + ("LIST" 'list " " "1" "2" "3") + ("LIST*" 'list* " " "1" "2" "3") + ("NUMBER" 'number " " "number") + ("RANGE" 'range (" " . " ") ":") + ("PAIR" 'pair (" " . " ") "pair") + ("LABELS" 'labels ()) + ("FILE" 'file " ") + ("TEXT" 'text "this is text") + ("STRING" 'string " ") + ("STRING*" 'string* " " "string*") + ("FORMAT" 'format " ") + ("POSITION" 'position " " "at" 3) + ("FONTSIZE" 'fontsize " ") )))) + +(defvar gnuplot-gui-all-types nil + "Associated list of terminal, set option, and command arguments. + +Each entry in the list is a cons cell of the form + (OPTION . ALIST) +where OPTION is one of the recognized options in Gnuplot, either a +command, something that is set, or a terminal type. Only those +commands, set options, and terminal types that actually take arguments +are in this associated list. + +ALIST is itself an associated list where each entry is of the form: + + (TAG TYPE DEFAULT REST) + +TAG is the name used on the widget and indicates one of the options +for this command, set option, or terminal type. + +TYPE is one of + 'list a menu-list of strings + 'list* a menu-list of strings with a prefix + 'number a number with an optional prefix + 'tag like number but must be the first argument + 'fontsize like number but must be the last argument + 'range a pair of numbers like [#,#] or [#:#] + 'pair a pair of numbers with no punctuation and a prefix + 'file a quoted string and a file browser + 'string a quoted string with an optional prefix + 'string* an unquoted string with a prefix + 'format a quoted string and an info-link to (gnuplot)format + 'labels an array as needed for xtics, ytics, etc + 'position 2 or 3 comma separated numbers with an optional prefix + +DEFAULT is the default value for this option. Note that the default +for 'range and 'pair is a cons cell and the default for 'labels is a +list. For most things, the best choice of DEFAULT is a string of +white space or a cons cell of two strings of white space. Strings of +white space are better defaults than empty strings or nil. + +The value of REST depends upon TYPE: + + For 'list & REST is the list of options that will go into the + 'list* menu-button. This can also be a symbol which + evaluates to a list containing the options to go into + the menu-button. This list variable must contain the + DEFAULT. + For 'number REST is the prefix string (if it exists) for that number. + For 'range REST is the separator, \":\" for plot ranges and + \",\" for plot dimensions (see for example the tgif + terminal type) + For 'string & REST may a number denoting the width of the editable-text + 'string* field or it may be a string denoting a prefix. By + default, the width is half the width of the frame + and there is no prefix. It may be useful to + specify \"1\" when the input is a single character + as in 'set missing'. + For 'file REST determines the label placed before the file insertion + field. If non-nil, then TAG is used. If nil, then + the default \"File\" is used. + For 'position REST is the prefix and the number of comma separated numbers + For others REST is not used. + +Here is an example entry for the png terminal type: + + (cons \"png\" + '((\"SIZE\" 'list \" \" \"small\" \"medium\" \"large\") + (\"COLOR\" 'list \" \" \"monochrome\" \"gray\" \"color\"))) + +This alist is formed at load time by appending together +`gnuplot-gui-terminal-types', `gnuplot-gui-set-types' and +`gnuplot-gui-command-types'.") + +(setq gnuplot-gui-all-types (append gnuplot-gui-terminal-types + gnuplot-gui-set-types + gnuplot-gui-command-types + gnuplot-gui-plot-splot-fit + gnuplot-gui-test-type + )) + + +(defun gnuplot-gui-swap-simple-complete () + (interactive) + (setq gnuplot-gui-plot-splot-fit-style + (if (equal gnuplot-gui-plot-splot-fit-style 'complete) + 'simple 'complete)) + (if (equal gnuplot-gui-plot-splot-fit-style 'complete) + (progn + (setcdr (assoc "plot" gnuplot-gui-all-types) gnuplot-gui-plot-full-list) + (setcdr (assoc "splot" gnuplot-gui-all-types) gnuplot-gui-splot-full-list) + (setcdr (assoc "fit" gnuplot-gui-all-types) gnuplot-gui-fit-full-list)) + (setcdr (assoc "plot" gnuplot-gui-all-types) gnuplot-gui-plot-simple-list) + (setcdr (assoc "splot" gnuplot-gui-all-types) gnuplot-gui-splot-simple-list) + (setcdr (assoc "fit" gnuplot-gui-all-types) gnuplot-gui-fit-simple-list)) + (message "Using %s lists for plot, splot, and fit." + gnuplot-gui-plot-splot-fit-style) ) + + + + +;;; user interface to the widget-y stuff + +(defun gnuplot-gui-mouse-set (event) + "Use the mouse to begin setting options using a GUI interface. +EVENT is a mouse event. Bound to \\[gnuplot-gui-mouse-set] +Note that \"plot\", \"splot\", \"fit\", and \"cntrparam\" are not +currently supported." + (interactive "@e") + (when (fboundp 'widget-create) + (save-excursion + (mouse-set-point event) + (gnuplot-gui-set-options-and-insert)))) + +(defun gnuplot-gui-get-frame-param (param) + (if gnuplot-xemacs-p + (plist-get gnuplot-gui-frame-plist param) + (cdr (assoc param gnuplot-gui-frame-parameters)))) +(defun gnuplot-gui-set-frame-param (param value) + (if gnuplot-xemacs-p + (plist-put gnuplot-gui-frame-plist param value) + (setcdr (assoc param gnuplot-gui-frame-parameters) value))) + +(defun gnuplot-gui-set-options-and-insert () + "Insert arguments using a GUI interface. +Determine contents of current line and set up the appropriate GUI +frame. Bound to \\[gnuplot-gui-set-options-and-insert] +Note that \"cntrparam\" is not currently supported." + (interactive) + (when (fboundp 'widget-create) + (let ((begin (gnuplot-point-at-beginning-of-command)) + (end (save-excursion (end-of-line) (point-marker))) + (termin (concat "\\(,\\s-*" (regexp-quote "\\") "\\|;\\)")) + (set nil) (term nil)) + (save-excursion + ;; there can be more then one command per line + (if (re-search-forward termin end "to_limit") + (progn (backward-char (length (match-string 1))) + (setq end (point-marker)))) + (goto-char begin) + (skip-syntax-forward "-" end) + ;; various constructions are recognized here. at the end of this + ;; cond, point should be just after the word whose arguments are + ;; to be set + (cond ((looking-at "set\\s-+") + (setq set t) + (goto-char (match-end 0)) + (if (looking-at "\\sw+") (goto-char (match-end 0))) + (when (string-match "^ter" (gnuplot-this-word)) ; terminal? + (setq term t) + (forward-word 1)) + (when (string-match "^\\(da\\|fu\\)" (gnuplot-this-word)) + (unless (looking-at "\\s-+st") + (insert " style") (forward-word 1)) + (forward-word 1))) + ((looking-at (concat "\\(cd\\|ca\\|lo\\|pa\\|pr\\|sa\\|u\\)" + "\\w*" + "[\\s-\\']")) + (forward-word 1)) + ;;(goto-char (match-end 0))) + (t + (forward-word 1))) + (if (> (point) end) (goto-char end)) + (let* ((w (gnuplot-this-word)) + (wd (try-completion w gnuplot-gui-all-types)) + (word "") wrd list) + (cond ((equal wd t) (setq word w)) + ((equal wd nil) (setq word w)) + ((assoc wd gnuplot-gui-all-types) (setq word wd)) + (t (setq wd nil))) + (cond ((equal (string-match "^\\s-*$" w) 0) + (message "Blank line")) + ((and wd (stringp word)) + (gnuplot-gui-correct-command word set term begin) + (setq gnuplot-gui-alist nil + gnuplot-gui-current-string + (buffer-substring-no-properties (point) end)) + (gnuplot-gui-set-alist word gnuplot-gui-current-string) + (let* ((old-height (gnuplot-gui-get-frame-param 'height)) + (old-top (gnuplot-gui-get-frame-param 'top))) + (when (or + (and (equal gnuplot-gui-plot-splot-fit-style 'complete) + (member* word '("plot" "splot" "fit") + :test 'string=)) + (equal word "test")) + (gnuplot-gui-set-frame-param 'height 32) + (gnuplot-gui-set-frame-param 'top 50)) + (gnuplot-gui-prompt-for-frame word) + (when (or + (and (equal gnuplot-gui-plot-splot-fit-style 'complete) + (member* word '("plot" "splot" "fit") + :test 'string=)) + (equal word "test")) + (gnuplot-gui-set-frame-param 'height old-height) + (gnuplot-gui-set-frame-param 'top old-top)) )) + ((setq wrd (car (all-completions w '(("cntrparam"))))) + (message + "Setting arguments for %S is currently unsuported in gnuplot-mode" + wrd)) + ((setq list (all-completions w gnuplot-gui-all-types)) + (message "%S could be one of %S" w list)) + (t + (message + "%S is not a gnuplot command which takes options" w)))) )))) + +(defun gnuplot-gui-toggle-popup () + (interactive) + (setq gnuplot-gui-popup-flag (not gnuplot-gui-popup-flag)) + (message (if gnuplot-gui-popup-flag + "Argument popup will appear after insertions." + "Argument popup will no longer appear after insertions."))) + + +(defun gnuplot-gui-y-n (foo)) +(if gnuplot-xemacs-p + (defalias 'gnuplot-gui-y-n 'y-or-n-p-maybe-dialog-box) + (defalias 'gnuplot-gui-y-n 'y-or-n-p)) + +(defun gnuplot-gui-correct-command (word set term begin) + "Check syntax of set command and terminal specifications. +WORD is the item being set. SET and TERM are non-nil if the words +\"set\" and \"terminal\" were found preceding WORD in the buffer. +BEGIN is the beginning of the command." + (save-excursion + (cond ((assoc word gnuplot-gui-terminal-types) + (when (and (not (and set term)) + (gnuplot-gui-y-n + (format + "%S must be preceded by \"set terminal\". Add it? " + word))) + (backward-word 1) + (let ((e (point-marker))) + (goto-char begin) + (skip-syntax-forward "-" e) + (delete-region (point) e) + (insert "set terminal ")))) + ((assoc word gnuplot-gui-set-types) + (when (and (not set) + (gnuplot-gui-y-n + (format + "%S must be preceded by \"set\". Add \"set\"? " word))) + (backward-word 1) + (let ((e (point-marker))) + (goto-char begin) + (skip-syntax-forward "-" e) + (delete-region (point) e) + (insert "set ")))))) + (message nil)) + + + +;;; handle the actual arguments + +(defun gnuplot-gui-fix-arg-list (list) + "Correct the result of splitting `gnuplot-gui-current-string'. +LIST is the split string. This removes empty and all-blank strings +from the list and concatenates the strings that are part of a quoted +argument, for example an axis label or a font name. It also replaces +bounding single quotes with double quotes, since double quotes are +used in `gnuplot-gui-all-types'." + (let (fixed-list quote quoted) ; remove blanks + (setq list (remove* "\\s-+" list :test 'string-match) + list (remove* "" list :test 'string=)) + (while list ; concatinate parts of quoted string + (if (not (string-match "^\\([\]\[()'\"]\\)" (car list))) + (setq fixed-list (append fixed-list (list (car list)))) + (setq quote (match-string 1 (car list)) + quoted (car list)) + (if (string= quote "[") (setq quote "]")) + (if (string= quote "(") (setq quote ")")) + (while (and list + (or (equal (length quoted) 1) + (not (string-match (concat (regexp-quote quote) "$") + quoted)))) + (setq quoted (concat quoted " " (cadr list)) + list (cdr list))) + (if (string= quote "'") + (setq quoted (concat "\"" (substring quoted 1)) + quoted (concat (substring quoted 0 -1) "\""))) + (setq fixed-list (append fixed-list (list quoted)))) + (setq list (cdr list)) ) + fixed-list)) + +(defun gnuplot-gui-set-alist (word string) + "Set defaults for arguments, using text from buffer if appropriate. +WORD is the Gnuplot expression whose arguments are being set. STRING +is text from the buffer containing the previous values for WORD's +arguments." + (let ((alist (cdr (assoc word gnuplot-gui-all-types))) + (arg-list (gnuplot-gui-fix-arg-list (split-string string)) )) + ;; arg-list contains the arguments taken from the buffer + (setq gnuplot-gui-alist nil) + (while alist + (let* ((list (car alist)) + (tag (gnuplot-gui-type-tag list)) + (symbol (eval (gnuplot-gui-type-symbol list))) + (default (gnuplot-gui-type-default list)) + (prefix (gnuplot-gui-type-prefix list)) + (values (gnuplot-gui-type-list list)) + (this-cons (cond ((stringp default) (cons tag default)) + ((consp default) ; set cons valued default w/care + (cons tag (cons (car default) (cdr default)))) + (t (cons tag default)))) + (temp-list arg-list) ) + ;;(message "%S" temp-list) ; want to lop values off arg-list + ; as they are found + (if (symbolp (cadr values)) + (setq values (symbol-value (cadr values)))) + ;; check if an argument of this type is in arg-list + ;; set the current cons cell if it is + (while temp-list + (cond + ;; ---------------------------- list + ((member* symbol '(list list*) :test 'equal) + (let* ((case-fold-search nil) + (match-cons (member* (concat "^" (car temp-list)) + values :test 'string-match))) + (if (and (car match-cons) ; " " may be first elem. of list + (not (string= " " (car match-cons)))) + (setq this-cons (cons tag (car match-cons)) + arg-list (remove* (car temp-list) arg-list + :test 'string= :count 1) + temp-list nil) + (setq temp-list (cdr temp-list))))) + ;; ---------------------------- tag (first number in list) + ((equal symbol 'tag) + (if (string-match "^[-0-9.]+$" (car arg-list)) + (setq this-cons (cons tag (car arg-list)) + temp-list nil) + (setq temp-list (cdr temp-list))) ) + ;; ---------------------------- fontsize (last number in list) + ((equal symbol 'fontsize) + (if (string-match "^[-0-9.]+$" (car (last arg-list))) + (setq this-cons (cons tag (car (last arg-list))) + temp-list nil) + (setq temp-list (cdr temp-list))) ) + ;; ---------------------------- number with prefix + ((equal symbol 'number) + (cond ((and (string= prefix (car temp-list)) + (string-match "^[-0-9.]+$" (cadr temp-list))) + (setq this-cons (cons tag (cadr temp-list)) + arg-list (remove* (car temp-list) arg-list + :test 'string= :count 1) + arg-list (remove* (cadr temp-list) arg-list + :test 'string= :count 1) + temp-list nil)) + ;; --------------------- number without prefix + ((and (not prefix) + (string-match "^[-0-9.]+$" (car temp-list))) + (setq this-cons (cons tag (car temp-list)) + arg-list (remove* (car temp-list) arg-list + :test 'string= :count 1) + temp-list nil)) + (t + (setq temp-list (cdr temp-list))))) + ;; ---------------------------- pair with prefix + ((equal symbol 'pair) + (if (and (string= prefix (car temp-list)) + (string-match "^[-0-9.]+$" (cadr temp-list))) + (let ((this-car (cadr temp-list)) + (this-cdr (if (string-match "^[-0-9.]+$" (caddr temp-list)) + (caddr temp-list) ""))) + (setq this-cons (cons tag (cons this-car this-cdr)) + temp-list nil)) + (setq temp-list (cdr temp-list)))) + ;; ---------------------------- range + ((equal symbol 'range) + (if (string-match (concat "\\[\\s-*" ; opening bracket + "\\([^:, \t]*\\)" ; first argument + "\\s-*[:,]\\s-*" ; separator + "\\([^\] \t]*\\)" ; second argument + "\\s-*\\]") ; closing bracket + (car temp-list)) + (setq this-cons + (cons tag (cons (match-string 1 (car temp-list)) + (match-string 2 (car temp-list)))) + arg-list (remove* (car temp-list) arg-list + :test 'string= :count 1) + temp-list nil) + (setq temp-list (cdr temp-list)) )) + ;; ---------------------------- labels + ((equal symbol 'labels) + (if (string-match (concat "(" ; opening paren + "\\([^\)]*\\)" ; string + ")") ; closing paren + (car temp-list)) + (let* ((list (split-string (car temp-list) "[ \t(),]+")) + (list (remove* "" list :test 'string=)) + (return ())) + (while list + (if (string-match "['\"]\\([^'\"]*\\)['\"]" (car list)) + (setq return (append return + (list (match-string 1 (car list)))) + list (cdr list) + return (append return (list (car list))) ) + (setq return (append return (list "" (car list))))) + (setq list (cdr list)) ) + (setq this-cons (cons tag return) + arg-list (remove* (car temp-list) arg-list + :test 'string= :count 1) + temp-list nil)) + (setq temp-list (cdr temp-list))) ) + ;; ---------------------------- string, file, format + ((member* symbol '(string file format) :test 'equal) + (if (string-match (concat "['\"]" ; opening quote + "\\([^'\"]*\\)" ; string + "['\"]") ; closing quote + (car temp-list)) + (setq this-cons (cons tag (match-string 0 (car temp-list))) + arg-list (remove* (car temp-list) arg-list + :test 'string= :count 1) + temp-list nil) + (setq temp-list (cdr temp-list)) )) + ;; ---------------------------- string* + ((equal symbol 'string*) + (if (string= prefix (car temp-list)) + (setq this-cons (cons tag (cadr temp-list)) + arg-list (remove* (car temp-list) arg-list + :test 'string= :count 1) + arg-list (remove* (cadr temp-list) arg-list + :test 'string= :count 1) + temp-list nil) + (setq temp-list (cdr temp-list)) ) ) + ;; ---------------------------- other or unknown + (t + (setq temp-list nil)) + )) + (setq gnuplot-gui-alist + (append gnuplot-gui-alist (list this-cons)))) + (setq alist (cdr alist))) )) + + +(defun gnuplot-gui-post-process-alist (type) + "A few types need some additional processing. +'range, 'pair, and 'labels are cons or list valued and need to b made +into strings. This is called right before inserting the arguments +into the buffer. TYPE is the object whose arguments are being set." + (let ((alist gnuplot-gui-alist) + (types (cdr (assoc type gnuplot-gui-all-types))) ) + (while alist ;; loop thru alist looking for tyeps needing post-processing + (let* ((list (assoc (caar alist) types)) + (value (cdr (assoc (caar alist) gnuplot-gui-alist))) + (prefix (gnuplot-gui-type-prefix list)) + (symb (gnuplot-gui-type-symbol list)) ) + (cond + ;;-------------------------- flat text + ((equal (eval symb) 'text) + (setcdr (assoc (caar alist) gnuplot-gui-alist) "")) + ;;-------------------------- range [#:#] or [#,#] + ((equal (eval symb) 'range) + (if (and (string-match "^\\s-*$" (car value)) + (string-match "^\\s-*$" (cdr value))) + (setcdr (assoc (caar alist) gnuplot-gui-alist) "") + (setcdr (assoc (caar alist) gnuplot-gui-alist) + (concat "[" (car value) prefix (cdr value) "]")) ) ) + ;;-------------------------- pair + ((equal (eval symb) 'pair) + (if (and (string-match "^\\s-*$" (car value)) + (string-match "^\\s-*$" (cdr value))) + (setcdr (assoc (caar alist) gnuplot-gui-alist) "") + (setcdr (assoc (caar alist) gnuplot-gui-alist) + (concat prefix " " (car value) " " (cdr value) )) ) ) + ;;-------------------------- labels + ((equal (eval symb) 'labels) + (if (consp value) + (let ((word "") (list value)) + (while list + (if (string-match "^\\s-*$" (car list)) + (setq word (concat word (format "%s, " (cadr list)))) + (setq word (concat word (format "%S %s, " (car list) + (cadr list))))) + (setq list (cddr list)) ) + (setq value (concat "(" (substring word 0 -2) ")"))) + (setq value "") ) + (setcdr (assoc (caar alist) gnuplot-gui-alist) value) )) + + (setq alist (cdr alist))) ))) + + +;;; GUI frames + +(defun gnuplot-gui-prompt-for-frame (&optional option save-frame) + (setq option (or option (completing-read "Option: " gnuplot-gui-all-types + nil t nil t))) + (gnuplot-gui-make-frame + option (cdr (assoc option gnuplot-gui-all-types)) save-frame) ) + + +(defface gnuplot-gui-error-face '((((class color) (background light)) + (:foreground "grey30")) + (((class color) (background dark)) + (:foreground "grey70"))) + "Face used to display message about unknown widget types." + :group 'gnuplot-faces) + +(defface gnuplot-gui-flat-text-face '((((class color) (background light)) + (:foreground "MediumBlue")) + (((class color) (background dark)) + (:foreground "LightSteelBlue"))) + "Face used to display message about unknown widget types." + :group 'gnuplot-faces) + +(defun gnuplot-gui-make-frame (item alist &optional save-frame) + "Open the frame and populate it with widgets. +ITEM is the object for which arguments are being set. ALIST is +the alist of arguments for ITEM taken from `gnuplot-gui-all-types'. +SAVE-FRAME is non-nil when the widgets are being reset." + (unless save-frame + (setq gnuplot-current-frame (selected-frame) + gnuplot-current-buffer (current-buffer) + gnuplot-current-buffer-point (point-marker)) + (unless (and gnuplot-gui-frame (frame-live-p gnuplot-gui-frame)) + (setq gnuplot-gui-frame (if gnuplot-xemacs-p + (make-frame gnuplot-gui-frame-plist) + (make-frame gnuplot-gui-frame-parameters)))) + (select-frame gnuplot-gui-frame) + ;;(set-frame-position gnuplot-gui-frame 150 150) ;; so herky-jerky + (if gnuplot-xemacs-p + (set-mouse-position (selected-window) 0 0) + (set-mouse-position gnuplot-gui-frame 0 0))) + (kill-buffer (get-buffer-create "*Gnuplot GUI*")) + (switch-to-buffer (get-buffer-create "*Gnuplot GUI*")) + (kill-all-local-variables) + (if gnuplot-xemacs-p + (progn + (set (make-local-variable 'frame-title-format) + "Set Gnuplot Options") + (set (make-local-variable 'frame-icon-title-format) + "Set Gnuplot Options")) + (modify-frame-parameters (selected-frame) + '((title . "Set Gnuplot Options"))) ) + (widget-insert "\nSet options for \"" item "\" ") + (let (tag help val) + (cond ((string-match "^[xyz]2?tics" item) + (setq tag "info on tic labels" + help "Open a frame displaying the info entry for tic labels" + val "xtics")) + ((string-match "^no" item) + (setq tag (concat "info on " (substring item 2)) + help (format "Open a frame displaying the info entry for %S" + item) + val item)) + (t + (setq tag (concat "info on " item) + help (format "Open a frame displaying the info entry for %S" + item) + val item))) + (widget-create 'gnuplot-gui-info-link :tag tag :help-echo help :value val)) + + (widget-insert "\n\n") + (while alist + (let* ((this (car alist)) + (tag (gnuplot-gui-type-tag this)) + (wtype (gnuplot-gui-type-symbol this)) + (prefix (gnuplot-gui-type-prefix this)) + (default (cdr (assoc tag gnuplot-gui-alist))) + (list (gnuplot-gui-type-list this))) + (if (symbolp (cadr list)) + (setq list (symbol-value (cadr list)))) + (widget-insert "\t") ; insert the appropriate widget + (cond + ;;------------------------------ list, list* ------------ + ((member* (eval wtype) '(list list*) :test 'equal) + (let ((starred (if (equal (eval wtype) 'list*) t nil))) + (gnuplot-gui-menu-choice tag default list starred))) + ;;------------------------------ number, tag, fontsize -- + ((member* (eval wtype) '(number tag fontsize) :test 'equal) + (gnuplot-gui-number tag default prefix)) + ;;------------------------------ position --------------- + ;;------------------------------ range, pair ------------ + ((member* (eval wtype) '(range pair) :test 'equal) + (let ((is-range (equal (eval wtype) 'range))) + (gnuplot-gui-range tag default prefix is-range))) + ;;------------------------------ string, string* -------- + ((member* (eval wtype) '(string string*) :test 'equal) + (let ((starred (if (equal (eval wtype) 'string) nil t))) + (gnuplot-gui-string tag default prefix starred))) + ;;------------------------------ format ----------------- + ((equal (eval wtype) 'format) + (gnuplot-gui-format tag default)) + ;;------------------------------ file ------------------- + ((equal (eval wtype) 'file) + (gnuplot-gui-file tag default prefix)) + ;;------------------------------ labels ----------------- + ((equal (eval wtype) 'labels) + (gnuplot-gui-labels tag default)) + ;;------------------------------ text ------------------- + ((equal (eval wtype) 'text) + (let ((str (gnuplot-gui-type-default this))) + (put-text-property 0 (length str) 'face 'gnuplot-gui-flat-text-face str) + (widget-insert str "\n"))) + ;;------------------------------ unknown ---------------- + (t + (let ((str (concat "<" (downcase tag) "> ('" + (symbol-name (eval wtype)) + " arguments are not yet supported)\n"))) + (put-text-property 0 (length str) 'face 'gnuplot-gui-error-face str) + (widget-insert str)) ))) + (setq alist (cdr alist))) + ;; insert control buttons: [Set options] [Reset] [Clear] [Cancel] + (widget-insert "\n\t") + (widget-create 'push-button + :value "Set options" + :doc item + :button-face 'gnuplot-gui-button-face + :help-echo "Push this button to set options" + :notify + (lambda (widget &rest ignore) + (kill-buffer (get-buffer-create "*Gnuplot GUI*")) + (delete-frame) + (select-frame gnuplot-current-frame) + (switch-to-buffer gnuplot-current-buffer) + (goto-char gnuplot-current-buffer-point) + (gnuplot-gui-post-process-alist + (widget-get widget :doc)) + (let ((alist gnuplot-gui-alist) marker + (eol (save-excursion (end-of-line) (point-marker) )) ) + (if (re-search-forward ";" eol "to_limit") + (backward-char 1)) + (delete-region gnuplot-current-buffer-point (point-marker)) + (delete-horizontal-space) + (setq marker (point-marker)) + (while alist + (let ((val (cdar alist))) + (if (string-match "^\\s-+$" val) () + (if (string-match "^['\"]\\(.*\\)['\"]$" val) + (setq val (concat gnuplot-quote-character + (match-string 1 val) + gnuplot-quote-character))) + (insert (format " %s" val)))) + (setq alist (cdr alist))) + (setq eol (point-marker)) + (goto-char marker) + (while (< (point) eol) ; a few odd cases + (unless (looking-at (concat "[" (regexp-quote "(") + (regexp-quote "*") ",]")) + (just-one-space)) + (forward-sexp))) + (delete-horizontal-space) + (if (string= "terminal" (widget-get widget :doc)) + (gnuplot-gui-set-options-and-insert)) )) + (widget-insert " ") + (widget-create 'push-button :value "Reset" + :help-echo "Push this button to reset all values" + :button-face 'gnuplot-gui-button-face + :doc item + :notify + (lambda (widget &rest ignore) + (let ((word (widget-get widget :doc))) + (gnuplot-gui-set-alist word gnuplot-gui-current-string) + (gnuplot-gui-prompt-for-frame word t)))) + (widget-insert " ") + (widget-create 'push-button :value "Clear" + :help-echo "Push this button to clear all values" + :button-face 'gnuplot-gui-button-face + :doc item + :notify + (lambda (widget &rest ignore) + (let* ((word (widget-get widget :doc)) + (alist (cdr (assoc word gnuplot-gui-all-types)))) + (while alist + (setcdr (assoc (gnuplot-gui-type-tag (car alist)) + gnuplot-gui-alist) + (gnuplot-gui-type-default (car alist))) + (setq alist (cdr alist))) + (gnuplot-gui-prompt-for-frame word t))) ) + (widget-insert " ") + (widget-create 'push-button :value "Cancel" + :help-echo "Quit setting options and dismiss frame" + :button-face 'gnuplot-gui-button-face + :notify (lambda (widget &rest ignore) + (kill-buffer (get-buffer-create "*Gnuplot GUI*")) + (setq gnuplot-gui-alist nil + gnuplot-gui-current-string nil) + (delete-frame) + (select-frame gnuplot-current-frame))) + (goto-char (point-min)) + (use-local-map widget-keymap) + (widget-setup)) + + +;;; widgets + +(defface gnuplot-gui-menu-face '((((class color) (background light)) + (:bold t :foreground "darkolivegreen")) + (((class color) (background dark)) + (:bold t :foreground "seagreen")) + (t + (:italic t))) + "Face used for menu-buttons." + :group 'gnuplot-faces) +(defface gnuplot-gui-button-face '((((class color) (background light)) + (:bold t :foreground "sienna")) + (((class color) (background dark)) + (:bold t :foreground "tan")) + (t + (:italic t))) + "Face used for push-buttons. +Only used in Emacs. XEmacs displays push-buttons with a pixmap." + :group 'gnuplot-faces) +(defface gnuplot-gui-labels-face '((((class color) (background light)) + (:bold t :foreground "darkslateblue")) + (((class color) (background dark)) + (:bold t :foreground "lightslateblue")) + (t + (:italic t))) + "Face used for insert and delete button in the labels widget." + :group 'gnuplot-faces) + +(defun gnuplot-gui-menu-choice (item default list &optional starred) + "Create a menu widget for the Gnuplot GUI. +ITEM is the object whose arguments are set by this widget, DEFAULT +is the default argument value, LIST contains the items for the pop-up +menu. STARRED is true if this a 'list* widget." + (let ((widget + (apply 'widget-create + 'menu-choice :value default :tag item :doc starred + :button-face 'gnuplot-gui-menu-face + :button-prefix "[" :button-suffix "]" + :help-echo (format "Mouse-2 to view the %S menu" (downcase item)) + :notify + (lambda (widget &rest ignore) + (let ((lab (if (widget-get widget :doc) + (concat (downcase (widget-get widget :tag)) " ") + "" ))) + (setcdr (assoc (widget-get widget :tag) gnuplot-gui-alist) + (if (string= (widget-value widget) " ") "" + (format "%s%s" lab (widget-value widget))) ))) + (mapcar (lambda (x) (list 'item :value x)) + list)))) + (widget-value-set widget default) + (if (and starred (not (string-match "^\\s-*$" default))) + (setcdr (assoc item gnuplot-gui-alist) + (format "%s %s" (downcase item) default))) + widget)) + +(defun gnuplot-gui-number (item default &optional prefix) + "Create a number widget for the Gnuplot GUI. +ITEM is the object whose arguments are set by this widget, DEFAULT +is the default value for the widget, PREFIX is a text string preceding +the numerical argument." + (let ((help-label (or prefix (downcase item)))) + (widget-insert (capitalize item) ": ") + (widget-create 'editable-field + :size 2 :tag item :value default :doc prefix + :help-echo (format "Insert new value of %S here" help-label) + :notify (lambda (widget &rest ignore) + (let ((val (widget-value widget)) + (pre (concat (widget-get widget :doc) " "))) + (setcdr (assoc (widget-get widget :tag) + gnuplot-gui-alist) + (if (string-match + "^\\s-*[-0-9.*]+\\s-*$" val) + (format "%s%s" pre val) "") ))))) + (unless (string-match "^\\s-*$" default) + (setcdr (assoc item gnuplot-gui-alist) (format "%s %s" prefix default))) + (widget-insert " " (make-string (- 40 (current-column)) ?.) + " (numeric value)\n")) + +(defun gnuplot-gui-string (item default &optional width_or_prefix starred) + "Create a string widget for the Gnuplot GUI. +ITEM is the object whose arguments are set by this widget, DEFAULT is +the default value for the widget, and WIDTH_OR_PREFIX is the width of +the text entry field (which defaults to half the frame width) or the +prefix for the string. STARRED is t if quotes are not to be used." + (let ((help-label (downcase item)) width (prefix "") (pp "")) + (cond ((stringp width_or_prefix) + (setq prefix width_or_prefix + pp prefix) + (if starred (setq prefix (concat prefix "_star"))) ) + ((numberp width_or_prefix) + (setq width width_or_prefix))) + (setq width (or width (/ (frame-width) 2))) + (if (string-match "^['\"]" default) + (setq default (replace-match "" nil nil default))) + (if (string-match "['\"]$" default) + (setq default (replace-match "" nil nil default))) + (widget-insert (capitalize item) ": ") + (widget-create + 'editable-field + :size width :tag item :doc prefix :value default + :help-echo (format "Insert new value of %S here" help-label) + :notify (lambda (widget &rest ignore) + (let ((val (widget-value widget)) + (q gnuplot-quote-character) + (p (widget-get widget :doc)) ) + (setcdr (assoc (widget-get widget :tag) gnuplot-gui-alist) + (if (string-match "^\\s-*$" val) + "" + (progn + (if (string-match "_star$" p) + (setq p (concat (substring p 0 -5) " ") + q "")) + (if (string-match "^\\s-+" val) + (setq val (replace-match "" nil nil val))) + (if (string-match "\\s-+$" val) + (setq val (replace-match "" nil nil val))) + (format "%s%s%s%s" p q val q))))))) + (unless (string-match "^\\s-*$" default) + (setcdr (assoc item gnuplot-gui-alist) (format "%s %s" pp default))) + (widget-insert "\n"))) + +(defun gnuplot-gui-format (item default) + "Create a string widget for the Gnuplot GUI. +ITEM is the object whose arguments are set by this widget, DEFAULT is +the default value for the widget, and WIDTH_OR_PREFIX is the width of +the text entry field (which defaults to half the frame width) or the +prefix for the string." + (if (string-match "^['\"]" default) + (setq default (replace-match "" nil nil default))) + (if (string-match "['\"]$" default) + (setq default (replace-match "" nil nil default))) + (widget-insert (capitalize item) ": ") + (widget-create 'editable-field + :size (/ (frame-width) 3) :tag item :value default + :help-echo (format "Insert new format string here") + :notify (lambda (widget &rest ignore) + (let ((val (widget-value widget))) + (setcdr (assoc (widget-get widget :tag) + gnuplot-gui-alist) + (format "%s%s%s" + gnuplot-quote-character + val + gnuplot-quote-character))))) + (widget-insert " ") + (widget-create 'gnuplot-gui-info-link + :tag (concat "info on format") + :help-echo "Open a frame displaying the info entry for format" + :value "format") + (widget-insert "\n")) + + +;; swiped from widget-color-complete +(defun gnuplot-gui-file-completion (widget) + "Complete the filename in WIDGET." + (let* ((str (buffer-substring-no-properties (widget-field-start widget) + (point))) + (file (or (file-name-nondirectory str) "")) + (dir (or (file-name-directory str) "./")) + (val (file-name-completion file dir)) ) + (cond ((eq val t) + (message "Exact match")) + ((null val) + (error "Can't find completion for \"%s\"" str)) + ((not (string-equal str val)) + (insert (substring val (length file)))) + (t + (message "Making completion list...") + (let ((list (file-name-all-completions file dir))) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list list))) + (message "Making completion list...done"))))) + +(defun gnuplot-gui-file (item default &optional tag) + "Create a file widget for the Gnuplot GUI. +ITEM is the object whose arguments is set by this widget, DEFAULT is +the default value for the argument. TAG is non-nil if ITEM rather than +\"File:\" is to be used as the tag." + (setq tag (if tag (capitalize item) "File")) + (if (string-match "^['\"]" default) + (setq default (replace-match "" nil nil default))) + (if (string-match "['\"]$" default) + (setq default (replace-match "" nil nil default))) + (let ((widg (widget-create + 'file + :value default :tag tag + :size (- (/ (frame-width) 2) 3) + :doc item :help-echo "Insert a filename here" + :complete 'gnuplot-gui-file-completion + :notify + (lambda (widget &rest ignore) + (setcdr (assoc (widget-get widget :doc) gnuplot-gui-alist) + (format "%s%s%s" gnuplot-quote-character + (widget-value widget) + gnuplot-quote-character)) )) )) + (widget-insert " ") + (widget-create + 'push-button :value "Browse" + :doc item :help-echo "Browse directories for a filename." + :parent widg + :notify (lambda (widget &rest ignore) + (let ((fname (file-relative-name (read-file-name "File: ") + default-directory)) + (q gnuplot-quote-character)) + (widget-value-set (widget-get widget :parent) fname) + (setcdr (assoc (widget-get widget :doc) gnuplot-gui-alist) + (format "%s%s%s" q fname q)) + (widget-setup)))) + (widget-insert "\n"))) + +(defun gnuplot-gui-labels (item default) + "Create a labels widget for the Gnuplot GUI. +ITEM is the object whose arguments is set by this widget, DEFAULT is +the default value for the argument." + (widget-create + '(editable-list + (list :inline t :tag "Tic label" + (string :tag "label" :size 10 + :help-echo "Enter the tic label here" ) + (string :tag " position" :size 10 + :help-echo "Enter an expression for the tic location here" ))) + :tag (capitalize item) + :value default + :format "%{%t%}:\n%v\t %i\n" + :entry-format "\t %i %d %v\n" + :button-face 'gnuplot-gui-labels-face + :notify (lambda (widget &rest ignore) + (setcdr (assoc (upcase (widget-get widget :tag)) + gnuplot-gui-alist) + (widget-value widget))))) + +(defun gnuplot-gui-range (item default separator is-range) + "Create a range or pair widget for the Gnuplot GUI. +ITEM is the object whose arguments are set by this widget, DEFAULT is +the default value for the widget, SEPARATOR is a text string preceding +the numerical argument, or the prefix for a pair operator. IS-RANGE +is non-nil if this is a 'range widget." + (widget-insert (capitalize item) ": ") + (if is-range (widget-insert "[")) + (widget-create 'editable-field + :size 4 :tag item :value (car default) + :help-echo (format "Insert the first value of the %S here" + (downcase item)) + :notify (lambda (widget &rest ignore) + (setcar (cdr (assoc (widget-get widget :tag) + gnuplot-gui-alist)) + (format "%s" (widget-value widget))))) + (if is-range (widget-insert separator) (widget-insert " ")) + (widget-create 'editable-field + :size 4 :tag item :value (cdr default) + :help-echo (format "Insert the second value of the %S here" + (downcase item)) + :notify (lambda (widget &rest ignore) + (setcdr (cdr (assoc (widget-get widget :tag) + gnuplot-gui-alist)) + (format "%s" (widget-value widget))))) + (if is-range (widget-insert "]")) + (widget-insert " " (make-string (- 39 (current-column)) ?.) + " (numeric values)\n")) + + +;; suppress compiler warning +;;(eval-when-compile (defun gnuplot-info-lookup-symbol (sym mode))) +(define-widget 'gnuplot-gui-info-link 'info-link + "A link to an info file for the Gnuplot GUI." + :action '(lambda (widget &optional event) + (let ((gnuplot-info-display 'frame)) + (if gnuplot-keywords-pending ; + (gnuplot-setup-info-look)) + (gnuplot-info-lookup-symbol (widget-value widget) + 'gnuplot-mode)))) + + +;;; just about done + +(provide 'gnuplot-gui) +;;;============================================================================ +;;; +;;; gnuplot-gui.el ends here diff --git a/elpa/gnuplot-20141231.1337/gnuplot-pkg.el b/elpa/gnuplot-20141231.1337/gnuplot-pkg.el new file mode 100644 index 00000000..2061697f --- /dev/null +++ b/elpa/gnuplot-20141231.1337/gnuplot-pkg.el @@ -0,0 +1,5 @@ +(define-package "gnuplot" "20141231.1337" "drive gnuplot from within emacs" 'nil :keywords + '("gnuplot" "plotting")) +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/gnuplot-20141231.1337/gnuplot.el b/elpa/gnuplot-20141231.1337/gnuplot.el new file mode 100644 index 00000000..3b50c7fa --- /dev/null +++ b/elpa/gnuplot-20141231.1337/gnuplot.el @@ -0,0 +1,3352 @@ +;;; gnuplot.el --- drive gnuplot from within emacs + +;; Copyright (C) 1998, 2011 Phil Type and Bruce Ravel, 1999-2012 Bruce Ravel + +;; Author: Bruce Ravel and Phil Type +;; Maintainer: Bruce Ravel +;; Created: June 28 1998 +;; Updated: November 1 2012 +;; Version: 0.7.0 +;; Keywords: gnuplot, plotting + +;; 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 2, or (at your option) +;; any later version. +;; +;; This lisp script is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +;; +;; Permission is granted to distribute copies of this lisp script +;; provided the copyright notice and this permission are preserved in +;; all copies. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, you can either send email to this +;; program's maintainer or write to: The Free Software Foundation, +;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; send bug reports to the author (bruceravel1@gmail.com) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Commentary: + +;; +;; This is a major mode for composing gnuplot scripts and displaying +;; their results using gnuplot. It supports features of recent +;; Gnuplot versions (4.4 and up), but should also work fine with older +;; versions. +;; +;; This version of gnuplot-mode has been tested mostly on GNU Emacs 23 +;; and 24, but should also work with older GNU Emacs versions back to +;; Emacs 21, and XEmacs 21. +;; +;; This mode offers several tools to help you compose your scripts, +;; including font-lock syntax colorization, a syntax table appropriate +;; to gnuplot, key bindings, pull-down menus, indentation, keyword +;; completions and variable customization using the Custom package. +;; Once the script is composed, there are several function for sending +;; some or all of the script to gnuplot. The interaction with the +;; gnuplot process is within a comint buffer. Plots can optionally be +;; displayed within Emacs. +;; +;; C-c C-l send current line to gnuplot +;; C-c C-v send current line to gnuplot and move forward 1 line +;; C-c C-r send current region to gnuplot +;; C-c C-b send entire buffer to gnuplot +;; C-c C-f send a file to gnuplot +;; C-c C-i insert filename at point +;; C-c C-n negate set option on current line +;; C-c C-c comment region +;; C-c C-o set arguments for command at point +;; S-mouse-2 set arguments for command under mouse cursor +;; C-c C-d read the gnuplot info file +;; C-c C-e show-gnuplot-buffer +;; C-c C-k kill gnuplot process +;; C-c C-u submit a bug report about gnuplot-mode +;; C-c C-z customize gnuplot-mode +;; M-tab or M-ret complete keyword before point +;; ret newline and indent +;; tab indent current line +;; C-c M-i toggle inline plot display in comint buffer +;; +;; With the exception of the commands for sending commands to Gnuplot, +;; most of the above commands also work in the Gnuplot comint buffer, +;; in addition to the following: +;; M-C-p plot the most recent script buffer line-by-line +;; M-C-f save the current script buffer and load that file +;; C-c C-e pop back to most recent script buffer +;; +;; These two functions are useful for starting up gnuplot-mode: +;; +;; M-x gnuplot-mode +;; start gnuplot-mode in the current buffer +;; +;; M-x gnuplot-make-buffer +;; open a new buffer (which is not visiting a file) and start +;; gnuplot-mode in that buffer +;; +;; Gnuplot-mode now includes context-sensitive support for keyword +;; completion and, optionally, eldoc-mode help text. See the +;; commentary in gnuplot-context.el for more information. If you +;; don't find it useful, it can be turned off by customizing +;; `gnuplot-context-sensitive-mode'. +;; +;; +;; --------------------------------------------------------------------- +;; +;; Other lisp files used by gnuplot.el +;; +;; gnuplot-gui.el (written by Bruce): +;; Defines the GUI interface for setting setting arguments to +;; gnuplot options. This uses the widget package extensively. +;; +;; gnuplot-context.el (written by Jonathan, j.j.oddie@gmail.com) +;; Context-sensitive completion, help lookup and eldoc +;; strings for gnuplot buffers. Should be byte-compiled before +;; using. +;; +;; --------------------------------------------------------------------- +;; +;; This mode was inspired by the original gnu-plot-mode by Gershon +;; Elber, which is distributed with gnuplot itself and which dates +;; back to the early 90's. Although this mode encompasses the +;; functionality of the original, the two share no code and the +;; current implementation takes advantage of many features of modern +;; versions of emacs and adheres (or so I intend) to the major mode +;; conventions described in the emacs-lisp reference for version 19 +;; and later. +;; +;; --------------------------------------------------------------------- +;; +;; Installation +;; ============ +;; +;; A recent version of this file can be found at +;; http://github.com/bruceravel/gnuplot-mode/ +;; +;; To autoload gnuplot-mode on any file with gp extension, put this in +;; your .emacs file +;; (autoload 'gnuplot-mode "gnuplot" "gnuplot major mode" t) +;; (autoload 'gnuplot-make-buffer "gnuplot" "open a buffer in gnuplot-mode" t) +;; +;; Something like +;; (setq auto-mode-alist (append '(("\\.gp$" . gnuplot-mode)) +;; auto-mode-alist)) +;; is useful for having files ending in .gp start up in gnuplot-mode. +;; +;; Something like +;; (global-set-key [(f9)] 'gnuplot-make-buffer) +;; may be useful. This binds f9 to the function that opens a scratch +;; buffer (i.e. one that is not visiting a file) in gnuplot-mode. +;; This is handy for your quick 'n' dirty plotting chores. +;; +;; To use the `gnuplot-info-lookup-symbol' function, the file +;; gnuplot.info MUST be installed somewhere that info can find it. +;; This means you must either: +;; 1. Copy gnuplot.info to the normal info directory or +;; 2. Make sure info can find gnuplot.info by putting this in your +;; .emacs file: +;; (setenv "INFOPATH" +;; (concat (getenv "INFOPATH") ":" +;; (expand-file-name "/path/to/file"))) +;; where "/path/to/file" is the location of gnuplot.info +;; +;; This mode has been tested extensively with GNU Emacs 23 and 24, and +;; in a limited manner with GNU Emacs 22 and XEmacs 21. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; History: + +;; +;; 0.1 Jun 25 1998 Finished with initial release. +;; 0.2 Sep 4 1998 Added filename insertion, indentation, and +;; colorization/completion in comint buffer.
+;; 0.2a Sep 11 1998 made `indent-line-function' buffer-local (whoops!) +;; and fixed some stuff in the installation script
+;; 0.3 Sep 12 1998 include insertions menu
+;; 0.3a Sep 14 1998 fixed bug finding info file if missing, fixed bug +;; starting font-lock, fixed bug re overwriting files in +;; installation script
+;; 0.3b Sep 15 1998 Added (require 'info) to `(eval-and-compile' +;; clause, Added (kill-all-local-variables) to `gnuplot-mode', +;; altered order of:- +;; (provide 'gnuplot) +;; (run-hooks 'gnuplot-load-hook) +;; at the end of the file in case something in the load hook +;; requires gnuplot (oh not that old one again...), added +;; `gnuplot-comint-setup-hook', corrected `gnuplot-mark-active' +;; which caused an error to be raised by (mark) when the mark +;; was inactive Some changes to font-lock rules &
+;; 0.4 Nov 14 1998
Use info-look for info interface. No +;; change to gnuplot-mode user interface, but cleaner code. +;; With info-look, the help funcion works regardless of the +;; version number of gnuplot. Also, `gnuplot-keywords' (used +;; for help, keyword-completion, and hilit19 highlighting) is +;; now generated automatically. +;; 0.4a Nov 18 1998
info-look leaves a couple of really useless +;; buffers lying around so I cleaned them up. Also fixed +;; font-lock rules so that things in quotes get highlighted +;; correctly and the surrounding text is unhighlighted. Fixed +;; up font-lock rules for plot and splot. Added +;; `gnuplot-send-line-and-forward' as suggested by . +;; 0.4b Nov 21 1998
added toolbar for xemacs -- see file +;; gnuplot-toolbar.el. fixed error message in plot line +;; function when line is empty. option added to display the +;; comint buffer showing the gnuplot process in a separate +;; frame +;; 0.4c Minor stuff: Nov 30 1998
fixed highlighting in comint +;; buffer. fixed frame behavior. added "[:]" to range +;; insertions. added :link to defgroup. Dec 1 1998
fixed +;; some mismatched defcustoms. added a few lines to suppress +;; some compile-time warnings. Dec 3 1998
Fixed behavior +;; of filename insertion function. Added more :links to +;; defgroup. +;; 0.4d Dec 6 1998
Added function gnuplot-setup-info-look and +;; variable gnuplot-info-hook to handle various versions of the +;; gnuplot info file. +;; 0.4e Dec 12 1998
Split up gnuplot-insertions-menu for ease of +;; custimization, put menubar initialization in a function. +;; 0.4f Dec 14 1998
defcustom the insertions submenus, add +;; gnuplot-insertion-menu-flag, intelligent Makefile knows +;; which info-look to compile +;; 0.5 Dec 27 1998
wrote initial draft of gnuplot-gui.el, +;; included it in insertions menu and in `gnuplot-insert'. +;; Negate option function, bound to C-c C-n. Dec 29 1998
+;; C-c C-h with no response goes to Commands menu. Transparent +;; toolbar icons. Replace kw-compl with a simple completion +;; function. Put gnuplot-toolbar code in gnuplot.el. +;; 0.5a Jan 23 1999
send file uses the load command. add +;; gnuplot-plot-from-comint and +;; gnuplot-save-and-plot-from-comint and keybindings in the +;; comint buffer. do (process-kill-without-query +;; gnuplot-process nil). `gnuplot-negate-option' checks if set +;; option has a negated form. +;; 0.5b `gnuplot-kill-gnuplot-buffer' made more robust. fixed a bug +;; in `gnuplot-plot-from-comint'. fixed description of +;; gnuplot-faces group. +;; 0.5c update copyright information, update gpelcard +;; 0.5d Mar 20 1999
adopt installation materials from . Add +;; some support for hidden3d. Use constants in types alists in +;; gui. Various other minor improvements to the types alists. +;; 0.5e Apr 6 1999
at the suggestion of I did away with the +;; gnuplot-which-highlight variable and revamped how +;; colorization gets turned on. This is a bit tricky since I +;; want it to work with font-lock under emacs and xemacs and +;; with hilit19. Apr 11 1999
insert space at end of +;; unique completion. add a few GUI types, rewrite some stuff +;; in the GUI interface. primitive support for plot, splot, +;; and fit. Fixed completion in file widget. +;; 0.5f May 15 1999
Add pgnuplot.c and Win9x install instructions +;; to the distribution. Fixed a defface bug. Added +;; `gnuplot-keywords-when' allowing deferral of parsing the +;; info file. +;; 0.5g May 27 1999
Fixed font-locking of strings and +;; comments. Figure out gnuplot-version number from startup +;; message and set `gnuplot-echo-command-line-flag' +;; accordingly. Added `gnuplot-program-version' variable. +;; Check that font-lock is actually a feature, as suggested by +;; +;; 0.5h Aug 15 1999
Added `gnuplot-determine-gnuplot-version' so +;; that the gnuplot version number and `comint-process-echos' +;; actually get set correctly. Actually, the first time +;; something is plotted, the echoing might not work, but the +;; second time it will. +;; 0.5i Sep 2 1999
Once again changed how +;; `comint-process-echos' gets set. Maybe I got it right this +;; time? Also fixed certain situations where the info file +;; did notget properly loaded (insertion with info toggle on +;; and info button in GUI). +;; 0.5j Sep 9 1999
Do a more robust check for the gnuplot +;; process before killing the gnuplot buffer, as suggested by +;; . +;; 0.5k Sep 22 1999
make `gnuplot-send-line-and-forward' skip +;; over blank and comment lines as suggested by . Jan 10 +;; 2000 Bound C-c C-j to `gnuplot-forward-script-line'. +;; 0.5l Nov 16 2000
support for pm3d in gnuplot-gui and in plot +;; options insertions menu. mentioned pm3d in gpelcard. gui +;; support for x11 pm3d and vgagl terms. +;; `gnuplot-negate-option' works with new syntax. +;; 0.5m Nov 17 2000
add colorization and gui support for new +;; commands in 3.8. gui support for emf term. gui support for +;; new "set style" syntax. much better scheme for determining +;; gnuplot version number + make better use of it. +;; 0.5n Jan 4 2001
corrected a serious problem interacting with +;; speedbar +;; 0.5o skipped +;; 0.5p Mar 14 2001
fixed problem with toolbar creation and +;; speedbar clicking +;; 0.5q May 30 2001
added font-lock bindings for words associated +;; with plotting +;; 0.5r Oct 17 2001
Incorporate two suggestions by , bind +;; C-c C-c to comment-region and C-c C-o to the GUI, also make +;; C-c C-l respect continuation lines +;; April 12, 2002
added feature to trim length of gnuplot +;; process buffer +;; 0.5s Jun 7 2002
Yet again changed how `comint-process-echos' +;; gets set. It really needs to be nil on NTEmacs 21.1 or +;; comint gets stuck in an infinate loop. +;; 0.5t Sep 16 2002
Fixed a problem with C-c C-v jumping +;; forward 2 lines at a time +;; 0.6.0 Dec 13 2002
Changed numbering scheme to accommodate +;; gnuplot packaging requirements +;; 0.6.1 Sep 13 2011
Moved to github, updated contact info +;; 0.7.0 Oct 20 2012 Contextual completion & help, inline plots, +;; some other stuff + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Acknowledgements: +;; David Batty (numerous corrections) +;; Laurent Bonnaud (suggestions regarding font-lock rules) +;; Markus Dickebohm (suggested `gnuplot-send-line-and-forward') +;; Stephen Eglan (suggested the use of info-look, +;; contributed a bug fix regarding shutting +;; down the gnuplot process, improvement to +;; `gnuplot-send-line-and-forward') +;; Robert Fenk (suggested respecting continuation lines) +;; Michael Karbach (suggested trimming the gnuplot process buffer) +;; Alex Chan Libchen (suggested font-lock for plotting words) +;; Kuang-Yu Liu (pointed out buggy dependence on font-lock) +;; Hrvoje Niksic (help with defcustom arguments for insertions) +;; Andreas Rechtsteiner (pointed out problem with C-c C-v) +;; Michael Sanders (help with the info-look interface) +;; Jinwei Shen (suggested functionality in comint buffer) +;; Michael M. Tung (prompted me to add pm3d support) +;; Holger Wenzel (suggested using `gnuplot-keywords-when') +;; Wolfgang Zocher (pointed out problem with gnuplot-mode + speedbar) +;; Jon Oddie (indentation, inline images, context mode) +;; +;; and especially to Lars Hecking for including gnuplot-mode +;; with the gnuplot 3.7-beta distribution and for providing me with +;; installation materials +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; To Do: +;; +;; 1. Since `gnuplot-display-process' can be nil, it would be +;; handy to have a function to put on +;; `gnuplot-after-plot-buffer-hook' to check and see if the script +;; executed properly. Alas I am not sure how gnuplot signals its +;; errors. +;; 2. improve plot, splot, fit in GUI +;; 3. interface to setting bind command using `read-key-sequence'. +;; this is a pain because the nomenclature is really different in +;; gnuplot than in `read-key-sequence' +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Code: + +(require 'comint) +(require 'easymenu) +(eval-when-compile (require 'cl)) + +(declare-function 'eldoc-add-command "eldoc") + + +;;; --- variable definitions + eval-and-compile clauses + +;; We no longer hack around ancient versions of Customize with macros +(require 'custom) + +(eval-and-compile ;; + (require 'info)) + +(eval-and-compile + (condition-case () + (require 'info-look) + (error nil))) + +;; Workaround missing `completion-at-point' in (X)Emacs < 22 +(if (not (fboundp 'completion-at-point)) + (defun gnuplot-xemacs-completion-at-point () + "Perform completion on keyword preceding point. + +This binds `comint-dynamic-complete-functions' to +`gnuplot-comint-complete' and uses `comint-dynamic-complete' to do the +real work." + (interactive) + (let ((comint-dynamic-complete-functions + '(gnuplot-comint-complete))) + (comint-dynamic-complete)))) + +;; Work around missing `window-full-height-p' +(if (fboundp 'window-full-height-p) + (defalias 'gnuplot-window-full-height-p 'window-full-height-p) + ;; The below is taken from window.el in GNU Emacs + (defun gnuplot-window-full-height-p (&optional window) + (unless window + (setq window (selected-window))) + (= (window-height window) + (window-height (frame-root-window (window-frame window)))))) + +;; Workaround obsolete `process-kill-without-query' +(if (fboundp 'set-process-query-on-exit-flag) + (defalias 'gnuplot-set-process-query-on-exit-flag 'set-process-query-on-exit-flag) + (defalias 'gnuplot-set-process-query-on-exit-flag 'process-kill-without-query)) + +;; Workaround for missing syntax-ppss in XEmacs +(if (fboundp 'syntax-ppss) + (defalias 'gnuplot-syntax-ppss 'syntax-ppss) + (defun gnuplot-syntax-ppss (&optional pos) + (save-excursion + (unless pos (setq pos (point))) + (let ((begin + (save-excursion + (goto-char pos) + (gnuplot-point-at-beginning-of-continuation)))) + (parse-partial-sexp begin pos))))) + + +;;;; +(defconst gnuplot-xemacs-p (string-match "XEmacs" (emacs-version))) +(defconst gnuplot-ntemacs-p (string-match "msvc" (emacs-version))) +(defvar gnuplot-three-eight-p "") + +(defconst gnuplot-maintainer "Bruce Ravel") +(defconst gnuplot-maintainer-email "bruceravel1@gmail.com>") +(defconst gnuplot-maintainer-url + "http://github.com/bruceravel/gnuplot-mode/") +(defconst gnuplot-version "0.7-beta") + +(defgroup gnuplot nil + "Gnuplot-mode for Emacs." + :prefix "gnuplot-" + :group 'processes + :group 'applications + :group 'local + :link '(emacs-library-link :tag "Lisp File" "gnuplot.el") + :link '(url-link :tag "Homepage" + "http://github.com/bruceravel/gnuplot-mode/") + :link '(custom-manual "(gnuplot)Top") + :link '(emacs-commentary-link :tag "Commentary" "gnuplot.el") ) +(defgroup gnuplot-insertions nil + "Insert commands into gnuplot-scripts from a pull-down menu." + :prefix "gnuplot-insertions-" + :group 'gnuplot) +(defgroup gnuplot-hooks nil + "Hook variables used by `gnuplot-mode'." + :prefix "gnuplot-" + :group 'gnuplot) + +(defcustom gnuplot-mode-hook nil + "*Hook run when `gnuplot-mode' is entered." + :group 'gnuplot-hooks + :type 'hook) +(defcustom gnuplot-load-hook nil + "*Hook run when gnuplot.el is first loaded." + :group 'gnuplot-hooks + :type 'hook) +(defcustom gnuplot-after-plot-hook nil + "*Hook run after gnuplot plots something. +This is the last thing done by the functions for plotting a line, a +region, a buffer, or a file." + :group 'gnuplot-hooks + :type 'hook) + + +(defcustom gnuplot-info-hook nil + "*Hook run before setting up the info-look interface. +This hook is necessary to handle inconsistencies in versions of and +sources of the gnuplot info file. If Gnuplot-mode can find the info +file generated from the 3.6beta patchlevel 347 (or later) release of +Gnuplot, then this hook probably is not necessary. Some versions of +the info file may have a General Index session, which can be used by +info-look. In that case the following (or something similar with the +value of `info-lookup-symbol-alist' altered appropriately) should be +placed in the .emacs file. + +Emacs version 20.2 ships with a different version of info-look that +does 20.3. If you use any version of Emacs 19, you must use the +version from 20.2. Any version of XEmacs 20 or 21 should use the +version from 20.3 but can use either. XEmacs 19 should use the +version 20.2. + +For the newer version of info-look, do this: + + (add-hook \'gnuplot-info-hook + \'(lambda () + (let ((elem (assoc \'gnuplot-mode info-lookup-alist))) + (delete elem info-lookup-alist) + (info-lookup-maybe-add-help + :mode 'gnuplot-mode :topic 'symbol + :regexp \"[a-zA-Z][_a-zA-Z0-9]*\" + :doc-spec '((\"(gnuplot)General Index\" nil + \"[_a-zA-Z0-9]+\")))))) + +For the older version of info-look, do this: + + (add-hook \'gnuplot-info-hook + \'(lambda () + (let ((elem (assoc \'gnuplot-mode info-lookup-alist))) + (delete elem info-lookup-alist) + (setq info-lookup-alist + (append info-lookup-alist + \'((gnuplot-mode + \"[a-zA-Z][_a-zA-Z0-9]*\" nil + ((\"(gnuplot)General Index\" nil + \"[_a-zA-Z0-9]+\" )))))))))" + :group 'gnuplot-hooks + :type 'hook) + +;; comint hook suggested by +(defcustom gnuplot-comint-setup-hook nil + "*Hook run after setting up the gnuplot buffer in comint mode. +So the configuration can be customised by the user." + :group 'gnuplot-hooks + :type 'hook) + +(defcustom gnuplot-comint-mode-hook nil + "*Hook run after setting up the gnuplot buffer in gnuplot-comint-mode. +By default this runs the hook named `gnuplot-comint-setup-hook', +for backward compatibility." + :group 'gnuplot-hooks + :type 'hook) + +(defvar gnuplot-recently-sent nil + "This is a record of the most recent kind of text sent to gnuplot. +It takes as its value nil, 'line, 'region, 'buffer, or 'file. It is +useful for functions included in `gnuplot-after-plot-hook'.") +(make-variable-buffer-local 'gnuplot-recently-sent) + +(defcustom gnuplot-program "gnuplot" + "*The name of the gnuplot executable." + :group 'gnuplot + :type 'string) +(defvar gnuplot-program-version nil + "Version number of gnuplot. +This is using `gnuplot-fetch-version-number'.") +(defvar gnuplot-program-major-version nil + "Major version number of gnuplot. +This is found using `gnuplot-fetch-version-number'.") +(defvar gnuplot-program-minor-version nil + "Minor version number of gnuplot. +This is found using `gnuplot-fetch-version-number'.") + +(defcustom gnuplot-process-name "gnuplot" + "Name given to the gnuplot buffer and process." + :group 'gnuplot + :type 'string) +(defvar gnuplot-buffer nil + "*The name of the buffer displaying the gnuplot process.") +(defvar gnuplot-process nil + "Variable holding the process handle.") +(defvar gnuplot-process-frame nil + "The frame for displaying the gnuplot process. +This is used when `gnuplot-display-process' is equal to 'frame.") +(defvar gnuplot-comint-recent-buffer nil + "The most recently plotted gnuplot script buffer. +This is used by the function that plot from the comint buffer. It is +reset every time something is plotted from a script buffer.") + +(defcustom gnuplot-gnuplot-buffer "plot.gp" + "*The name of the gnuplot scratch buffer opened by 'gnuplot-make-buffer'." + :group 'gnuplot + :type 'string) + +(defcustom gnuplot-display-process 'window + "This controls how the gnuplot process buffer is displayed. +The values are + 'frame display gnuplot process in a separate frame + 'window display gnuplot process in this frame but in another window + nil `gnuplot-process' is in the current frame but not displayed" + :group 'gnuplot + :type '(radio (const :tag "Separate frame" frame) + (const :tag "Separate window" window) + (const :tag "Not displayed" nil))) +(defcustom gnuplot-info-display 'window + "*Determines how `gnuplot-info-lookup-symbol' displays the info file. +The values are + 'frame display info file in a separate frame + 'window display info file in another window + nil display info file in the current window" + :group 'gnuplot + :type '(radio (const :tag "Separate frame" frame) + (const :tag "Separate window" window) + (const :tag "This window" nil))) + +(defcustom gnuplot-echo-command-line-flag (not gnuplot-ntemacs-p) + "*This sets the fall-back value of `comint-process-echos'. +If `gnuplot-mode' cannot figure out what version number of gnuplot +this is, then the value of this variable will be used for +`comint-process-echos'. It seems that gnuplot 3.5 wants this to be +nil and 3.7 wants it to be t. If lines that you send to gnuplot from +the `gnuplot-mode' buffer are not appearing at the gnuplot prompt in +the process buffer, try toggling it. Also see the document string for +`comint-process-echos'. If you change this, kill the gnuplot process +and start it again." + :group 'gnuplot + :type 'boolean) +(defcustom gnuplot-insertions-show-help-flag nil + "*Non-nil means to display certain help messages automatically. +These messages are shown after menu insertion of gnuplot commands." + :group 'gnuplot-insertions + :type 'boolean) + +(defcustom gnuplot-delay 0.01 + "*Amount of time to delay before sending a new line to gnuplot. +This is needed so that the the line is not written in the gnuplot +buffer in advance of its prompt. Increase this number if the +prompts and lines are displayed out of order." + :group 'gnuplot + :type 'number) +(defcustom gnuplot-buffer-max-size 1000 + "*The maximum size in lines of the gnuplot process buffer. +Each time text is written in the gnuplot process buffer, lines are +trimmed from the beginning of the buffer so that the buffer is this +many lines long. The lines are deleted after the most recent lines +were interpretted by gnuplot. Setting to 0 turns off this feature +\(i.e. no lines get trimmed)." + :group 'gnuplot + :type 'integer) +(defcustom gnuplot-quote-character "\'" + "*Quotation character used for inserting quoted strings. +Gnuplot can use single or double quotes. If you prefer to have the +filename insertion function never insert quotes for you, set this +to the empty string." + :group 'gnuplot + :type '(radio (const :tag "double quote" "\"") + (const :tag "single quote" "\'") + (const :tag "none" "" ))) +(defcustom gnuplot-basic-offset 4 + "Number of columns to indent lines inside a do- or if-else-block. + +This applies only to new-style do- and if-statements using +braces. Commands continued over a linebreak using a backslash are +always indented to line up with the second word on the line +beginning the continued command." + :group 'gnuplot + :type 'integer) + +;; (defcustom gnuplot-gnuplot-version nil +;; "*Force gnuplot-mode to behave for this version of gnuplot." +;; :group 'gnuplot +;; :type '(radio (const :tag "unspecified" nil) +;; (const :tag "3.8 or newer" "3.8") +;; (const :tag "3.7 or older" "3.7"))) + +(defvar gnuplot-info-frame nil) +(defvar gnuplot-info-nodes '()) + +(defvar gnuplot-first-call t) + +;; with info-look, there is no need to carry this list around -- it +;; can be generated on the fly appropriate to the currently installed +;; version of gnuplot.info +(defvar gnuplot-keywords nil + "A list of keywords used in GNUPLOT. +These are set by `gnuplot-set-keywords-list' from the values in +`info-lookup-cache'.") +(defvar gnuplot-keywords-alist nil) ;; For all-completions +(defvar gnuplot-keywords-pending t ;; + "A boolean which gets toggled when the info file is probed.") +(defcustom gnuplot-keywords-when 'deferred ;; 'immediately + "This variable controls when the info file is parsed. +The choices are immediately upon starting gnuplot-mode or the first +time that data is needed." + :group 'gnuplot + :type + '(radio (const :tag "Parse info file when gnuplot-mode starts" immediately) + (const :tag "Parse info file the first time it is needed" deferred))) + +(defun gnuplot-set-context-sensitive-completion (_variable value) + "Customize :set function for `gnuplot-use-context-sensitive-completion'." + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p 'gnuplot-mode 'gnuplot-comint-mode) + (gnuplot-context-sensitive-mode + (if value 1 0)))))) + +(defcustom gnuplot-use-context-sensitive-completion t + "Non-nil if `gnuplot-context-sensitive-mode' should be enabled by default. + +In context-sensitive mode, gnuplot-mode parses the current +command line to provide smarter completion and documentation +suggestions." + :group 'gnuplot + :type 'boolean + :initialize 'custom-set-default + :set 'gnuplot-set-context-sensitive-completion + :link '(emacs-commentary-link "gnuplot-context")) + +(defcustom gnuplot-eldoc-mode nil + "Non-nil if ElDoc mode should be enabled by default in Gnuplot buffers. +ElDoc support requires `gnuplot-context-sensitive-mode' to be +on." + :group 'gnuplot + :type 'boolean) + +(defcustom gnuplot-tab-completion nil + "Non-nil if TAB should perform completion in gnuplot-mode buffers. + +Setting this to `t' sets the `tab-always-indent' variable to the +symbol `complete' in gnuplot-mode buffers." + :group 'gnuplot + :type 'boolean) + +(defun gnuplot-set-display-mode (variable value &rest args) + "Customize :set function for `gnuplot-inline-image-mode'." + (if (and (eq variable 'gnuplot-inline-image-mode) + value + (not (gnuplot-display-images-p))) + (progn + (message "Displaying images is not supported.") + (set variable nil)) + (set variable value)) + (gnuplot-setup-comint-for-image-mode)) + +(defcustom gnuplot-inline-image-mode nil + "Whether to display Gnuplot output in Emacs. + +Possible values are nil, `inline' and `dedicated'. + +When this is `nil', Gnuplot output is handled outside of Emacs in +the normal way. Otherwise, Emacs attempts to capture Gnuplot's +output and display it in a buffer. Output is inserted inline in +the Gnuplot interaction buffer it this is `inline', in a +separate dedicated buffer if it is `dedicated'. + +Use Customize to set this variable, or the commands +`gnuplot-external-display-mode', `gnuplot-inline-display-mode', +and `gnuplot-dedicated-display-mode'." + :group 'gnuplot + :type '(radio + (const :tag "No" nil) + (const :tag "In Comint buffer" inline) + (const :tag "In dedicated buffer" dedicated)) + :initialize 'custom-initialize-default + :set 'gnuplot-set-display-mode) + +(defcustom gnuplot-image-format "png" + "Image format to use for displaying images within Emacs. + +This will be sent directly to Gnuplot as a command of the form +\"set terminal \". Common values are \"png\" and +\"svg\". + +This only has an effect when `gnuplot-inline-image-mode' is +non-nil." + :group 'gnuplot + :type 'string + :initialize 'custom-initialize-default + :set 'gnuplot-set-display-mode) + +(defgroup gnuplot-faces nil + "Text faces used by gnuplot-mode." + :prefix "gnuplot-" + :group 'gnuplot) + +(defface gnuplot-prompt-face '((((class color)) + (:foreground "firebrick")) + (t + (:bold t :underline t))) + "Face used for the prompt in the gnuplot process buffer." + :group 'gnuplot-faces) + + +;;; --- key bindings and menus + +(defvar gnuplot-mode-map + (let ((map (make-sparse-keymap)) + (completion-function + (if (fboundp 'completion-at-point) + 'completion-at-point + 'gnuplot-xemacs-completion-at-point))) + (define-key map "\C-c\C-b" 'gnuplot-send-buffer-to-gnuplot) + (define-key map "\C-c\C-c" 'comment-region) ; + (define-key map "\C-c\C-o" 'gnuplot-gui-set-options-and-insert) + (define-key map "\C-c\C-w" 'gnuplot-show-version) + (define-key map "\C-c\C-e" 'gnuplot-show-gnuplot-buffer) + (define-key map "\C-c\C-f" 'gnuplot-send-file-to-gnuplot) + (define-key map "\C-c\C-d" 'gnuplot-info-lookup-symbol) + (define-key map "\C-c\C-i" 'gnuplot-insert-filename) + (define-key map "\C-c\C-j" 'gnuplot-forward-script-line) + (define-key map "\C-c\C-k" 'gnuplot-kill-gnuplot-buffer) + (define-key map "\C-c\C-l" 'gnuplot-send-line-to-gnuplot) + (define-key map "\C-c\C-n" 'gnuplot-negate-option) + (define-key map "\C-c\C-p" 'gnuplot-show-gnuplot-version) + (define-key map "\C-c\C-r" 'gnuplot-send-region-to-gnuplot) + (define-key map (kbd "C-M-x") 'gnuplot-send-line-to-gnuplot) + (define-key map "\C-c\C-u" 'gnuplot-bug-report) + (define-key map "\C-c\C-v" 'gnuplot-send-line-and-forward) + (define-key map "\C-c\C-z" 'gnuplot-customize) + (define-key map "\C-i" 'indent-for-tab-command) + (define-key map "\C-m" 'newline-and-indent) + (define-key map "\C-c\M-i" 'gnuplot-inline-image-mode) + (define-key map (kbd "}") 'gnuplot-electric-insert) + (define-key map "\M-\r" completion-function) + (define-key map "\M-\t" completion-function) + + (if gnuplot-xemacs-p + (define-key map '(shift button2) 'gnuplot-gui-mouse-set) + (define-key map [S-mouse-2] 'gnuplot-gui-mouse-set)) + + map)) + +(defvar gnuplot-mode-menu nil) + +(defvar gnuplot-display-options-menu + (flet ((make-image-setter (type) + `[,(concat (upcase type) " images") + (lambda () (interactive) (gnuplot-set-image-format ,type)) + :style toggle + :selected (eq gnuplot-image-format ,type)])) + `("Display plot output" + ["Externally" gnuplot-external-display-mode + :style toggle + :selected (null gnuplot-inline-image-mode)] + ["In Comint buffer" gnuplot-inline-display-mode + :active (gnuplot-display-images-p) + :style toggle + :selected (eq gnuplot-inline-image-mode 'comint)] + ["In dedicated buffer" gnuplot-dedicated-display-mode + :style toggle + :selected (eq gnuplot-inline-image-mode 'dedicated)] + "---" + ,@(mapcar #'make-image-setter (list "png" "jpeg" "svg")) + ["Other image type..." gnuplot-set-image-format]))) + +(defvar gnuplot-menu + `("Gnuplot" + ["Send line to gnuplot" gnuplot-send-line-to-gnuplot t] + ["Send line & move forward" gnuplot-send-line-and-forward (not (eobp))] + ["Send region to gnuplot" gnuplot-send-region-to-gnuplot + (gnuplot-mark-active)] + ["Send buffer to gnuplot" gnuplot-send-buffer-to-gnuplot t] + ["Send file to gnuplot" gnuplot-send-file-to-gnuplot t] + "---" + ,gnuplot-display-options-menu + ["Contextual completion and help" gnuplot-context-sensitive-mode + :style toggle + :selected gnuplot-context-sensitive-mode] + ["Echo area help (eldoc-mode)" eldoc-mode + :active gnuplot-context-sensitive-mode + :style toggle + :selected eldoc-mode] + "---" + ["Insert filename at point" gnuplot-insert-filename t] + ["Negate set option" gnuplot-negate-option t] + ;;["Set key binding" gnuplot-set-binding gnuplot-three-eight-p] + ["Keyword help" gnuplot-info-lookup-symbol + (or gnuplot-keywords gnuplot-keywords-pending)] + ["Quick help for thing at point" gnuplot-help-function + gnuplot-context-sensitive-mode] + ["Info documentation on thing at point" + gnuplot-info-at-point + gnuplot-context-sensitive-mode] + ["Show gnuplot process buffer" gnuplot-show-gnuplot-buffer t] + ["Set arguments at point" gnuplot-gui-set-options-and-insert + (fboundp 'gnuplot-gui-set-options-and-insert)] + ["Swap plot/splot/fit lists in GUI" gnuplot-gui-swap-simple-complete + (fboundp 'gnuplot-gui-swap-simple-complete)] + "---" + ["Customize gnuplot" gnuplot-customize t] + ["Submit bug report" gnuplot-bug-report t] + ["Show gnuplot-mode version" gnuplot-show-version t] + ["Show gnuplot version" gnuplot-show-gnuplot-version t] + "---" + ["Kill gnuplot" gnuplot-kill-gnuplot-buffer t] + ) + "Menu for `gnuplot-mode'.") + + + +;;; --- insertions variables and menus + +;;(load-library "gnuplot-insertions") +(defvar gnuplot-mode-insertions-menu nil) +(defvar gnuplot-insertions-menu nil + "Menu for insertions in `gnuplot-mode'. + +The insertions menu is composed of several sub-menus. The variables +describing the sub-menus are: + `gnuplot-insertions-adornments' + `gnuplot-insertions-plot-options' + `gnuplot-insertions-terminal' + `gnuplot-insertions-x-axis' + `gnuplot-insertions-y-axis' + `gnuplot-insertions-z-axis' + `gnuplot-insertions-x2-axis' + `gnuplot-insertions-y2-axis' + `gnuplot-insertions-parametric-plots' + `gnuplot-insertions-polar-plots' + `gnuplot-insertions-surface-plots' +These variables can be customized by the user. For example, there are +many terminal types which are not in the terminal submenu but which +may be compiled into a user's copy of gnuplot. + +Each of these variables is a list whose first element is a string and +all the rest are vectors as described in the document string for +`easy-menu-define'. The callback used throughout these menus is +`gnuplot-insert' which inserts the appropriate set expression and, +optionally, looks up that item in the gnuplot info file. + +The easiest way to customize the submenus is to use the custom +package. Just type \\[gnuplot-customize] and follow your nose. + +You can also add new items to any of these sub-menus by adding to the +`gnuplot-load-hook' in your .emacs file. Here is an example of adding +the \"regis\" terminal type to the terminal sub-menu: + + (add-hook + 'gnuplot-load-hook + '(lambda () + (setq gnuplot-insertions-terminal + (append gnuplot-insertions-terminal + (list + [\"regis\" + (gnuplot-insert \"set terminal regis\") + t])))))") + +(defvar gnuplot-insertions-top () + "Top part of insertions menu. +See the document string for `gnuplot-insertions-menu'") + +(defcustom gnuplot-insertions-menu-flag t + "*Non-nil means to place the insertion menu in the menubar. +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type 'boolean) + +(defcustom gnuplot-insertions-adornments ; this is icky... + (if gnuplot-three-eight-p + '("adornments" + ["arrow" (gnuplot-insert "set arrow ") t] + ["bar" (gnuplot-insert "set bar") t] + ["border" (gnuplot-insert "set border") t] + ["boxwidth" (gnuplot-insert "set boxwidth ") t] + ["format" (gnuplot-insert "set format ") t] + ["grid" (gnuplot-insert "set grid") t] + ["key" (gnuplot-insert "set key ") t] + ["label" (gnuplot-insert "set label ") t] + ["pointsize" (gnuplot-insert "set pointsize ") t] + ["samples" (gnuplot-insert "set samples ") t] + ["size" (gnuplot-insert "set size ") t] + ["style" (gnuplot-insert "set style ") t] + ["tics" (gnuplot-insert "set tics ") t] + ["timefmt" (gnuplot-insert "set timefmt ") t] + ["timestamp" (gnuplot-insert "set timestamp ") t] + ["title" (gnuplot-insert "set title ") t] + ["zeroaxis" (gnuplot-insert "set zeroaxis") t] ) + '("adornments" + ["data style" (gnuplot-insert "set data style ") t] + ["function style" (gnuplot-insert "set function style ") t] + ["arrow" (gnuplot-insert "set arrow ") t] + ["bar" (gnuplot-insert "set bar") t] + ["border" (gnuplot-insert "set border") t] + ["boxwidth" (gnuplot-insert "set boxwidth ") t] + ["format" (gnuplot-insert "set format ") t] + ["grid" (gnuplot-insert "set grid") t] + ["key" (gnuplot-insert "set key ") t] + ["label" (gnuplot-insert "set label ") t] + ["pointsize" (gnuplot-insert "set pointsize ") t] + ["samples" (gnuplot-insert "set samples ") t] + ["size" (gnuplot-insert "set size ") t] + ["tics" (gnuplot-insert "set tics ") t] + ["timefmt" (gnuplot-insert "set timefmt ") t] + ["timestamp" (gnuplot-insert "set timestamp ") t] + ["title" (gnuplot-insert "set title ") t] + ["zeroaxis" (gnuplot-insert "set zeroaxis") t] )) + "Adornments submenu in the insertions menu. +See the document string for `gnuplot-insertions-menu' +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type '(list (string :tag "Title") + (repeat :inline t + (vector (string :tag "Name") + (function :tag "Callback") + (boolean :tag "Enabled" t))))) + + + +(defcustom gnuplot-insertions-plot-options + '("plot options" + ["autoscale" (gnuplot-insert "set autoscale ") t] + ["clip" (gnuplot-insert "set clip ") t] + ["encoding" (gnuplot-insert "set encoding ") t] + ["locale" (gnuplot-insert "set locale ") t] + ["logscale" (gnuplot-insert "set logscale ") t] + ["multiplot" (gnuplot-insert "set multiplot") t] + ["missing" (gnuplot-insert "set missing \"\"") t] + ["palette" (gnuplot-insert "set palette ") t] ; + ["pm3d" (gnuplot-insert "set pm3d ") t] + ["offsets" (gnuplot-insert "set offsets ") t] + ["output" (gnuplot-insert "set output ") t] + ["zero" (gnuplot-insert "set zero ") t] ) + "Plot options submenu in the insertions menu. +See the document string for `gnuplot-insertions-menu' +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type '(list (string :tag "Title") + (repeat :inline t + (vector (string :tag "Name") + (function :tag "Callback") + (boolean :tag "Enabled" t))))) + + +(defcustom gnuplot-insertions-terminal + '("terminal" + ["eepic" (gnuplot-insert "set terminal eepic") t] + ["fig" (gnuplot-insert "set terminal fig") t] + ["gpic" (gnuplot-insert "set terminal gpic") t] + ["latex" (gnuplot-insert "set terminal latex") t] + ["linux" (gnuplot-insert "set terminal linux") t] + ["pbm" (gnuplot-insert "set terminal pbm") t] + ["png" (gnuplot-insert "set terminal png") t] + ["postscript" (gnuplot-insert "set terminal postscript") t] + ["pslatex" (gnuplot-insert "set terminal pslatex") t] + ["table" (gnuplot-insert "set terminal table") t] + ["tek40xx" (gnuplot-insert "set terminal tek40xx") t] + ["tkcanvas" (gnuplot-insert "set terminal tkcanvas") t] + ["tpic" (gnuplot-insert "set terminal tpic") t] + ["vgagl" (gnuplot-insert "set terminal vgagl") t] ; for pm3d patch + ["vttek" (gnuplot-insert "set terminal vttek") t] + ["x11" (gnuplot-insert "set terminal x11") t] ) + "Terminal submenu in the insertions menu. +See the document string for `gnuplot-insertions-menu' +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type '(list (string :tag "Title") + (repeat :inline t + (vector (string :tag "Name") + (function :tag "Callback") + (boolean :tag "Enabled" t))))) + + +(defcustom gnuplot-insertions-x-axis + '("x-axis" + ["xdata" (gnuplot-insert "set xdata ") t] + ["xlabel" (gnuplot-insert "set xlabel ") t] + ["xrange" (gnuplot-insert "set xrange [:]") t] + ["xtics" (gnuplot-insert "set xtics ") t] + ["mxtics" (gnuplot-insert "set mxtics ") t] + ["xzeroaxis" (gnuplot-insert "set xzeroaxis ") t] + ["xdtics" (gnuplot-insert "set xdtics ") t] + ["xmtics" (gnuplot-insert "set xmtics ") t]) + "X-axis submenu in the insertions menu. +See the document string for `gnuplot-insertions-menu' +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type '(list (string :tag "Title") + (repeat :inline t + (vector (string :tag "Name") + (function :tag "Callback") + (boolean :tag "Enabled" t))))) + + +(defcustom gnuplot-insertions-x2-axis + '("x2-axis" + ["x2data" (gnuplot-insert "set xdata ") t] + ["x2label" (gnuplot-insert "set xlabel ") t] + ["x2range" (gnuplot-insert "set xrange [:]") t] + ["x2tics" (gnuplot-insert "set xtics ") t] + ["mx2tics" (gnuplot-insert "set mxtics ") t] + ["x2zeroaxis" (gnuplot-insert "set xzeroaxis ") t] + ["x2dtics" (gnuplot-insert "set xdtics ") t] + ["x2mtics" (gnuplot-insert "set xmtics ") t]) + "X2-axis submenu in the insertions menu. +See the document string for `gnuplot-insertions-menu' +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type '(list (string :tag "Title") + (repeat :inline t + (vector (string :tag "Name") + (function :tag "Callback") + (boolean :tag "Enabled" t))))) + + +(defcustom gnuplot-insertions-y-axis + '("y-axis" + ["ydata" (gnuplot-insert "set ydata ") t] + ["ylabel" (gnuplot-insert "set ylabel ") t] + ["ymtics" (gnuplot-insert "set ymtics ") t] + ["yrange" (gnuplot-insert "set yrange [:]") t] + ["ytics" (gnuplot-insert "set ytics ") t] + ["yzeroaxis" (gnuplot-insert "set yzeroaxis ") t] + ["ydtics" (gnuplot-insert "set ydtics ") t] + ["mytics" (gnuplot-insert "set mytics ") t]) + "Y-axis submenu in the insertions menu. +See the document string for `gnuplot-insertions-menu' +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type '(list (string :tag "Title") + (repeat :inline t + (vector (string :tag "Name") + (function :tag "Callback") + (boolean :tag "Enabled" t))))) + +(defcustom gnuplot-insertions-y2-axis + '("y2-axis" + ["y2data" (gnuplot-insert "set ydata ") t] + ["y2label" (gnuplot-insert "set ylabel ") t] + ["y2range" (gnuplot-insert "set yrange [:]") t] + ["y2tics" (gnuplot-insert "set ytics ") t] + ["my2tics" (gnuplot-insert "set mytics ") t] + ["y2zeroaxis" (gnuplot-insert "set yzeroaxis ") t] + ["y2mtics" (gnuplot-insert "set ymtics ") t] + ["y2dtics" (gnuplot-insert "set ydtics ") t]) + "Y2-axis submenu in the insertions menu. +See the document string for `gnuplot-insertions-menu' +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type '(list (string :tag "Title") + (repeat :inline t + (vector (string :tag "Name") + (function :tag "Callback") + (boolean :tag "Enabled" t))))) + + + +(defcustom gnuplot-insertions-z-axis + '("z-axis" + ["zdata" (gnuplot-insert "set zdata ") t] + ["zlabel" (gnuplot-insert "set zlabel ") t] + ["zrange" (gnuplot-insert "set zrange [:]") t] + ["ztics" (gnuplot-insert "set ztics ") t] + ["mztics" (gnuplot-insert "set mztics ") t] + ["zdtics" (gnuplot-insert "set zdtics ") t] + ["zmtics" (gnuplot-insert "set zmtics ") t] ) + "Z-axis submenu in the insertions menu. +See the document string for `gnuplot-insertions-menu' +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type '(list (string :tag "Title") + (repeat :inline t + (vector (string :tag "Name") + (function :tag "Callback") + (boolean :tag "Enabled" t))))) + + +(defcustom gnuplot-insertions-parametric-plots + '("parametric plots" + ["parametric" (gnuplot-insert "set parametric") t] + ["isosamples" (gnuplot-insert "set isosamples ") t] + ["dummy" (gnuplot-insert "set dummy ") t] + ["trange" (gnuplot-insert "set trange [:]") t] + ["urange" (gnuplot-insert "set urange [:]") t] + ["vrange" (gnuplot-insert "set vrange [:]") t] ) + "Parametric plots submenu in the insertions menu. +See the document string for `gnuplot-insertions-menu' +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type '(list (string :tag "Title") + (repeat :inline t + (vector (string :tag "Name") + (function :tag "Callback") + (boolean :tag "Enabled" t))))) + + +(defcustom gnuplot-insertions-polar-plots + '("polar plots" + ["polar" (gnuplot-insert "set polar") t] + ["angles" (gnuplot-insert "set angles ") t] + ["rrange" (gnuplot-insert "set rrange [:]") t] ) + "Polar plots submenu in the insertions menu. +See the document string for `gnuplot-insertions-menu' +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type '(list (string :tag "Title") + (repeat :inline t + (vector (string :tag "Name") + (function :tag "Callback") + (boolean :tag "Enabled" t))))) + + +(defcustom gnuplot-insertions-surface-plots + '("surface plots" + ["clabel" (gnuplot-insert "set clabel ") t] + ["cntrparam" (gnuplot-insert "set cntrparam ") t] + ["contour" (gnuplot-insert "set contour") t] + ["dgrid3d" (gnuplot-insert "set dgrid3d ") t] + ["hidden3d" (gnuplot-insert "set hidden3d ") t] + ["mapping" (gnuplot-insert "set mapping ") t] + ["surface" (gnuplot-insert "set surface ") t] + ["view" (gnuplot-insert "set view ") t] ) + "Surface plots submenu in the insertions menu. +See the document string for `gnuplot-insertions-menu' +Changing this will not effect a change in any currently existing +`gnuplot-mode' buffer. You will see the change the next time you +create a `gnuplot-mode' buffer." + :group 'gnuplot-insertions + :type '(list (string :tag "Title") + (repeat :inline t + (vector (string :tag "Name") + (function :tag "Callback") + (boolean :tag "Enabled" t))))) + + + +(defvar gnuplot-insertions-bottom () + "Bottom part of the insertions menu. +This part contains the toggle buttons for displaying info or +opening an argument-setting popup.") +(setq gnuplot-insertions-bottom + '("---" + ["Display of info with insertion" gnuplot-toggle-info-display + :style toggle :selected gnuplot-insertions-show-help-flag] + ["Display GUI popup with insertion" gnuplot-gui-toggle-popup + :active (fboundp 'gnuplot-gui-toggle-popup) + :style toggle :selected (and (fboundp 'gnuplot-gui-toggle-popup) + gnuplot-gui-popup-flag)] )) + + +;; Regarding a comment by : +;; +;; This is from the header in easymenu.el distributed with XEmacs: +;; +;; ;; - Function: easy-menu-add MENU [ MAP ] +;; ;; Add MENU to the current menubar in MAP. +;; ;; +;; ;; - Function: easy-menu-remove MENU +;; ;; Remove MENU from the current menubar. +;; ;; +;; ;; Emacs 19 never uses `easy-menu-add' or `easy-menu-remove', menus +;; ;; automatically appear and disappear when the keymaps specified by +;; ;; the MAPS argument to `easy-menu-define' are activated. +;; ;; +;; ;; XEmacs will bind the map to button3 in each MAPS, but you must +;; ;; explicitly call `easy-menu-add' and `easy-menu-remove' to add and +;; ;; remove menus from the menu bar. +;; +;; in Emacs, easy-menu-add is defined like this: +;; (defun easy-menu-add (menu &optional map)) + +(defun gnuplot-setup-menubar () + "Initial setup of gnuplot and insertions menus." + (if gnuplot-insertions-menu-flag ; set up insertions menu + (progn + (if gnuplot-xemacs-p + (setq gnuplot-insertions-top + '("insert set expression" "--:doubleLine")) + (setq gnuplot-insertions-top + '("insert set expression" "---"))) + (setq gnuplot-insertions-menu + (append (list "Insertions") + gnuplot-insertions-top + (list gnuplot-insertions-adornments) + (list gnuplot-insertions-plot-options) + (list gnuplot-insertions-terminal) + (list gnuplot-insertions-x-axis) + (list gnuplot-insertions-y-axis) + (list gnuplot-insertions-z-axis) + (list gnuplot-insertions-x2-axis) + (list gnuplot-insertions-y2-axis) + (list gnuplot-insertions-parametric-plots) + (list gnuplot-insertions-polar-plots) + (list gnuplot-insertions-surface-plots) + gnuplot-insertions-bottom)) + (easy-menu-define gnuplot-mode-insertions-menu gnuplot-mode-map + "Insertions menu used in Gnuplot-mode" + gnuplot-insertions-menu) + (easy-menu-add gnuplot-mode-insertions-menu gnuplot-mode-map))) + (easy-menu-define ; set up gnuplot menu + gnuplot-mode-menu gnuplot-mode-map "Menu used in gnuplot-mode" + gnuplot-menu) + (easy-menu-add gnuplot-mode-menu gnuplot-mode-map) ) + +;; There is no `mark-active' variable in XEmacs. Hassle! This is not +;; only replicates mark-active, but it only returns true if the region +;; is of non-zero width. +;; Error checking suggested by +(defun gnuplot-mark-active () + "Return non-nil if the mark is active and it is not equal to point." + (condition-case nil + (and (mark) (/= (mark) (point))) + (error nil))) + + +;;; --- XEmacs toolbar + +(defgroup gnuplot-toolbar nil + "Toolbar used by XEmacs." + :prefix "gnuplot-toolbar-" + :group 'gnuplot) + +(defcustom gnuplot-toolbar-display-flag gnuplot-xemacs-p + "*Non-nil means to display display a toolbar in XEmacs." + :group 'gnuplot-toolbar + :type 'boolean) + +(defcustom gnuplot-toolbar-use-toolbar (if (featurep 'toolbar) 'left-toolbar nil) + "*If nil, do not use a toolbar. +If it is non-nil, it must be a toolbar. The five legal values are +`default-toolbar', `top-toolbar', `bottom-toolbar', `right-toolbar', +and `left-toolbar', although choosing `default-toolbar' or +`top-toolbar' may be a bad idea since either will make the GNUPLOT +toolbar replace the standard toolbar. Changing this will not change +the toolbar in a currently existing buffer, but it will take effect +the next time you use `gnuplot-mode' and emacs. + +This is only used if a toolbar can be displayed, thus this is used in +XEmacs and ignored in FSF Emacs." + :type '(choice (const default-toolbar) + (const top-toolbar) + (const bottom-toolbar) + (const left-toolbar) + (const right-toolbar) + (const :tag "No toolbar" nil)) + :group 'gnuplot-toolbar) + +(defvar gnuplot-toolbar-location "") + +(defun gnuplot-toolbar-setup-toolbar (toolbar) + "Setup function for the `gnuplot-mode' toolbar. +TOOLBAR contains the toolbar specification. +This is basically swiped from VM." + (let ((width 46) (height 46) + (buffer (current-buffer)) + (frame (selected-frame)) + (tag-set '(win))) + (cond + ((eq (symbol-value gnuplot-toolbar-use-toolbar) right-toolbar) + (setq gnuplot-toolbar-location "right") + (set-specifier right-toolbar toolbar buffer) + (set-specifier right-toolbar-width width frame tag-set)) + ((eq (symbol-value gnuplot-toolbar-use-toolbar) left-toolbar) + (setq gnuplot-toolbar-location "left") + (set-specifier left-toolbar toolbar buffer) + (set-specifier left-toolbar-width width frame tag-set)) + ((eq (symbol-value gnuplot-toolbar-use-toolbar) bottom-toolbar) + (setq gnuplot-toolbar-location "bottom") + (set-specifier bottom-toolbar toolbar buffer) + (set-specifier bottom-toolbar-height height frame tag-set)) + ((eq (symbol-value gnuplot-toolbar-use-toolbar) top-toolbar) + (setq gnuplot-toolbar-location "top") + (set-specifier top-toolbar toolbar buffer) + (set-specifier top-toolbar-height height frame tag-set))) )) + +(defvar gnuplot-line-xpm + (if (featurep 'xpm) + (toolbar-make-button-list + "/* XPM */ +static char *line[] = { +/* width height num_colors chars_per_pixel */ +\" 40 40 5 1\", +/* colors */ +\". c #000000\", +\"a c #bebebe s backgroundToolBarColor\", +\"b c #2f4f4f\", +\"c c #ff6347\", +\"d c #0000ff\", +/* pixels */ +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaa..a..aaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaa..aaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaa..a..a....aaa...aaaaaaaaaaaa\", +\"aaaaaaaaaaaa..a..a..a..a..a..aaaaaaaaaaa\", +\"aaaaaaaaaaaa..a..a.aa..a.....aaaaaaaaaaa\", +\"aaaaaaaaaaa..a..a..a..a..aaaaaaaaaaaaaaa\", +\"aaaaaaaaaaa..a..a..a..a..a..aaaaaaaaaaaa\", +\"aaaaaaaaaaa..a..a..a..aa...aaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaa..aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaadaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaadaaaaaaaaa\", +\"aaaaaaa..aaaaaaaaaaaaaaaaaaaadaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaadaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaacaaaadaadaaaaaaaaaaaa\", +\"aaaaaaaa.caaadaaaccaccadaddaaaaaccaaaaaa\", +\"aaaaaaa..accdaddcaaaaaccaaaaaaccaaaaaaaa\", +\"aaaaaaaa.aadcaccdaaaadaaccaaccaaaaaaaaaa\", +\"aaaaaaaa.adaacaaaddadaaaaaccaaaaaaaaaaaa\", +\"aaaaaaaa.daaaaaaaaadaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaa..aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaa............................aaaaaa\", +\"aaaaaaaa.aaaa.aaaa.aaaa.aaaa.aaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"};") + "XPM format image used for the \"plot line\" button")) + +(defvar gnuplot-region-xpm + (if (featurep 'xpm) + (toolbar-make-button-list + "/* XPM */ +static char *region[] = { +/* width height num_colors chars_per_pixel */ +\" 40 40 5 1\", +/* colors */ +\". c #000000\", +\"a c #bebebe s backgroundToolBarColor\", +\"b c #2f4f4f\", +\"c c #ff6347\", +\"d c #0000ff\", +/* pixels */ +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaa..aaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaa.a..a...aaa....a..aa...aa....aaaaa\", +\"aaaaaa...a..a..a..a..a..a..a..a..a..aaaa\", +\"aaaaaa..aa.....a.aa..a....aa..a.aa..aaaa\", +\"aaaaa..a...aaaa..aa.a..a..aa....a..aaaaa\", +\"aaaaa..a...a..a..a..a..a..a..a..a..aaaaa\", +\"aaaa..aaaa...aaa....a..aa...aa..a..aaaaa\", +\"aaaaaaaaaaaaaaaaa..aaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaa...aaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaadaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaadaaaaaaaaa\", +\"aaaaaaa..aaaaaaaaaaaaaaaaaaaadaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaadaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaacaaaadaadaaaaaaaaaaaa\", +\"aaaaaaaa.caaadaaaccaccadaddaaaaaccaaaaaa\", +\"aaaaaaa..accdaddcaaaaaccaaaaaaccaaaaaaaa\", +\"aaaaaaaa.aadcaccdaaaadaaccaaccaaaaaaaaaa\", +\"aaaaaaaa.adaacaaaddadaaaaaccaaaaaaaaaaaa\", +\"aaaaaaaa.daaaaaaaaadaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaa..aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaa............................aaaaaa\", +\"aaaaaaaa.aaaa.aaaa.aaaa.aaaa.aaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"};") + "XPM format image used for the \"plot region\" button")) + +(defvar gnuplot-buffer-xpm + (if (featurep 'xpm) + (toolbar-make-button-list + "/* XPM */ +static char *buffer[] = { +/* width height num_colors chars_per_pixel */ +\" 40 40 5 1\", +/* colors */ +\". c #000000\", +\"a c #bebebe s backgroundToolBarColor\", +\"b c #2f4f4f\", +\"c c #ff6347\", +\"d c #0000ff\", +/* pixels */ +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa..aaaaaaaaaa......aaaaaaaaaaaaaa\", +\"aaaaaaaa..aaaaaaaaa..a..aaaaaaaaaaaaaaaa\", +\"aaaaaaa....aa..a.........a...aa.a.aaaaaa\", +\"aaaaaaa..a..a..a..a..a..a..a..a...aaaaaa\", +\"aaaaaaa.aa....aa..a..a..a.....a..aaaaaaa\", +\"aaaaaa...a.a..a..a..a..a..aaaa..aaaaaaaa\", +\"aaaaaa.....a..a..a..a..a..a..a..aaaaaaaa\", +\"aaaaaa....aaa..a.a..a..aa...aa..aaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaadaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaadaaaaaaaaa\", +\"aaaaaaa..aaaaaaaaaaaaaaaaaaaadaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaadaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaacaaaadaadaaaaaaaaaaaa\", +\"aaaaaaaa.caaadaaaccaccadaddaaaaaccaaaaaa\", +\"aaaaaaa..accdaddcaaaaaccaaaaaaccaaaaaaaa\", +\"aaaaaaaa.aadcaccdaaaadaaccaaccaaaaaaaaaa\", +\"aaaaaaaa.adaacaaaddadaaaaaccaaaaaaaaaaaa\", +\"aaaaaaaa.daaaaaaaaadaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaa..aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaa............................aaaaaa\", +\"aaaaaaaa.aaaa.aaaa.aaaa.aaaa.aaaaaaaaaaa\", +\"aaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"};") + "XPM format image used for the \"plot buffer\" button")) + +(defvar gnuplot-doc-xpm + (if (featurep 'xpm) + (toolbar-make-button-list + "/* XPM */ +static char *book_index[] = { +/* width height num_colors chars_per_pixel */ +\" 40 40 6 1\", +/* colors */ +\". c #000000\", +\"a c #bebebe s backgroundToolBarColor\", +\"b c #2f4f4f\", +\"c c #ff0000\", +\"d c #ffffff\", +\"e c #708090\", +/* pixels */ +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaa.........bbeaaaebb..........aaaaaa\", +\"aaaaaa.ddddddddaaebebeaaddddddddd.aaaaaa\", +\"aaaa...dab.bddeebadbdaeebedeeeeed...aaaa\", +\"aaaa.c.dbaddddebeedbdeebeedebebed.c.aaaa\", +\"aaaa.c.d.de.edeebeabdbbeeddebbbed.c.aaaa\", +\"aaaa.c.dbad.ddebeadbdeeebeddeeeed.c.aaaa\", +\"aaaa.c.dab..ddeeeedbdebeeedebebed.c.aaaa\", +\"aaaa.c.dddddddeebeabdebebedeebedd.c.aaaa\", +\"aaaa.c.debebedebeedbdbebeedbeeeeb.c.aaaa\", +\"aaaa.c.debeeedeeeaabdaaddddebedbb.c.aaaa\", +\"aaaa.c.deebeddbebedbdbaa.adeeedeb.c.aaaa\", +\"aaaa.c.ddeebedeeebaba.dd.dddeeedd.c.aaaa\", +\"aaaa.c.debeebdbeeedbd....ddeebeed.c.aaaa\", +\"aaaa.c.deebeedeebadbd.dd.ddeeeedd.c.aaaa\", +\"aaaa.c.dbbebddeeeeabd.aa.adebebbd.c.aaaa\", +\"aaaa.c.deeeeedeebeabaedddddeeeedd.c.aaaa\", +\"aaaa.c.dbebbbdebeadbdaeeeedebeeed.c.aaaa\", +\"aaaa.c.deeebddeeebdbdeebeedeebeed.c.aaaa\", +\"aaaa.c.debeeedebeeabdebebedebeebd.c.aaaa\", +\"aaaa.c.deebbedeeeedbdeeeeddeeeeed.c.aaaa\", +\"aaaa.c.dddddddddaadbdaddddddddddd.c.aaaa\", +\"aaaa.c..........beabaeb...........c.aaaa\", +\"aaaa.c.bbbbbbbbbb.bbbbbbbbbbbbbbb.c.aaaa\", +\"aaaa.c.bbbbbbbbbb..e.bbbbbbbbbbbb.c.aaaa\", +\"aaaa.c.bbbbbbbbbb.b.bbbbbbbbbbbbb.c.aaaa\", +\"aaaa.c............e.e.............c.aaaa\", +\"aaaa.cccccccccccc.a.a.ccccccccccccc.aaaa\", +\"aaaa................................aaaa\", +\"aaaaaaaaaaaaaaaaaa...aaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"};") + "XPM format image used for the \"document\" button")) + +(defvar gnuplot-help-xpm + (if (featurep 'xpm) + (toolbar-make-button-list + "/* XPM */ +static char *help_btn[] = { +/* width height num_colors chars_per_pixel */ +\" 40 40 3 1\", +/* colors */ +\"a c #bebebe s backgroundToolBarColor\", +\"b c #000000\", +\"c c #ff0000\", +/* pixels */ +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabbbbbbbbaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaabbbccccccccbbbaaaaaaaaaaaaa\", +\"aaaaaaaaaaabbccccccccccccccbbaaaaaaaaaaa\", +\"aaaaaaaaaabccccccccccccccccccbaaaaaaaaaa\", +\"aaaaaaaaabccccccccccccccccccccbaaaaaaaaa\", +\"aaaaaaaabcccccccbbbbbbbbcccccccbaaaaaaaa\", +\"aaaaaaaabccccbbbaaaaaaaabbbccccbaaaaaaaa\", +\"aaaaaaabccccbaaaaaaaaaaaaaabccccbaaaaaaa\", +\"aaaaaaabcccbaaaaaaaaaaaaaaaabcccbaaaaaaa\", +\"aaaaaaabcccbaaaaaaaaaaaaaaaabcccbaaaaaaa\", +\"aaaaaaabcccbaaaaaaaaaaaaaaaabcccbaaaaaaa\", +\"aaaaaaabbbbbaaaaaaaaaaaaaaabccccbaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaabbbccccbaaaaaaaa\", +\"aaaaaaaaaaaaaaaabbbbbbbbcccccccbaaaaaaaa\", +\"aaaaaaaaaaaaaaaabcccccccccccccbaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabccccccccccccbaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabccccccccccbbaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabccccbbbbbbaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabccccbaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabccccbaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabbbbbbaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabbbbbbaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabccccbaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabccccbaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabccccbaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaabbbbbbaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\", +\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"};") + "XPM format image used for the \"help\" button")) + +(defvar gnuplot-toolbar + '([gnuplot-line-xpm + gnuplot-line-fn t "Plot the line under point"] + [gnuplot-region-xpm + gnuplot-region-fn t "Plot the selected region"] + [gnuplot-buffer-xpm + gnuplot-buffer-fn t "Plot the entire buffer"] + [:style 3d :size 8] + [gnuplot-help-xpm + gnuplot-help-fn t "Look at the gnuplot process buffer"] + [gnuplot-doc-xpm + gnuplot-doc-fn t "Look at the gnuplot document"]) + "The gnuplot toolbar.") + +(fset 'gnuplot-line-fn 'gnuplot-send-line-and-forward) +(fset 'gnuplot-region-fn 'gnuplot-send-region-to-gnuplot) +(fset 'gnuplot-buffer-fn 'gnuplot-send-buffer-to-gnuplot) +(fset 'gnuplot-help-fn 'gnuplot-show-gnuplot-buffer) +(fset 'gnuplot-doc-fn 'gnuplot-info-lookup-symbol) + +(defvar gnuplot-all-buttons-defined + (and (listp gnuplot-line-xpm) (listp gnuplot-region-xpm) + (listp gnuplot-buffer-xpm) (listp gnuplot-doc-xpm) + (listp gnuplot-help-xpm))) + + +(defun gnuplot-make-toolbar-function () + (if (and gnuplot-xemacs-p gnuplot-all-buttons-defined) + (progn + ;;(remove-specifier gnuplot-toolbar-use-toolbar (current-buffer)) + (gnuplot-toolbar-setup-toolbar gnuplot-toolbar) + (add-spec-to-specifier (symbol-value gnuplot-toolbar-use-toolbar) + gnuplot-toolbar + (current-buffer) )))) + +;;(defalias 'gnuplot-make-toolbar 'gnuplot-make-toolbar-function) + + + +;;; --- syntax colorization, syntax table + +(defvar gnuplot-mode-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?* "." table) + (modify-syntax-entry ?+ "." table) + (modify-syntax-entry ?- "." table) + (modify-syntax-entry ?/ "." table) + (modify-syntax-entry ?% "." table) + (modify-syntax-entry ?= "." table) + (modify-syntax-entry ?: "." table) + (modify-syntax-entry ?& "." table ) ; rarely used + (modify-syntax-entry ?^ "." table ) ; operators + (modify-syntax-entry ?| "." table ) ; in gnuplot, + (modify-syntax-entry ?& "." table ) ; (by me, + (modify-syntax-entry ?? "." table ) ; anyway...) + (modify-syntax-entry ?~ "." table ) ; + + (modify-syntax-entry ?_ "w" table ) + + ;; In GNU Emacs >=24 we can use `syntax-propertize-function' to + ;; accurately scan for strings and comments (see + ;; `gnuplot-syntax-propertize'). If there's no + ;; `syntax-propertize', fall back to using the built-in parser and + ;; making ", ', and # string or comment delimiters as normal. + (if (not (boundp 'syntax-propertize-function)) + (progn + (modify-syntax-entry ?\' "\"" table) + (modify-syntax-entry ?# "<" table) + (modify-syntax-entry ?\n ">" table) + (modify-syntax-entry ?\\ "\\" table)) + + ;; When syntax-propertize is available, ", ', and # should be + ;; punctuation so that the built-in parser doesn't interfere + ;; with the syntax-propertize search. + (modify-syntax-entry ?\" "." table) + (modify-syntax-entry ?\' "." table) + (modify-syntax-entry ?` "." table) + (modify-syntax-entry ?\\ "." table)) + + table) + + "Syntax table in use in `gnuplot-mode' buffers. +This is the same as the standard syntax table except that ` and _ +are word characters, and math operators are punctuation +characters.") + +;; Macro to generate efficient regexps for keyword matching +;; +;; These regular expressions treat the gnuplot vocabulary as complete +;; words. Although gnuplot will recognise unique abbreviations, these +;; regular expressions will not. +(defmacro gnuplot-make-regexp (list) + `(regexp-opt ,list 'words)) + +;; Lists of gnuplot keywords for syntax coloring etc. +(defvar gnuplot-keywords-builtin-functions + '("abs" "acosh" "acos" "arg" "asinh" "asin" "atan" "atanh" "atan2" "besj1" + "besj0" "besy1" "besy0" "ceil" "column" "cosh" "cos" "erfc" "erf" "exp" + "floor" "gamma" "ibeta" "igamma" "imag" "int" "inverf" "invnorm" "lgamma" + "log" "log10" "norm" "rand" "real" "sgn" "sinh" "sin" "sqrt" "tanh" "tan" + "tm_hour" "tm_mday" "tm_min" "tm_mon" "tm_sec" "tm_wday" "tm_yday" "tm_year" + "valid" "EllipticPi" "EllipticE" "EllipticK" "words" "word" "value" + "timecolumn" "substr" "strstrt" "strptime" "strlen" "stringcolumn" + "strftime" "sprintf" "lambertw" "gprintf" "exists" "defined" "columnhead") + + "List of GNUPLOT built-in functions, as strings. + +These are highlighted using `font-lock-function-name-face'.") + +(defvar gnuplot-keywords-plotting + '("axes" "every" "index" "lw" "lt" "ls" "linestyle" "linetype" "linewidth" + "notitle" "pt" "ps" "pointsize" "pointtype" "smooth" "thru" "title" "using" + "with" "noautoscale" "volatile" "matrix" "nonuniform" "binary" "fillstyle" + "linecolor" "pointinterval" "nosurface" "nocontours" "nohidden3d") + "List of GNUPLOT keywords associated with plotting, as strings. + +These are highlighted using `font-lock-type-face'. +This list does not include plotting styles -- for that, see +`gnuplot-keywords-plotting-styles'") + +(defvar gnuplot-keywords-plotting-styles + '("boxerrorbars" "boxes" "boxxyerrorbars" "candlesticks" "dots" "errorbars" + "financebars" "fsteps" "histeps" "impulses" "lines" "linespoints" "points" + "steps" "vector" "xerrorbars" "xyerrorbars" "yerrorbars" "vectors" + "filledcurves" "labels" "rgbalpha" "rgbimage" "image" "circles" "pm3d" + "histograms" "xyerrorlines" "xerrorlines" "errorlines" "yerrorlines") + + "List of GNUPLOT plotting styles, as strings. + +These are highlighted using `font-lock-function-name-face'.") + +(defvar gnuplot-keywords-misc + '("bind" "cd" "clear" "exit" "fit" "help" "history" "load" "pause" "print" + "pwd" "quit" "replot" "save" "set" "show" "unset" "if" "else" "do" "update" + "undefine" "test" "system" "raise" "lower" "eval" "shell" "reset" "reread" + "refresh" "call") + "List of GNUPLOT miscellaneous commands, as strings. + +These are highlighted using `font-lock-constant-face'.") + +(defvar gnuplot-keywords-negatable-options + '("arrow" "autoscale" "border" "clabel" "clip" "contour" "dgrid3d" "grid" + "hidden3d" "historysize" "key" "label" "linestyle" "logscale" "mouse" + "multiplot" "mx2tics" "mxtics" "my2tics" "mytics" "mztics" "offsets" "polar" + "surface" "timestamp" "title" "x2dtics" "x2mtics" "x2tics" "x2zeroaxis" + "xdtics" "xmtics" "xtics" "xzeroaxis" "y2dtics" "y2mtics" "y2tics" + "y2zeroaxis" "ydtics" "ymtics" "ytics" "yzeroaxis" "zdtics" "zmtics" "ztics" + "zzeroaxis") + + "List of gnuplot options which can be negated using `gnuplot-negate-option'") + +(defvar gnuplot-negatable-options-regexp + (gnuplot-make-regexp gnuplot-keywords-negatable-options)) + +;; Set up colorization for gnuplot. +;; This handles font-lock for emacs and xemacs. +(defvar gnuplot-font-lock-keywords nil) +(defvar gnuplot-font-lock-syntactic-keywords nil) +(defvar gnuplot-font-lock-defaults nil) + +(when (featurep 'font-lock) ; + (setq gnuplot-font-lock-keywords + (list + ;; stuff in brackets, sugg. by + '("\\[\\([^]]+\\)\\]" 1 font-lock-constant-face) + + ;; variable/function definitions + '("\\(\\(\\sw\\|\\s_\\)+\\s-*\\((\\s-*\\(\\sw\\|\\s_\\)*\\s-*\\(,\\s-*\\sw*\\)*\\s-*)\\)?\\s-*=\\)[^=]" + 1 font-lock-variable-name-face) + + ;; built-in function names + (cons (gnuplot-make-regexp gnuplot-keywords-builtin-functions) + font-lock-function-name-face) + + ;; reserved words associated with plotting + (cons (gnuplot-make-regexp gnuplot-keywords-plotting) + font-lock-type-face) + (cons (gnuplot-make-regexp gnuplot-keywords-plotting-styles) + font-lock-function-name-face) + + ;; (s)plot -- also thing (s)plotted + '("\\" . font-lock-keyword-face) + ;; '("\\ + (gnuplot-beginning-of-continuation) + (setq start (point)) + (end-of-line) + (while (save-excursion + (backward-char) + (looking-at "\\\\")) ; go to end of last continuation line + (end-of-line 2)) + (beginning-of-line 2) + (setq end (point))) + (if (not (string-match "\\`\\s-*\\'" + (buffer-substring-no-properties start end))) + (gnuplot-send-region-to-gnuplot start end 'line)) + end)) + (t + (message "You can only send lines in gnuplot-mode buffers to gnuplot.") + nil))) + +;; I chose a very easy to type but slightly non-mnemonic key-binding +;; for this (C-c C-v). It seems like the kind of thing one would want +;; to do repeatedly without incurring RSI. 8^) +(defun gnuplot-send-line-and-forward (&optional num) + "Call `gnuplot-send-line-to-gnuplot' and move forward 1 line. +You can use a numeric prefix to send more than one line. Blank lines and +lines with only comments are skipped when moving forward." + (interactive "p") + (let (end) + (while (> num 0) + (setq end (gnuplot-send-line-to-gnuplot)) + (goto-char end) + (backward-char 1) ; + (gnuplot-forward-script-line 1) + (setq num (1- num))))) + +(defun gnuplot-send-line-and-newline () + "Call `gnuplot-send-line-to-gnuplot' and insert a new line." + (interactive) + (end-of-line) + (gnuplot-send-line-to-gnuplot) + (insert "\n")) + +(defun gnuplot-forward-script-line (&optional num) ; + "Move forward my NUM script lines. +Blank lines and commented lines are not included in the NUM count." + (interactive "p") + (while (> num 0) + (and (not (eobp)) (forward-line 1)) + (while (and (not (eobp)) + (or (looking-at "^\\s-*$") + (looking-at "^\\s-*#"))) + (forward-line 1)) + (setq num (1- num)))) + +(defun gnuplot-send-buffer-to-gnuplot () + "Sends the entire buffer to the gnuplot program. +This sets `gnuplot-recently-sent' to 'buffer." + (interactive) + (if (equal major-mode 'gnuplot-mode) + (gnuplot-send-region-to-gnuplot (point-min) (point-max) 'buffer) + (message "You can only send gnuplot-mode buffers to gnuplot."))) + +(defun gnuplot-send-file-to-gnuplot () + "Sends a selected file to the gnuplot program using the \"load\" command. +This sets `gnuplot-recently-sent' to 'file." + (interactive) + (let ((string (read-file-name "Name of file to send to gnuplot > " nil nil t))) + (setq string (concat "load '" (expand-file-name string) "'\n")) + (message "%S" string) + (gnuplot-make-gnuplot-buffer) ; make sure a gnuplot buffer exists + (gnuplot-send-string-to-gnuplot string 'file))) + +;; suggested by +(defun gnuplot-plot-from-comint () + "Send the contents of a script to gnuplot from the process buffer. +This inserts the contents of the most recently used gnuplot script +into the process buffer and sends those lines to gnuplot. It does +this by copying the script line by line." + (interactive) + (if (not (buffer-live-p gnuplot-comint-recent-buffer)) + (message "Script buffer has been deleted.") + (let (string list (buffer (current-buffer))) + (set-buffer gnuplot-comint-recent-buffer) + (setq string (buffer-substring-no-properties (point-min) (point-max)) + string (concat string "\n") + list (gnuplot-split-string string)) + (set-buffer buffer) + (while list + (insert (car list)) + (comint-send-input) + (sleep-for gnuplot-delay) + (setq list (cdr list))) + (comint-send-input)))) + +(defun gnuplot-save-and-plot-from-comint () + "Send a current script to gnuplot from the process buffer. +This sends the most recently used gnuplot script to gnuplot using the +\"load\" command. This function first saves the script buffer to a +file, prompting for a filename if one is not associated with the script +buffer. Then it sends a load command to gnuplot using the name of the +file visited by the script buffer." + (interactive) + (if (not (buffer-live-p gnuplot-comint-recent-buffer)) + (message "Script buffer has been deleted.") + (let (fname) + (with-current-buffer gnuplot-comint-recent-buffer + (save-buffer) + (setq fname (buffer-file-name))) + (goto-char (point-max)) + (insert (format "load '%s'" fname)) + (comint-send-input)))) + +(defun gnuplot-pop-to-recent-buffer () + "Switch to the most recently-plotted gnuplot script buffer." + (interactive) + (when (buffer-live-p gnuplot-comint-recent-buffer) + (pop-to-buffer gnuplot-comint-recent-buffer))) + +(defun gnuplot-trim-gnuplot-buffer () + "Trim lines from the beginning of the *gnuplot* buffer. +This keeps that buffer from growing excessively in size. Normally, +this function is attached to `gnuplot-after-plot-hook'" + (if (> gnuplot-buffer-max-size 0) + (with-current-buffer gnuplot-buffer + (let ((nlines (count-lines (point-min) (point-max))) + (kill-whole-line t)) + (while (> nlines gnuplot-buffer-max-size) + (goto-char (point-min)) + (kill-line) + (setq nlines (1- nlines))) + (goto-char (point-max)) )))) +(add-hook 'gnuplot-after-plot-hook 'gnuplot-trim-gnuplot-buffer nil nil) + + +;;; --- functions controlling the gnuplot process + +;; Menu for the comint-mode buffer +(defvar gnuplot-comint-menu + `("Gnuplot" + ["Plot most recent gnuplot buffer" gnuplot-plot-from-comint + (buffer-live-p gnuplot-comint-recent-buffer)] + ["Save and plot most recent gnuplot buffer" gnuplot-save-and-plot-from-comint + (buffer-live-p gnuplot-comint-recent-buffer)] + "---" + ,gnuplot-display-options-menu + ["Contextual completion and help" gnuplot-context-sensitive-mode + :style toggle + :selected gnuplot-context-sensitive-mode] + ["Echo area help (eldoc-mode)" eldoc-mode + :active gnuplot-context-sensitive-mode + :style toggle + :selected eldoc-mode] + "---" + ["Insert filename at point" gnuplot-insert-filename t] + ["Negate set option" gnuplot-negate-option t] + ["Keyword help" gnuplot-info-lookup-symbol + (or gnuplot-keywords gnuplot-keywords-pending)] + ["Quick help for thing at point" gnuplot-help-function + gnuplot-context-sensitive-mode] + ["Info documentation on thing at point" + gnuplot-info-at-point + gnuplot-context-sensitive-mode] + ["Switch to recent gnuplot script buffer" gnuplot-pop-to-recent-buffer + (buffer-live-p gnuplot-comint-recent-buffer)] + "---" + ["Customize gnuplot" gnuplot-customize t] + ["Submit bug report" gnuplot-bug-report t] + ["Show gnuplot-mode version" gnuplot-show-version t] + ["Show gnuplot version" gnuplot-show-gnuplot-version t] + "---" + ["Kill gnuplot" gnuplot-kill-gnuplot-buffer t] + )) + +;; Major mode `gnuplot-comint-mode' for the interaction buffer +(define-derived-mode gnuplot-comint-mode comint-mode "Gnuplot interaction" + "Major mode for interacting with a gnuplot process in a buffer. + +This sets font-lock and keyword completion in the comint/gnuplot +buffer." + + (set-syntax-table gnuplot-mode-syntax-table) + + (if gnuplot-xemacs-p ; deal with font-lock + (if (fboundp 'turn-on-font-lock) (turn-on-font-lock)) + (progn + (setq font-lock-defaults gnuplot-font-lock-defaults) + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (set (make-local-variable 'syntax-propertize-function) + #'gnuplot-syntax-propertize))) + + ;; XEmacs needs the call to make-local-hook + (when (and (featurep 'xemacs) + (fboundp 'make-local-hook)) + (make-local-hook 'kill-buffer-hook)) + (add-hook 'kill-buffer-hook 'gnuplot-close-down nil t) + + (add-hook 'comint-output-filter-functions + 'comint-postoutput-scroll-to-bottom + nil t) + (add-hook 'comint-output-filter-functions + 'gnuplot-protect-prompt-fn + nil t) + + ;; Set up completion, using completion-at-point in recent Emacs, + ;; comint-dynamic-complete in older Emacs + (if (and (>= emacs-major-version 24) + (>= emacs-minor-version 1)) + (add-hook 'completion-at-point-functions #'gnuplot-completion-at-point nil t) + (add-hook 'comint-dynamic-complete-functions 'gnuplot-comint-complete nil t)) + + ;; Set up menu (see below) + (easy-menu-define + gnuplot-comint-mode-menu gnuplot-comint-mode-map "Menu used in gnuplot-comint-mode" + gnuplot-comint-menu) + (easy-menu-add gnuplot-comint-mode-menu gnuplot-comint-mode-map)) + +;; Key bindings for gnuplot-comint-mode +(define-key gnuplot-comint-mode-map "\M-\C-p" 'gnuplot-plot-from-comint) +(define-key gnuplot-comint-mode-map "\M-\C-f" 'gnuplot-save-and-plot-from-comint) +(define-key gnuplot-comint-mode-map "\C-d" 'gnuplot-delchar-or-maybe-eof) +(let ((completion-function + (if (and (>= emacs-major-version 24) + (>= emacs-minor-version 1)) + 'completion-at-point + 'comint-dynamic-complete))) + (define-key gnuplot-comint-mode-map "\M-\r" completion-function) + (define-key gnuplot-comint-mode-map "\M-\t" completion-function)) +(define-key gnuplot-comint-mode-map "\C-c\C-d" 'gnuplot-info-lookup-symbol) +(define-key gnuplot-comint-mode-map "\C-c\C-w" 'gnuplot-show-version) +(define-key gnuplot-comint-mode-map "\C-c\C-i" 'gnuplot-insert-filename) +(define-key gnuplot-comint-mode-map "\C-c\C-n" 'gnuplot-negate-option) +(define-key gnuplot-comint-mode-map "\C-c\C-p" 'gnuplot-show-gnuplot-version) +(define-key gnuplot-comint-mode-map "\C-c\C-u" 'gnuplot-bug-report) +(define-key gnuplot-comint-mode-map "\C-c\C-z" 'gnuplot-customize) +(define-key gnuplot-comint-mode-map "\C-c\C-e" 'gnuplot-pop-to-recent-buffer) +(define-key gnuplot-comint-mode-map "\C-c\M-i" 'gnuplot-inline-image-mode) + +;; Menu for gnuplot-comint-mode +(defvar gnuplot-comint-mode-menu nil + "Menu for `gnuplot-comint-mode'.") + +;; Switch to the gnuplot program buffer +(defun gnuplot-make-gnuplot-buffer () + "Switch to the gnuplot program buffer or create one if none exists." + (unless (and gnuplot-process (eq (process-status gnuplot-process) 'run) + gnuplot-buffer (buffer-live-p gnuplot-buffer)) + (message "Starting gnuplot plotting program...") + (setq gnuplot-buffer (make-comint gnuplot-process-name gnuplot-program) + gnuplot-process (get-buffer-process gnuplot-buffer)) + (gnuplot-set-process-query-on-exit-flag gnuplot-process nil) + (with-current-buffer gnuplot-buffer + (gnuplot-comint-mode) + (when gnuplot-inline-image-mode + (sleep-for gnuplot-delay) + (gnuplot-setup-comint-for-image-mode))) + (message "Starting gnuplot plotting program...Done"))) + + +(defun gnuplot-fetch-version-number () + "Determine the installed version of the gnuplot program. + +If `gnuplot-program-version' is already set, does +nothing. Otherwise, runs `gnuplot-program' and searches the text +printed at startup for a string like \"Version N.N\". + +Sets the variables `gnuplot-program-version', +`gnuplot-program-major-version', `gnuplot-program-minor-version', +and `gnuplot-three-eight-p'. + +If the version number cannot be determined by this method, it +defaults to 3.7." + (unless gnuplot-program-version + (message "gnuplot-mode %s -- determining gnuplot version ......" + gnuplot-version) + (with-temp-buffer + (insert "show version") + (call-process-region (point-min) (point-max) + gnuplot-program t (current-buffer)) + (goto-char (point-min)) + (if (and (re-search-forward "[Vv]ersion\\s-+" (point-max) t) + (looking-at "\\([0-9]\\)\\.\\([0-9]+\\)")) + (progn + (setq gnuplot-program-version (match-string 0) + gnuplot-program-major-version (string-to-number + (match-string 1)) + gnuplot-program-minor-version (string-to-number + (match-string 2)) + gnuplot-three-eight-p + (>= (string-to-number gnuplot-program-version) 3.8))) + + ;; Guess v3.7 if something went wrong + (message "Warning: could not determine gnuplot version, guessing 3.7") + (setq gnuplot-program-version "3.7" + gnuplot-program-major-version 3 + gnuplot-program-minor-version 7 + gnuplot-three-eight-p nil))) + + ;; Setup stuff that depends on version number + (gnuplot-setup-menu-and-toolbar))) + +(defun gnuplot-setup-menu-and-toolbar () + ;; set up the menubar (possibly dependent on version number) + (gnuplot-setup-menubar) + ;; set up the toolbar (possibly dependent on version number) + (if (and gnuplot-xemacs-p gnuplot-toolbar-display-flag) + (condition-case () ; deal with the toolbar + (and (require 'toolbar) + (require 'xpm) + (gnuplot-make-toolbar-function)) + (error nil))) + (message "gnuplot-mode %s (gnuplot %s) -- report bugs with %S" + gnuplot-version gnuplot-program-version + (substitute-command-keys "\\[gnuplot-bug-report]"))) + +(defvar gnuplot-prompt-regexp + (regexp-opt '("gnuplot> " "multiplot> ")) + "Regexp for recognizing the GNUPLOT prompt") + +(defun gnuplot-protect-prompt-fn (string) + "Prevent the Gnuplot prompt from being deleted or overwritten. +STRING is the text as originally inserted in the comint buffer." + (save-excursion + (let ((b (progn + (goto-char (point-max)) + (beginning-of-line) + (point))) + e) + (if (re-search-forward gnuplot-prompt-regexp (point-max) t) + (progn + (setq e (point)) + (put-text-property b e 'rear-nonsticky '(read-only intangible face)) + (put-text-property b e 'intangible t) + (put-text-property b e 'face 'gnuplot-prompt-face) + ;;(put-text-property b e 'read-only t) + )) ))) + +(defun gnuplot-close-down () + "Tidy up when deleting the gnuplot buffer." + (if (and gnuplot-process + (eq (process-status gnuplot-process) 'run)) ; + (kill-process gnuplot-process)) + (setq gnuplot-process nil + gnuplot-buffer nil)) + +(defun gnuplot-delchar-or-maybe-eof (arg) + "Delete ARG characters forward, or (if at eob) send an EOF to subprocess. +This is very similar to `comint-delchar-or-maybe-eof'." + (interactive "p") + (if (eobp) + (gnuplot-kill-gnuplot-buffer) + (delete-char arg))) + +(defun gnuplot-kill-gnuplot-buffer () + "Kill the gnuplot process and its display buffers." + (interactive) + (if (and gnuplot-process + (eq (process-status gnuplot-process) 'run)) ;; + (kill-process gnuplot-process)) + (if (and gnuplot-buffer (get-buffer gnuplot-buffer)) + (progn + (if (one-window-p) () + (delete-window (get-buffer-window gnuplot-buffer))) + (kill-buffer gnuplot-buffer))) + (setq gnuplot-process nil + gnuplot-buffer nil)) + + +(defun gnuplot-show-gnuplot-buffer () + "Switch to the buffer containing the gnuplot process. +When `gnuplot-display-process' is nil this will switch to +the gnuplot process buffer. When that variable is non-nil, the +gnuplot process buffer will be displayed in a window." + (interactive) + (unless (and gnuplot-buffer (get-buffer gnuplot-buffer)) + (gnuplot-make-gnuplot-buffer)) + (cond ((equal gnuplot-display-process 'window) + (switch-to-buffer-other-window gnuplot-buffer)) + ((equal gnuplot-display-process 'frame) + (or (and gnuplot-process-frame + (frame-live-p gnuplot-process-frame)) + (setq gnuplot-process-frame (make-frame))) + (raise-frame gnuplot-process-frame) + (select-frame gnuplot-process-frame) + (switch-to-buffer gnuplot-buffer)) + (t + (switch-to-buffer gnuplot-buffer)))) + + +;;; Support for displaying plotted images within Emacs + +(defvar gnuplot-inline-image-filename nil + "Name of the current Gnuplot output file.") + +(defvar gnuplot-image-buffer-name "*gnuplot output*") + +(defun gnuplot-display-images-p () + ;; Inline images require GNU Emacs. + (and (not (featurep 'xemacs)) + (fboundp 'display-images-p) + (display-images-p))) + +(defun gnuplot-external-display-mode () + (interactive) + (gnuplot-set-display-mode 'gnuplot-inline-image-mode nil)) + +(defun gnuplot-inline-display-mode () + (interactive) + (gnuplot-set-display-mode 'gnuplot-inline-image-mode 'inline)) + +(defun gnuplot-dedicated-display-mode () + (interactive) + (gnuplot-set-display-mode 'gnuplot-inline-image-mode 'dedicated)) + +(defun gnuplot-set-image-format (format) + (interactive "sGnuplot image format: ") + (gnuplot-set-display-mode 'gnuplot-image-format format) + (unless gnuplot-inline-image-mode + (message "Setting will take effect when plots are displayed in Emacs"))) + +(defun gnuplot-setup-comint-for-image-mode () + (when (and gnuplot-buffer (buffer-live-p gnuplot-buffer) + (get-buffer-process gnuplot-buffer)) + (with-current-buffer gnuplot-buffer + (if gnuplot-inline-image-mode + (progn + (gnuplot-send-hiding-output + (format "set terminal %s\n" gnuplot-image-format)) + (gnuplot-inline-image-set-output) + (add-hook 'comint-output-filter-functions + 'gnuplot-insert-inline-image-output nil t)) + (gnuplot-send-hiding-output "set terminal pop\n") + (remove-hook 'comint-output-filter-functions + 'gnuplot-insert-inline-image-output t))))) + +(defun gnuplot-inline-image-set-output () + "Set Gnuplot's output file to `gnuplot-inline-image-filename'." + (let ((tmp (make-temp-file "gnuplot"))) + (setq gnuplot-inline-image-filename tmp) + (gnuplot-send-hiding-output (format "set output '%s'\n" tmp)))) + +(defvar gnuplot-inhibit-filter nil) + +(defun gnuplot-insert-inline-image-output (string) + "Insert Gnuplot graphical output in the gnuplot-comint buffer. + +Called via `comint-preoutput-filter-functions' hook when +`gnuplot-inline-image-mode' is enabled. Checks the status of the +file `gnuplot-inline-image-filename'; if it exists and has +nonzero size, inserts it as an inline image, stores a new +temporary filename in `gnuplot-inline-image-filename', and +updates Gnuplot with the appropriate 'set output' command." + (unless gnuplot-inhibit-filter ; Prevent recursively entering this filter + (let ((gnuplot-inhibit-filter t)) ; (causing an infinite loop) + (save-excursion + (goto-char (point-max)) + (beginning-of-line) + (when (looking-at gnuplot-prompt-regexp) + (let* ((filename gnuplot-inline-image-filename) + (size (nth 7 (file-attributes filename)))) + (when (and size (> size 0)) + (gnuplot-send-hiding-output "set output\n") ; Flush output file + (sit-for 0.1) ; Hack: wait for Gnuplot IO to finish + (ecase gnuplot-inline-image-mode + (nil nil) + (inline + (ignore-errors + (let ((image (create-image filename))) + (beginning-of-line) + (insert-image image) + (insert "\n") + (gnuplot-inline-image-set-output)))) + (dedicated + (with-current-buffer + (get-buffer-create gnuplot-image-buffer-name) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert-file-contents filename) + (ignore-errors (normal-mode)) + (display-buffer (current-buffer)) + (gnuplot-inline-image-set-output)))))))))))) + +;;; Send commands to GNUPLOT silently & without generating an extra prompt +(defvar gnuplot-hidden-output-buffer " *gnuplot output*") + +(defun gnuplot-send-hiding-output (string) + "Send STRING to the running Gnuplot process invisibly." + (with-current-buffer gnuplot-buffer + (add-hook 'comint-preoutput-filter-functions + 'gnuplot-discard-output nil t)) + (with-current-buffer (get-buffer-create gnuplot-hidden-output-buffer) + (erase-buffer)) + (comint-send-string (get-buffer-process gnuplot-buffer) string)) + +(defun gnuplot-discard-output (string) + ;; Temporary preoutput filter for hiding Gnuplot output & prompt. + ;; Accumulates output in a buffer until it finds the next prompt, + ;; then removes itself from comint-preoutput-filter-functions. + (with-current-buffer + (get-buffer-create gnuplot-hidden-output-buffer) + (insert string) + (when (looking-back gnuplot-prompt-regexp) + (with-current-buffer gnuplot-buffer + (remove-hook 'comint-preoutput-filter-functions + 'gnuplot-discard-output t)))) + "") + + + +;;; --- miscellaneous functions: insert file name, indentation, negation + +(defun gnuplot-insert-filename () + "Insert a filename at point, prompting for name in the minibuffer. +This inserts a filename relative to the buffer's default directory. +Uses completion and the value of `gnuplot-quote-character'. +Bound to \\[gnuplot-insert-filename]" + (interactive) + (insert gnuplot-quote-character + (file-relative-name (read-file-name "Filename > " "") + default-directory) + gnuplot-quote-character) ) + + +;; Adjust indentation for the line containing point +(defun gnuplot-indent-line () + "Set indentation in gnuplot buffer. +For most lines, set indentation to previous level of indentation. +Add additional indentation for continuation lines." + (interactive) + (let (indent) + (if (gnuplot-in-string (point-at-bol)) + ;; Continued strings begin at left margin + (setq indent 0) + (save-excursion + (if (gnuplot-continuation-line-p) + ;; This is a continuation line. Indent to the same level as + ;; the second word on the line beginning this command (i.e., + ;; the first non-whitespace character after whitespace) + (progn + (gnuplot-beginning-of-continuation) + (back-to-indentation) + (re-search-forward "\\S-+\\s-+" (point-at-eol) 'end-at-limit) + (setq indent (- (point) (point-at-bol)))) + + ;; Not a continuation line; indent according to block + ;; nesting depth + (save-excursion + (condition-case nil + (progn + (beginning-of-line) + (skip-syntax-forward "-" (point-at-eol)) + (if (looking-at "\\s)") (forward-char)) + (backward-up-list) + (gnuplot-beginning-of-continuation) + (setq indent (+ gnuplot-basic-offset (current-indentation)))) + (error + (setq indent 0))))))) + + ;; Set indentation + (save-excursion + (indent-line-to indent)) + + ;; Move point after indentation when at beginning of line + (let ((point-at-indent (+ (point-at-bol) indent))) + (when (< (point) point-at-indent) (goto-char point-at-indent))))) + +;; Adjust indentation on inserting a close brace +;; The blink-paren fix is stolen from cc-mode +(defun gnuplot-electric-insert (arg) + (interactive "*p") + (let ((old-blink-paren blink-paren-function) + (blink-paren-function nil)) + (self-insert-command arg) + (gnuplot-indent-line) + (when old-blink-paren (funcall old-blink-paren)))) + +;; +;; Functions for finding the start and end of continuation blocks +;; + +;; Check if line containing point is a continuation +(defun gnuplot-continuation-line-p () + "Return t if the line containing point is a continuation of the previous line." + (save-excursion + (condition-case () + (progn + (end-of-line 0) + (backward-char) + (looking-at "\\\\")) + (error nil)))) + +;; Move point to start of continuation block +(defun gnuplot-beginning-of-continuation () + "Move point to the beginning of the continuation lines containing point. + +If not in a continuation line, move point to beginning of line." + (beginning-of-line) + (while (gnuplot-continuation-line-p) + (beginning-of-line 0))) + +;; Move point to end of continuation block +(defun gnuplot-end-of-continuation () + "Move point to the end of the continuation lines containing point. + +If there are no continuation lines, move point to end-of-line." + (end-of-line) + (unless (bobp) + (catch 'eob + (while (save-excursion (backward-char) + (looking-at "\\\\")) + (end-of-line 2) + (if (eobp) (throw 'eob nil)))))) + +;; Save-excursion wrappers for the above to return point at beginning +;; or end of continuation +(defun gnuplot-point-at-beginning-of-continuation (&optional pos) + "Return value of point at beginning of the continued block containing point. + +If there are no continuation lines, returns point-at-bol." + (save-excursion + (when pos (goto-char pos)) + (gnuplot-beginning-of-continuation) + (point))) + +(defun gnuplot-point-at-end-of-continuation (&optional pos) + "Return value of point at the end of the continued block containing point. + +If there are no continuation lines, returns point-at-eol." + (save-excursion + (when pos (goto-char pos)) + (gnuplot-end-of-continuation) + (point))) + +;; We also treat a block of continuation lines as a 'defun' for +;; movement purposes +(defun gnuplot-beginning-of-defun (&optional arg) + (if (not arg) (setq arg 1)) + (if (> arg 0) + (catch 'bob ; go to beginning of ARGth prev. defun + (dotimes (n arg) + (when (= (point) + (gnuplot-point-at-beginning-of-continuation)) + (forward-line -1) + (if (bobp) (throw 'bob t)) + (while (looking-at "^\\s-*$") + (forward-line -1) + (if (bobp) (throw 'bob t)))) + (gnuplot-beginning-of-continuation)) + t) + + (catch 'eob ; find beginning of (-ARG)th following defun + (dotimes (n (- arg)) + (gnuplot-end-of-continuation) + (forward-line) + (if (eobp) (throw 'eob t)) + (while (looking-at "^\\s-*$") + (forward-line) + (if (eobp) (throw 'eob t))))))) + +;; Movement to start or end of command, including multiple commands +;; separated by semicolons +(defun gnuplot-beginning-of-command () + "Move point to beginning of command containing point." + (let ((limit (gnuplot-point-at-beginning-of-continuation))) + (while + (and + (search-backward ";" limit 'lim) + (gnuplot-in-string-or-comment))) + (skip-chars-forward ";") + (skip-syntax-forward "-"))) + +(defun gnuplot-end-of-command () + "Move point to end of command containing point." + (let ((limit (gnuplot-point-at-end-of-continuation))) + (while + (and + (search-forward ";" limit 'lim) + (gnuplot-in-string-or-comment))) + (skip-chars-backward ";") + (skip-syntax-backward "-"))) + +(defun gnuplot-point-at-beginning-of-command () + "Return position at the beginning of command containing point." + (save-excursion (gnuplot-beginning-of-command) (point))) + +(defun gnuplot-point-at-end-of-command () + "Return position at the end of command containing point." + (save-excursion (gnuplot-end-of-command) (point))) + +(defun gnuplot-negate-option () + "Append \"no\" to or remove \"no\" from the set option on the current line. +This checks if the set option is one which has a negated form. + +Negatable options are defined in `gnuplot-keywords-negatable-options'." + (interactive) + (gnuplot-fetch-version-number) + (let ((begin (gnuplot-point-at-beginning-of-command)) + (end (gnuplot-point-at-end-of-command)) + (regex gnuplot-negatable-options-regexp)) + (save-excursion + (goto-char begin) + (skip-syntax-forward "-" end) + (if (looking-at "\\(un\\)?set\\s-+") + (cond ((> (string-to-number gnuplot-program-version) 3.7) + (cond ((looking-at "unset") + (delete-char 2)) + ((looking-at (concat "set\\s-+\\(" regex "\\)")) + (insert "un")) + (t + (message "There is not a negatable set option on this line")))) + (t + (goto-char (match-end 0)) + (if (> (point) end) (goto-char end)) + (cond ((looking-at "no") + (delete-char 2)) + ((looking-at regex) + (insert "no")) + (t + (message "There is not a negatable set option on this line"))))) + (message "There is not a set option on this line")) ))) + +;; (defun gnuplot-set-binding () +;; "Interactively select a key sequence for binding to a plot function. +;; This is only useful in gnuplot 3.8 and for plot terminals which support +;; key bindings (i.e. those covered by pm3d)." +;; (interactive) +;; (let ((keyseq (read-key-sequence "Choose a key sequence now")) +;; (command (read-string "Bind to this command > "))) +;; (setq keyseq (format "%S" keyseq)) +;; (string-match "keypress-event\\s-+" keyseq) +;; (setq keyseq (substring keyseq (match-end 0) -2)) +;; ;; need to convert from emacs nomenclature to gnuplot. what a pain. +;; (let* ((alist '(("backspace" . "Backspace") ("tab" . "Tab") ("linefeed" . "Linefeed") +;; ("clear" . "Clear") ("return" . "Return") ("pause" . "Pause") +;; ("scroll-lock" . "Scroll_Lock") ("SysReq" . "sys-req") +;; ("escape" . "Escape") ("delete" . "Delete") ("home" . "Home") +;; ("left" . "Left") ("right" . "Right") ("up" . "Up") ("down" . "Down") +;; ("prior" . "PageUp") ("next" . "PageDown") ("end" . "End") +;; ("begin". "Begin"))) +;; (match (assoc keyseq alist))) +;; (if match (setq keyseq (cdr match))) +;; +;; (insert (format "bind \"%s\" \"%s\"" keyseq command))))) + + +(defun gnuplot-customize () + "Customize `gnuplot-mode'." + (interactive) + (if (fboundp 'customize-group) + (customize-group "gnuplot") + (message "The Custom library is not installed."))) + + + +;;; --- help from the info file, keyword list + completion, insert function + + +;; set up stuff for info-look (as suggested by ) +;; modified with suggestion from +(defun gnuplot-setup-info-look () + "Setup info-look in the gnuplot buffer. + +Also set the variable `gnuplot-keywords' and do something sensible if +info-look was not available. +See the comments in `gnuplot-info-hook'." + (interactive) + (setq gnuplot-keywords-pending nil) + (if (featurep 'info-look) + (progn + (gnuplot-fetch-version-number) + + ;; In the absence of evidence to the contrary, I'm guessing + ;; the info file layout changed with gnuplot version 4 + (let ((doc-spec + (if (>= (string-to-number gnuplot-program-version) 4.0) + ;; New info-file layout - works with gnuplot 4.4 + '(("(gnuplot)Command_Index" nil "[_a-zA-Z0-9]+") + ("(gnuplot)Options_Index" nil "[_a-zA-Z0-9]+") + ("(gnuplot)Function_Index" nil "[_a-zA-Z0-9]+") + ("(gnuplot)Terminal_Index" nil "[_a-zA-Z0-9]+")) + + ;; Old info-file layout + '(("(gnuplot)Top" nil "[_a-zA-Z0-9]+") + ("(gnuplot)Commands" nil "[_a-zA-Z0-9]+") + ("(gnuplot)Functions" nil "[_a-zA-Z0-9]+") + ("(gnuplot)plot" nil "[_a-zA-Z0-9]+") + ("(gnuplot)set-show" nil "[_a-zA-Z0-9]+") + ("(gnuplot)data-file" nil "[_a-zA-Z0-9]+") + ("(gnuplot)smooth" nil "[_a-zA-Z0-9]+") + ("(gnuplot)style" nil "[_a-zA-Z0-9]+") + ("(gnuplot)terminal" nil "[_a-zA-Z0-9]+"))))) + (cond ((boundp 'info-lookup-symbol-alist) ; older info-lookup version + (setq info-lookup-symbol-alist + (append + info-lookup-symbol-alist + `((gnuplot-mode + "[a-zA-Z][_a-zA-Z0-9]*" nil + ,doc-spec "[_a-zA-Z0-9]+" ))))) + (t ; newer version + (info-lookup-add-help + :mode 'gnuplot-mode :topic 'symbol + :regexp "[a-zA-Z][_a-zA-Z0-9]*" + :doc-spec doc-spec) + ;; allow help lookup from the comint buffer as well + (info-lookup-add-help + :mode 'gnuplot-comint-mode :topic 'symbol + :regexp "[a-zA-Z][_a-zA-Z0-9]*" + :doc-spec doc-spec)))) + + ;; this hook is my best way of working with info-look and + ;; allowing multiple versions of the gnuplot-info file. + ;; yes, this is a hassle. + (run-hooks 'gnuplot-info-hook) + (let ((there (bufferp (get-buffer "*info*")))) + (info-lookup-setup-mode 'symbol 'gnuplot-mode) + (or there (and (get-buffer "*info*") (kill-buffer "*info*"))) + ;; why are these buffers here? I think that the general + ;; user will not want them lying around + (and (get-buffer "info dir") (kill-buffer "info dir")) + (and (get-buffer "info dir<2>") (kill-buffer "info dir<2>"))) + (setq gnuplot-keywords (gnuplot-set-keywords-list)) + (setq gnuplot-keywords-alist ; needed for all-completions + (mapcar 'list gnuplot-keywords))) + + ;; or do something sensible if info-look is not installed + (defun info-lookup-interactive-arguments (symbol) + (message + "Help is not available. info-look.el is not installed.") + (list nil nil)))) + + +(defun gnuplot-set-keywords-list () + "Set `gnuplot-keywords' from `info-lookup-cache'. +Return a list of keywords." + (let* ((list (cdr (assoc 'symbol info-lookup-cache))) + (list (cdr (cdr (assoc 'gnuplot-mode list)))) + (list (car list)) + (store ()) item) + (while list + (setq item (car (car list)) + item (format "%s" item) ; keep this line for the sake of + store (append (list item) store) ; info-look.el w/o my patch + list (cdr list))) + (delete "nil" store) + store )) + + +;;;; Completion at point and Eldoc. + +;; There are two alternative completion-at-point mechanisms: the old +;; one using info-look and the new one (enabled by default) which +;; parses the command line to provide smarter completions. + +;; `gnuplot-completion-at-point-function' defines which one is +;; used. `gnuplot-context-sensitive-mode' toggles between the two. + +(defvar gnuplot-completion-at-point-function #'gnuplot-completion-at-point-info-look + "Function to call to perform completion in Gnuplot buffers.") + +(defun gnuplot-completion-at-point () + (funcall gnuplot-completion-at-point-function)) + +(defvar gnuplot-eldoc-hash nil + "ElDoc strings for gnuplot-mode. + +These have to be compiled from the Gnuplot source tree using +`doc2texi.el'.") + +;; Enable and disable context-sensitive completion +(define-minor-mode gnuplot-context-sensitive-mode + "Use context-sensitive completion and help in gnuplot-mode. + +When context-sensitive mode is enabled, gnuplot-mode tries to +provide more useful completions and help suggestions for built-in +keywords and functions by parsing each command as you type. It +attempts to take into account Gnuplot's many abbreviated +keywords. For example, with point at the end of a line reading +\"plot 'datafile' w \", typing \\[completion-at-point] will pop +up a list of plotting styles. + +Key bindings: + +\\[completion-at-point] will complete the keyword at point based +on its context in the command. To make keyword completion work on +pressing TAB, set `tab-always-indent' to `complete', or customize +`gnuplot-tab-completion' to make this automatic in gnuplot-mode +buffers. + +\\[gnuplot-info-at-point] will try to find the most relevant +Gnuplot info node for the construction at point, prompting for a +node name if nothing is found. + +\\[gnuplot-help-function] will pop up a brief summary of the +syntax at point in the minibuffer. To have one-line syntax +summaries appear in the echo area as you type, toggle +`eldoc-mode' or customize `gnuplot-eldoc-mode'. + +To choose whether to use this mode by default in Gnuplot buffers, +customize the variable +`gnuplot-use-context-sensitive-completion'. + +Note: help strings for eldoc-mode and \\[gnuplot-help-function] +need to be provided in an Emacs-readable form by the Gnuplot +distribution. See gnuplot-context.el for details." + :keymap + `((,(kbd "C-c C-/") . gnuplot-help-function) + (,(kbd "C-c C-d") . gnuplot-info-at-point)) + (unless (derived-mode-p 'gnuplot-mode 'gnuplot-comint-mode) + (message "Gnuplot context-sensitive mode works only in Gnuplot-mode buffers") + (setq gnuplot-context-sensitive-mode nil)) + (if gnuplot-context-sensitive-mode + ;; Turn on + (progn + (load-library "gnuplot-context") + (load-library "eldoc") + (setq gnuplot-completion-at-point-function #'gnuplot-context-completion-at-point) + + ;; Setup Eldoc + (set (make-local-variable 'eldoc-documentation-function) + 'gnuplot-eldoc-function) + (eldoc-add-command 'completion-at-point) ; Check for eldoc after completion + (when (fboundp 'comint-dynamic-complete) + (eldoc-add-command 'comint-dynamic-complete)) + + ;; Try to load Eldoc strings + (when gnuplot-eldoc-mode + (unless gnuplot-eldoc-hash + (condition-case nil + (load-library "gnuplot-eldoc") + (error + (message "gnuplot-eldoc.el not found. Install it from the Gnuplot distribution.") + (setq gnuplot-eldoc-hash nil + gnuplot-eldoc-mode nil)))) + + (if gnuplot-eldoc-hash + (eldoc-mode 1) + (eldoc-mode 0))) + + ;; Set up tab-to-complete + (when gnuplot-tab-completion + (set (make-local-variable 'tab-always-indent) 'complete)) + + (message "Gnuplot context-sensitive help & completion enabled.")) + + ;; Turn off + (setq gnuplot-completion-at-point-function #'gnuplot-completion-at-point-info-look) + (setq eldoc-documentation-function nil) + (eldoc-mode 0) + (message "Gnuplot context-sensitive help & completion disabled."))) + +;; Older completion method using info-look +(defun gnuplot-completion-at-point-info-look () + "Return completions of keyword preceding point. + +Uses the cache of keywords generated by info-lookup. See +`gnuplot-setup-info-look'. If not nil, the return value is in the form +\(BEGIN END COMPLETIONS) where BEGIN and END are buffer +positions and COMPLETIONS is a list." + + (if gnuplot-keywords-pending ; + (gnuplot-setup-info-look)) + (let* ((end (point)) + (beg (unwind-protect (save-excursion (backward-sexp 1) (point)))) + (patt (buffer-substring beg end)) + (pattern (if (string-match "\\([^ \t]*\\)\\s-+$" patt) + (match-string 1 patt) patt)) + (completions (all-completions pattern gnuplot-keywords-alist))) + (if completions + (list beg end completions) + (message "No gnuplot keywords complete '%s'" pattern) + nil))) + +(defun gnuplot-comint-complete () + "Complete the keyword preceding point in the gnuplot comint buffer. + +This is only used in Emacs versions before 24.1." + (let ((completions (gnuplot-completion-at-point))) + (if completions + (let* ((beg (nth 0 completions)) + (end (nth 1 completions)) + (candidates (nth 2 completions)) + (completion-base-position (list beg end))) + (comint-dynamic-simple-complete + (buffer-substring-no-properties beg end) + candidates)) + nil))) + + +(defun gnuplot-info-lookup-symbol (symbol &optional mode) + "Wrapper for `info-lookup-symbol'. +Takes SYMBOL and MODE as arguments exactly as +`info-lookup-symbol'. After doing the info lookup, calls +`gnuplot--adjust-info-display' to display the info buffer +according to the value of `gnuplot-info-display'." + (interactive + (cond (gnuplot-keywords + (info-lookup-interactive-arguments 'symbol)) + (gnuplot-keywords-pending ; + (gnuplot-setup-info-look) + (info-lookup-interactive-arguments 'symbol)) + (t + (list nil (message + "Help is not available. The gnuplot info file could not be found."))))) + + (when (and (featurep 'info-look) gnuplot-keywords) + (unless symbol (setq symbol "Commands")) + (save-window-excursion + (info-lookup-symbol symbol mode)) + (gnuplot--adjust-info-display))) + +(defun gnuplot--adjust-info-display () + "Displays the *info* buffer in a window or frame as specified +by the value of `gnuplot-info-display'. If +`gnuplot-info-display' is 'window, then the window will be shrunk +to the size of the info entry if it is smaller than half the +height of the frame. + +The *info* buffer should already exist when this function is +called." + (case gnuplot-info-display + (window + (switch-to-buffer-other-window "*info*") + ;; Adjust window height only if the frame is split + ;; horizontally, so as not to mess up the minibuffer + ;; we can't use shrink-window-if-larger-than-buffer here + ;; because it doesn't work with Info mode's narrowing + (with-selected-window (get-buffer-window "*info*") + (unless (gnuplot-window-full-height-p) + (enlarge-window + (min (- (count-lines (point-min) (point-max)) (window-height) -1) + (- (/ (frame-height) 2) (window-height))))))) + + (frame + (unless (and gnuplot-info-frame + (frame-live-p gnuplot-info-frame)) + (setq gnuplot-info-frame (make-frame))) + (select-frame gnuplot-info-frame) + (raise-frame gnuplot-info-frame) + (if gnuplot-xemacs-p (setq toolbar-info-frame gnuplot-info-frame)) + (switch-to-buffer "*info*")) + + (t + (switch-to-buffer "*info*")))) + +(defun gnuplot-insert (string) + "Insert STRING at point and display help for for STRING. +Help is not shown if `gnuplot-insertions-show-help-flag' is nil. The +help shown is for STRING unless STRING begins with the word \"set\" or +\"show\", in which case help is shown for the thing being set or +shown." + (interactive) + (cond ((and (not gnuplot-three-eight-p) + (string-match "\\(emf\\|p\\(alette\\|m3d\\)\\|vgagl\\)" string)) + (message "%S is an option introduced in gnuplot 3.8 (You are using %s)" + string gnuplot-program-version) ) + (t + (insert string) + (let ((topic string) term) + (if (string-match + "\\(set\\|show\\)[ \t]+\\([^ \t]+\\)\\(\\s-+\\([^ \t]+\\)\\)?" + string) + (progn + (setq topic (downcase (match-string 2 string)) + term (match-string 4 string)) + (if (string= topic "terminal") (setq topic (downcase term))))) + (cond ((and (fboundp 'gnuplot-gui-set-options-and-insert) + gnuplot-gui-popup-flag) + (gnuplot-gui-set-options-and-insert)) + (gnuplot-insertions-show-help-flag + (if gnuplot-keywords-pending ; + (gnuplot-setup-info-look)) + (gnuplot-info-lookup-symbol topic)) ) )) ) ) + +(defun gnuplot-toggle-info-display () + (interactive) + (setq gnuplot-insertions-show-help-flag (not gnuplot-insertions-show-help-flag)) + (message (if gnuplot-insertions-show-help-flag + "Help will be displayed after insertions." + "Help no longer displayed after insertions."))) + + +;;; --- bug reports +;; grep '(defcustom' gnuplot.el gnuplot-gui.el | awk '{print $2}' +(defun gnuplot-bug-report () + "Submit a bug report about `gnuplot-mode' by email. +Please do not send any bug reports about gnuplot itself to the +maintainer of `gnuplot-mode'." + (interactive) + (let ((line (make-string 62 ?-))) + (require 'reporter) + (and (y-or-n-p + "Do you really want to submit an email report about gnuplot? ") + (y-or-n-p + (concat "Variable values will be written to the message. " + "Don't erase them. OK? ")) + (reporter-submit-bug-report + (format "%s <%s>" gnuplot-maintainer gnuplot-maintainer-email) + (format "gnuplot-mode (version %s)" gnuplot-version) + (append ; variables to display values of in mail + '(gnuplot-mode-hook + gnuplot-load-hook + gnuplot-after-plot-hook + gnuplot-info-hook + gnuplot-comint-setup-hook + gnuplot-program + gnuplot-program-version + gnuplot-process-name + gnuplot-gnuplot-buffer + gnuplot-display-process + gnuplot-info-display + gnuplot-echo-command-line-flag + gnuplot-insertions-show-help-flag + gnuplot-delay + gnuplot-quote-character + gnuplot-keywords-when + ;;gnuplot-insertions-menu-flag + ;;gnuplot-insertions-adornments + ;;gnuplot-insertions-plot-options + ;;gnuplot-insertions-terminal + ;;gnuplot-insertions-x-axis + ;;gnuplot-insertions-x2-axis + ;;gnuplot-insertions-y-axis + ;;gnuplot-insertions-y2-axis + ;;gnuplot-insertions-z-axis + ;;gnuplot-insertions-parametric-plots + ;;gnuplot-insertions-polar-plots + ;;gnuplot-insertions-surface-plots + gnuplot-toolbar-display-flag + gnuplot-toolbar-use-toolbar + gnuplot-gui-popup-flag + gnuplot-gui-frame-plist + gnuplot-gui-frame-parameters + gnuplot-gui-fontname-list + gnuplot-gui-plot-splot-fit-style + gnuplot-inline-image-mode + gnuplot-tab-completion + gnuplot-eldoc-mode + gnuplot-context-sensitive-mode + gnuplot-basic-offset + gnuplot-buffer-max-size + gnuplot-comint-mode-hook + ;; plus a few more... + gnuplot-comint-recent-buffer + gnuplot-version + Info-directory-list + exec-path + features )) + nil ; pre-hooks + nil ; post-hooks + (concat line ; salutation + "\nInsert your description of the gnuplot-mode bug here.\n" + "Please be as specific as possible.\n\n" + "There are several known shortcomings of gnuplot-mode.\n" + "Many of these have to do with the complicated and inconsistent\n" + "syntax of gnuplot itself. See the document string for the\n" + "function `gnuplot-mode' (use `" + (substitute-command-keys "\\[describe-function]") + "') for details.\n\n" + "Note that this bug report form should be used for problems\n" + "with gnuplot-mode only. Problems with gnuplot itself should\n" + "be addressed directly to the developers of gnuplot.\n" + "The maintainer of gnuplot-mode will not field questions about\n" + "gnuplot itself. Thank you.\n" + line) + )))) + + + +;;; --- autoloaded functions: gnuplot-mode and gnuplot-make-buffer + +;;;###autoload +(defun gnuplot-mode () + "Major mode for editing and executing GNUPLOT scripts. +This was written with version 4.6 of gnuplot in mind, but should +work with newer and older versions. + +Report bugs in `gnuplot-mode' using \\[gnuplot-bug-report]. + + ------O------ + +Gnuplot-mode includes two different systems for keyword +completion and documentation lookup: a newer one, +`gnuplot-context-sensitive-mode' (enabled by default), and a +older one which extracts keywords from gnuplot's Info file. Both +systems allow looking up documentation in the Info file. The +older system also depends having the info file properly installed +to make a list of keywords. + +The info file should be installed by default with the Gnuplot +distribution, or is available at the `gnuplot-mode' web page: +http://github.com/bruceravel/gnuplot-mode/ + +With the new context-sensitive mode active, gnuplot-mode can also +provide `eldoc-mode' syntax hints as you type. This requires a +separate file of strings, `gnuplot-eldoc.el', which is also +provided by recent Gnuplot distributions. + + ------O------ + +There are several known shortcomings of `gnuplot-mode', version 0.5g +and up. Many of the shortcomings involve the graphical interface +\(refered to as the GUI) to setting arguments to plot options. Here is +a list: + + 1. Currently there is no way for `gnuplot-mode' to know if information + sent to gnuplot was correctly plotted. + 2. \"plot\", \"splot\", and \"fit\" are handled in the GUI, but are + a bit flaky. Their arguments may not be read correctly from + existing text, and continuation lines (common for plot and splot) + are not supported. + 3. The GUI does not know how to read from continuation lines. + 4. Comma separated position arguments to plot options are + unsupported in the GUI. Colon separated datafile modifiers (used + for plot, splot, and fit) are not supported either. Arguments + not yet supported by the GUI generate messages printed in grey + text. + 5. The GUI handling of \"hidden3d\" is flaky and \"cntrparam\" is + unsupported. + + ------O------ + + Key bindings: + \\{gnuplot-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map gnuplot-mode-map) + (setq major-mode 'gnuplot-mode + mode-name "Gnuplot") + (set (make-local-variable 'comment-start) "# ") + (set (make-local-variable 'comment-end) "") + (set (make-local-variable 'comment-column) 32) + (set (make-local-variable 'comment-start-skip) "#[ \t]*") + (set (make-local-variable 'indent-line-function) 'gnuplot-indent-line) + + (set (make-local-variable 'beginning-of-defun-function) 'gnuplot-beginning-of-defun) + (set (make-local-variable 'end-of-defun-function) 'gnuplot-end-of-continuation) + + (unless (featurep 'xemacs) + (add-hook 'completion-at-point-functions 'gnuplot-completion-at-point nil t)) + + (set-syntax-table gnuplot-mode-syntax-table) + + (when (eq gnuplot-keywords-when 'immediately) ; + (gnuplot-setup-info-look)) ;; + + (if gnuplot-xemacs-p ; deal with font-lock + (when (fboundp 'turn-on-font-lock) + (turn-on-font-lock)) + (progn + ;; Add syntax-propertizing functions to search for strings and comments + (set (make-local-variable 'syntax-propertize-function) + #'gnuplot-syntax-propertize) + (add-hook 'syntax-propertize-extend-region-functions + #'gnuplot-syntax-propertize-extend-region nil t) + + ;; Set up font-lock + (setq font-lock-defaults gnuplot-font-lock-defaults) + (set (make-local-variable 'font-lock-multiline) t) + (set (make-local-variable 'parse-sexp-lookup-properties) t))) + + (if (fboundp 'widget-create) ; gnuplot-gui + (condition-case () + (require 'gnuplot-gui) + (error nil))) + (setq gnuplot-first-call nil ; a few more details ... + gnuplot-comint-recent-buffer (current-buffer) + comint-process-echoes gnuplot-echo-command-line-flag) + (run-hooks 'gnuplot-mode-hook) + ;; the first time we need to figure out which gnuplot we are running + (if gnuplot-program-version + (gnuplot-setup-menu-and-toolbar) + (gnuplot-fetch-version-number))) + +;;;###autoload +(defun gnuplot-make-buffer () + "Open a new buffer in `gnuplot-mode'. +When invoked, it switches to a new, empty buffer visiting no file +and then starts `gnuplot-mode'. + +It is convenient to bind this function to a global key sequence. For +example, to make the F10 key open a gnuplot script buffer, put the +following in your .emacs file: + (autoload 'gnuplot-make-buffer \"gnuplot\" + \"open a buffer in gnuplot mode\" t) + (global-set-key [(f10)] 'gnuplot-make-buffer)" + (interactive) + (switch-to-buffer gnuplot-gnuplot-buffer) + (gnuplot-mode)) + +;;;###autoload +(defun run-gnuplot () + "Run an inferior Gnuplot process." + (interactive) + (gnuplot-make-gnuplot-buffer) + (pop-to-buffer gnuplot-buffer)) + +(defun gnuplot-show-version () + "Show version number in echo area" + (interactive) + (message "gnuplot-mode %s -- URL: %s" gnuplot-version gnuplot-maintainer-url)) + +(defun gnuplot-show-gnuplot-version () + "Show gnuplot program and version number in echo area" + (interactive) + (gnuplot-fetch-version-number) + (message "You are calling gnuplot %s as %s" gnuplot-program-version gnuplot-program)) + + +;;; That's it! ---------------------------------------------------------------- + + +;;; --- final chores: provide 'gnuplot and run load-hook +;; provide before run-hooks suggested by +(provide 'gnuplot) +(run-hooks 'gnuplot-load-hook) + +;;;============================================================================ +;;; + +;;; gnuplot.el ends here diff --git a/elpa/gnuplot-readme.txt b/elpa/gnuplot-readme.txt new file mode 100644 index 00000000..4f211189 --- /dev/null +++ b/elpa/gnuplot-readme.txt @@ -0,0 +1,122 @@ +This is a major mode for composing gnuplot scripts and displaying +their results using gnuplot. It supports features of recent +Gnuplot versions (4.4 and up), but should also work fine with older +versions. + +This version of gnuplot-mode has been tested mostly on GNU Emacs 23 +and 24, but should also work with older GNU Emacs versions back to +Emacs 21, and XEmacs 21. + +This mode offers several tools to help you compose your scripts, +including font-lock syntax colorization, a syntax table appropriate +to gnuplot, key bindings, pull-down menus, indentation, keyword +completions and variable customization using the Custom package. +Once the script is composed, there are several function for sending +some or all of the script to gnuplot. The interaction with the +gnuplot process is within a comint buffer. Plots can optionally be +displayed within Emacs. + + C-c C-l send current line to gnuplot + C-c C-v send current line to gnuplot and move forward 1 line + C-c C-r send current region to gnuplot + C-c C-b send entire buffer to gnuplot + C-c C-f send a file to gnuplot + C-c C-i insert filename at point + C-c C-n negate set option on current line + C-c C-c comment region + C-c C-o set arguments for command at point + S-mouse-2 set arguments for command under mouse cursor + C-c C-d read the gnuplot info file + C-c C-e show-gnuplot-buffer + C-c C-k kill gnuplot process + C-c C-u submit a bug report about gnuplot-mode + C-c C-z customize gnuplot-mode +M-tab or M-ret complete keyword before point + ret newline and indent + tab indent current line + C-c M-i toggle inline plot display in comint buffer + +With the exception of the commands for sending commands to Gnuplot, +most of the above commands also work in the Gnuplot comint buffer, +in addition to the following: + M-C-p plot the most recent script buffer line-by-line + M-C-f save the current script buffer and load that file + C-c C-e pop back to most recent script buffer + +These two functions are useful for starting up gnuplot-mode: + +M-x gnuplot-mode + start gnuplot-mode in the current buffer + +M-x gnuplot-make-buffer + open a new buffer (which is not visiting a file) and start + gnuplot-mode in that buffer + +Gnuplot-mode now includes context-sensitive support for keyword +completion and, optionally, eldoc-mode help text. See the +commentary in gnuplot-context.el for more information. If you +don't find it useful, it can be turned off by customizing +`gnuplot-context-sensitive-mode'. + + +--------------------------------------------------------------------- + +Other lisp files used by gnuplot.el + +gnuplot-gui.el (written by Bruce): + Defines the GUI interface for setting setting arguments to + gnuplot options. This uses the widget package extensively. + +gnuplot-context.el (written by Jonathan, j.j.oddie@gmail.com) + Context-sensitive completion, help lookup and eldoc + strings for gnuplot buffers. Should be byte-compiled before + using. + +--------------------------------------------------------------------- + +This mode was inspired by the original gnu-plot-mode by Gershon +Elber, which is distributed with gnuplot itself and which dates +back to the early 90's. Although this mode encompasses the +functionality of the original, the two share no code and the +current implementation takes advantage of many features of modern +versions of emacs and adheres (or so I intend) to the major mode +conventions described in the emacs-lisp reference for version 19 +and later. + +--------------------------------------------------------------------- + + Installation + ============ + +A recent version of this file can be found at + http://github.com/bruceravel/gnuplot-mode/ + +To autoload gnuplot-mode on any file with gp extension, put this in +your .emacs file + (autoload 'gnuplot-mode "gnuplot" "gnuplot major mode" t) + (autoload 'gnuplot-make-buffer "gnuplot" "open a buffer in gnuplot-mode" t) + +Something like + (setq auto-mode-alist (append '(("\\.gp$" . gnuplot-mode)) + auto-mode-alist)) +is useful for having files ending in .gp start up in gnuplot-mode. + +Something like + (global-set-key [(f9)] 'gnuplot-make-buffer) +may be useful. This binds f9 to the function that opens a scratch +buffer (i.e. one that is not visiting a file) in gnuplot-mode. +This is handy for your quick 'n' dirty plotting chores. + +To use the `gnuplot-info-lookup-symbol' function, the file +gnuplot.info MUST be installed somewhere that info can find it. +This means you must either: + 1. Copy gnuplot.info to the normal info directory or + 2. Make sure info can find gnuplot.info by putting this in your + .emacs file: + (setenv "INFOPATH" + (concat (getenv "INFOPATH") ":" + (expand-file-name "/path/to/file"))) + where "/path/to/file" is the location of gnuplot.info + +This mode has been tested extensively with GNU Emacs 23 and 24, and +in a limited manner with GNU Emacs 22 and XEmacs 21. diff --git a/elpa/hcl-mode-20160502.1700/hcl-mode-autoloads.el b/elpa/hcl-mode-20160502.1700/hcl-mode-autoloads.el new file mode 100644 index 00000000..f5b55767 --- /dev/null +++ b/elpa/hcl-mode-20160502.1700/hcl-mode-autoloads.el @@ -0,0 +1,23 @@ +;;; hcl-mode-autoloads.el --- automatically extracted autoloads +;; +;;; Code: +(add-to-list 'load-path (or (file-name-directory #$) (car load-path))) + +;;;### (autoloads nil "hcl-mode" "hcl-mode.el" (22473 28699 0 0)) +;;; Generated autoloads from hcl-mode.el + +(autoload 'hcl-mode "hcl-mode" "\ +Major mode for editing hcl configuration file + +\(fn)" t nil) + +(add-to-list 'auto-mode-alist '("\\.hcl\\'" . hcl-mode)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; End: +;;; hcl-mode-autoloads.el ends here diff --git a/elpa/hcl-mode-20160502.1700/hcl-mode-pkg.el b/elpa/hcl-mode-20160502.1700/hcl-mode-pkg.el new file mode 100644 index 00000000..d5544c3d --- /dev/null +++ b/elpa/hcl-mode-20160502.1700/hcl-mode-pkg.el @@ -0,0 +1 @@ +(define-package "hcl-mode" "20160502.1700" "Major mode for Hashicorp" '((emacs "24") (cl-lib "0.5")) :url "https://github.com/syohex/emacs-hcl-mode") diff --git a/elpa/hcl-mode-20160502.1700/hcl-mode.el b/elpa/hcl-mode-20160502.1700/hcl-mode.el new file mode 100644 index 00000000..59efe88f --- /dev/null +++ b/elpa/hcl-mode-20160502.1700/hcl-mode.el @@ -0,0 +1,217 @@ +;;; hcl-mode.el --- Major mode for Hashicorp + +;; Copyright (C) 2016 by Syohei YOSHIDA + +;; Author: Syohei YOSHIDA +;; URL: https://github.com/syohex/emacs-hcl-mode +;; Package-Version: 20160502.1700 +;; Version: 0.02 +;; 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: + +;; hcl-mode provides a major-mode of hcl file. + +;;; Code: + +(require 'cl-lib) +(require 'rx) + +(defgroup hcl nil + "Major mode of Hashicorp Configuration Language." + :group 'languages) + +(defcustom hcl-indent-level 2 + "The tab width to use when indenting." + :type 'integer) + +(defconst hcl--block-regexp + "^\\s-*[^{]+{") + +;; String Interpolation(This regexp is taken from ruby-mode) +(defconst hcl--string-interpolation-regexp + "\\${[^}\n\\\\]*\\(?:\\\\.[^}\n\\\\]*\\)*}") + +(defconst hcl--assignment-regexp + "\\s-*\\([[:word:]]+\\)\\s-*=\\(?:[^>=]\\)") + +(defconst hcl--map-regexp + "\\s-*\\([[:word:]]+\\)\\s-*{") + +(defconst hcl--boolean-regexp + (concat "\\(?:^\\|[^.]\\)" + (regexp-opt '("true" "false" "on" "off" "yes" "no") + 'words))) + +(defvar hcl-font-lock-keywords + `((,hcl--assignment-regexp 1 font-lock-variable-name-face) + (,hcl--boolean-regexp . font-lock-constant-face) + (,hcl--map-regexp 1 font-lock-type-face) + (,hcl--string-interpolation-regexp 0 font-lock-variable-name-face t))) + +(defsubst hcl--paren-level () + (car (syntax-ppss))) + +(defsubst hcl--in-string-or-comment-p () + (nth 8 (syntax-ppss))) + +(defun hcl--block-indentation () + (let ((curline (line-number-at-pos))) + (save-excursion + (condition-case nil + (progn + (backward-up-list) + (unless (= curline (line-number-at-pos)) + (current-indentation))) + (scan-error nil))))) + +(defun hcl--previous-indentation () + (save-excursion + (forward-line -1) + (let (finish) + (while (not finish) + (cond ((bobp) (setq finish t)) + ((hcl--in-string-or-comment-p) (forward-line -1)) + (t + (let ((line (buffer-substring-no-properties + (line-beginning-position) (line-end-position)))) + (if (not (string-match-p "\\`\\s-*\\'" line)) + (setq finish t) + (forward-line -1)))))) + (current-indentation)))) + +(defun hcl-indent-line () + "Indent current line as Hcl configuration." + (interactive) + (let* ((curpoint (point)) + (pos (- (point-max) curpoint))) + (back-to-indentation) + (if (hcl--in-string-or-comment-p) + (goto-char curpoint) + (let ((block-indentation (hcl--block-indentation))) + (delete-region (line-beginning-position) (point)) + (if block-indentation + (if (looking-at "[]}]") + (indent-to block-indentation) + (indent-to (+ block-indentation hcl-indent-level))) + (indent-to (hcl--previous-indentation))) + (when (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos))))))) + +(defun hcl-beginning-of-defun (&optional count) + (interactive "p") + (setq count (or count 1)) + (let ((match 0) + finish) + (while (and (not finish) + (re-search-backward hcl--block-regexp nil t)) + (unless (hcl--in-string-or-comment-p) + (cl-incf match) + (when (= match count) + (setq finish t)))))) + +(defun hcl-end-of-defun (&optional count) + (interactive "p") + (let ((paren-level (hcl--paren-level))) + (when (or (and (looking-at-p "}") (= paren-level 1)) + (= paren-level 0)) + (re-search-forward hcl--block-regexp nil t))) + (dotimes (_i count) + (when (looking-at-p hcl--block-regexp) + (goto-char (line-end-position))) + (hcl-beginning-of-defun 1) + (skip-chars-forward "^{") + (forward-char 1) + (let ((orig-level (hcl--paren-level))) + (while (>= (hcl--paren-level) orig-level) + (skip-chars-forward "^}") + (forward-line +1))))) + +(eval-and-compile + (defconst hcl--here-doc-beg-re + "<<[~-]?\\(?:\\([a-zA-Z0-9_]+\\)\\|\"\\([^\"]+\\)\"\\|'\\([^']+\\)'\\)")) + +(defun hcl--syntax-propertize-heredoc (limit) + (goto-char (match-beginning 0)) + (let ((heredoc-marker (cl-loop for i from 1 to 3 + when (match-string i) + return it))) + (put-text-property (point) (1+ (point)) 'syntax-table (string-to-syntax "|")) + (let ((end-re (concat "^\\(" heredoc-marker "\\)\\W"))) + (if (re-search-forward end-re nil t) + (goto-char (match-end 1)) + (goto-char (point-max))) + (put-text-property (1- (point)) (point) 'syntax-table (string-to-syntax "|")) + (goto-char (match-end 0))))) + +(defun hcl--syntax-propertize-function (start end) + (goto-char start) + (funcall + (syntax-propertize-rules + (hcl--here-doc-beg-re + (0 (ignore (hcl--syntax-propertize-heredoc end))))) + (point) end)) + +(defvar hcl-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-M-a") 'hcl-beginning-of-defun) + (define-key map (kbd "C-M-e") 'hcl-end-of-defun) + map) + "Keymap for Hcl major mode.") + +;;;###autoload +(define-derived-mode hcl-mode prog-mode "HCL" + "Major mode for editing hcl configuration file" + + (setq font-lock-defaults '((hcl-font-lock-keywords))) + + (modify-syntax-entry ?_ "w" hcl-mode-syntax-table) + + ;;; Comments + ;; Single line comment + (modify-syntax-entry ?# "< b" hcl-mode-syntax-table) + (modify-syntax-entry ?\n "> b" hcl-mode-syntax-table) + + ;; multiple line comment(/* ... */) taken from `go-mode' + (modify-syntax-entry ?/ ". 124b" hcl-mode-syntax-table) + (modify-syntax-entry ?* ". 23" hcl-mode-syntax-table) + + (set (make-local-variable 'comment-start) "#") + (set (make-local-variable 'comment-use-syntax) t) + (set (make-local-variable 'comment-start-skip) "\\(//+\\|/\\*+\\)\\s *") + + ;; indentation + (make-local-variable 'hcl-indent-level) + (set (make-local-variable 'indent-line-function) 'hcl-indent-line) + + (set (make-local-variable 'beginning-of-defun-function) + 'hcl-beginning-of-defun) + (set (make-local-variable 'end-of-defun-function) + 'hcl-end-of-defun) + + (set (make-local-variable 'syntax-propertize-function) + #'hcl--syntax-propertize-function) + + ;; electric-mode + (set (make-local-variable 'electric-indent-chars) + (append "{}[]" electric-indent-chars))) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.hcl\\'" . hcl-mode)) + +(provide 'hcl-mode) + +;;; hcl-mode.el ends here -- 2.47.3